source: tol/tolbase/lib/toltk/project.tcl @ a965ab8

1941-docker-image-to-testdevel
Last change on this file since a965ab8 was e87e769, checked in by Pedro Gea <pgea@…>, 11 years ago

Se reubica la asignación del icono de tolbase al método initWM para que funcione adecuadamente en Linux.
Se usa wm iconphoto para poder poner un icono con colores.
Podría incorporarse la imagen del icono ya escalada a distintos tamaños 16x16, 32x32 y 64x64

git-svn-id: ​https://www.tol-project.org/svn/tolp/trunk@7097 be4846ae-f051-483a-831f-b64e7d08527f
  • Property mode set to 100644
File size: 31.2 KB
Line 
1#/////////////////////////////////////////////////////////////////////////////
2# FILE    : project.tcl
3# PURPOSE : This file implement the comunication between the project and
4#           tolcon. Menu description is taken from
5#           http://mini.net/tcl/827.html, the implementation is in file
6#           prjmenu.tcl.
7#/////////////////////////////////////////////////////////////////////////////
8
9package require bfunctions
10package require btoplevel
11package require fmenu
12package require mdi
13package require bodbc
14
15#/////////////////////////////////////////////////////////////////////////////     
16namespace eval ::project {
17# 
18#/////////////////////////////////////////////////////////////////////////////       
19  variable data
20  variable events
21  variable widgets
22
23  array set projects {}
24
25  array set data {
26    name           ""
27    path           ""
28    killing        0
29    init           0
30    tolconreq      0
31    minmode        withdraw
32    minforzed      0
33    splashed       0
34    oculto         0
35    defaulthelpkey ""}
36  array set widgets {
37    children ""
38    children,types ""
39    children,type,default ""
40    children,saved ""
41    mainframe .
42  }
43  array set events {OnInitTcl "" OnInitTol "" OnExit ""}
44}
45
46
47#/////////////////////////////////////////////////////////////////////////////
48  proc ::project::project { inf } {
49#
50# PURPOSE: Defines the projects & initializes the namespace variables.
51#
52# PARAMETERS:
53#  name :
54#  path :
55#
56#/////////////////////////////////////////////////////////////////////////////
57  variable data
58  variable widgets
59  variable projects
60
61  # definition connection BODBC
62  set data(bodbc) [bodbc bodbcgestor]
63  #Tolcon_Trace "project.project : data(bodbc)=$data(bodbc)"
64
65  set projects(Project,splash) ""
66  set projects(Project,names) ""
67  array set projects $inf
68
69  array set events {OnInitTcl "" OnInitTol "" OnExit ""}
70  array unset widgets
71  array set data {
72    killing 0
73    init 0
74    tolconreq 0
75    minmode withdraw
76    minforzed 0
77    splashed 0
78    defaulthelpkey "Tb4Mai"}
79  array set widgets {
80    children ""
81    children,types ""
82    children,type,default ""
83    children,saved ""
84    mainframe .
85  }
86  # hide the main window, the one containing the menu bar
87  wm withdraw .
88  if { [expr ! $data(oculto)] } {
89    splashWindow
90  }
91}
92
93#/////////////////////////////////////////////////////////////////////////////
94  proc ::project::path { name } {
95#
96# PURPOSE: Returns the project path.
97#
98#/////////////////////////////////////////////////////////////////////////////
99  variable projects
100  return $projects($name,path)
101}
102
103
104#/////////////////////////////////////////////////////////////////////////////
105  proc ::project::init { } {
106#
107# PURPOSE:  Starts the project. If there is no project, it starts tolcon.
108#           Could be started only once.
109#
110#/////////////////////////////////////////////////////////////////////////////
111  global tcl_platform
112  variable data
113  variable widgets
114  variable projects
115
116  if { $data(init) } return
117  startupResources
118  initWM
119  if { [info exists projects(Project,names)] && \
120       [llength $projects(Project,names)] > 0 } {
121    load
122  } else {
123    UseTolCon
124  }
125  # Read .ini (paramters TolBase)
126  ::TolConsole::ReadIni
127 
128  # Gives a name for the application
129  if { [string equal $tcl_platform(platform) "unix"] } {
130    set prjtitle "TOLBase" 
131  } else {
132    # tol platform selection
133    array set tol_platform [lindex [toltcl::eval {PlatformInfo(?)} -named 1] 1]
134    if {$tol_platform(CompilerID) eq "GNU"} {
135      set prjtitle "TOLBase (GNU)"
136    } elseif {$tol_platform(CompilerID) eq "MSVC"} {
137      set prjtitle "TOLBase (MSVC)"
138    } else {
139      set prjtitle "TOLBase"
140    }
141  }
142 
143  if { [info exists projects(Project,title)] && $projects(Project,title) ne "" } {
144    set prjtitle $projects(Project,title)
145  }
146  wm title . $prjtitle
147
148  #Creamos frame de trabajo
149  set widgets(mainmenu) [::project::CreateMdiMenu .main.mdi]
150  set widgets(mainframe) [frame .main]
151  set widgets(mainmdi) [mdi .main.mdi -mdimenu $widgets(mainmenu) \
152                         -relief sunken -bd 1]
153  pack $widgets(mainmenu) -fill x -side top
154  pack $widgets(mainframe) -fill both -expand yes -side bottom
155  pack $widgets(mainmdi) -fill both -expand yes -side bottom
156  bind . <Control-Tab> "[list $widgets(mainmdi) cicle]; break"
157
158  ::TolConsole::MainFrame $widgets(mainmdi) [TolConReq]
159 
160  if { [TolConReq] } {
161    ::TolConsole::MenuMDI
162  }
163  foreach prj $projects(Project,names) {
164    set prjname $projects(${prj},name)
165    if { [string length $prjname] } { eval ${prjname}::InitTcl }
166  }
167  $widgets(mainmenu) draw
168
169  if { [TolConReq] } {
170    ::TolInspector::Busy
171  }
172#   update
173  if { $projects(Project,path,root) ne "" } {
174    set initol 0
175    set iniproject [ file join $projects(Project,path,root) "_iniproject.tol" ]
176  } else {
177    set initol $data(iniproject)
178    set iniproject ""
179  }
180  tol::initlibrary -initproject $initol -defaultpackages $data(defaultpackages)
181  if { $iniproject ne "" } {
182    # incluyo _iniproject.tol relativo a -project
183    tol::include $iniproject
184  }
185  foreach prj $projects(Project,names) {
186    set prjname $projects(${prj},name)
187    if { [string length $prjname] } { eval ${prjname}::InitTol }
188  }
189  #project::event InitTol
190  if { [TolConReq] } {
191    ::TolInspector::NotBusy
192  }
193  if { [expr ! $data(oculto)] } {
194    splashWindow
195  }
196
197  set data(init) 1
198}
199
200
201#/////////////////////////////////////////////////////////////////////////////
202  proc ::project::initWM { } {
203#
204# PURPOSE: Inits the events & protocols associated to toplevel.
205#
206#/////////////////////////////////////////////////////////////////////////////
207  global tcl_platform
208  global toltk_images_path
209  variable data
210 
211  bind . <Map> "::project::mapMain %W"
212  bind . <Unmap> "::project::unmapMain %W"
213  # establezco los protocolos
214  wm protocol . WM_DELETE_WINDOW [list ::project::OnDelete]
215  bind . <Destroy> "::project::OnDestroy %W"
216  set defgeom "[winfo vrootw .]x[winfo vrooth .]+0+0"
217 
218  #(pgea) se adelanta para no ver el icono de TK intermedio
219  if { [string equal $tcl_platform(platform) "unix"] } {
220    wm iconphoto . [image create photo .icon256 -format png -file [file join $toltk_images_path tolbase-256.png] ]
221  } else {
222    # tol platform selection
223    array set tol_platform [lindex [toltcl::eval {PlatformInfo(?)} -named 1] 1]
224    if {$tol_platform(CompilerID) eq "GNU"} {
225      wm iconbitmap . -default [file join $toltk_images_path tolbase-gnu.ico]
226    } elseif {$tol_platform(CompilerID) eq "MSVC"} {
227      wm iconbitmap . -default [file join $toltk_images_path tolbase-msvc.ico]
228    } else {
229      wm iconbitmap . -default [file join $toltk_images_path tolbase.ico]
230    }
231  }
232   
233  wm state . normal
234  wm geometry . [set geom [::iniFile::Read Project topgeom $defgeom]]
235puts "initWM: geometria: $geom"
236  if { [expr $project::data(oculto)] } {
237    wm iconify .
238  } else {
239    wm state . [::iniFile::ReadWMState ::iniFile::Read Project]
240  }
241  # update in order to . gets the geometry
242  update
243  showMain
244}
245
246#/////////////////////////////////////////////////////////////////////////////     
247proc ::project::OnDelete {} {
248# 
249#/////////////////////////////////////////////////////////////////////////////       
250  variable data
251
252  project::SetKilling
253  set answer [tk_messageBox -title [mc "Question"]\
254         -message [mc "Are you sure you want to quit?"] \
255         -type yesno -icon question]
256  if { [string compare $answer yes] == 0 } {
257    #::TolConsole::Exit
258    Exit
259  }
260  project::SetKilling 0
261}
262
263#/////////////////////////////////////////////////////////////////////////////     
264proc ::project::OnDestroy { w } {
265# 
266#/////////////////////////////////////////////////////////////////////////////       
267  variable data
268
269  if {$w eq "."} {
270    ::iniFile::Write Project topgeom  $data(geometry,main)
271    ::iniFile::Write Project wm,state $data(wm,state)
272    ::iniFile::CloseAll
273  }
274}
275
276#/////////////////////////////////////////////////////////////////////////////     
277proc project::Exit { } {
278# 
279#/////////////////////////////////////////////////////////////////////////////       
280  variable data
281  if {[event Exit] ne "cancel"} {
282    update idletasks
283    set data(geometry,main) [wm geometry .]
284    set data(wm,state)      [wm state    .]
285    destroy .
286  }
287}
288
289
290#/////////////////////////////////////////////////////////////////////////////
291  proc ::project::mapMain { w } {
292#
293# PURPOSE: proc to handle <Map> event, normally it is triggered when the "."
294#          window is restored after having being minimized.
295#
296# PARAMETERS:
297#  w :
298#
299#/////////////////////////////////////////////////////////////////////////////
300  variable widgets
301
302  if { [string compare $w .] } return
303  # restaurar descendientes
304  foreach c $widgets(children,saved) {
305    mapChild $c
306  }
307  set widgets(children,saved) ""
308}
309
310
311#/////////////////////////////////////////////////////////////////////////////
312  proc ::project::unmapMain { w } {
313#
314# PURPOSE: proc to handle <Unmap> event, normally it is triggered when the
315#          "." window is minimized.
316#
317# PARAMETERS:
318#  w :
319#
320#/////////////////////////////////////////////////////////////////////////////
321  variable widgets
322
323  if { [string compare $w .] } return
324  # guardar informacion de descendientes mapeados
325  foreach c $widgets(children) {
326    if [winfo ismapped $c] {
327      lappend widgets(children,saved) $c
328      unmapChild $c
329    }
330  }
331}
332
333
334#/////////////////////////////////////////////////////////////////////////////
335  proc ::project::UseTolCon { } {
336#
337# PURPOSE: Loads the code for using tolcon.
338#
339#/////////////////////////////////////////////////////////////////////////////
340  global toltk_script_path
341  variable data
342 
343  set data(tolconreq) 1
344  source [file join $toltk_script_path "tolbase.tcl"]
345}
346
347
348#/////////////////////////////////////////////////////////////////////////////
349   proc ::project::TolConReq { } {
350#
351# PURPOSE: Tells us if tolcon has being requested (project::UseTolCon).
352#
353#/////////////////////////////////////////////////////////////////////////////
354  variable data
355 
356  set data(tolconreq)
357}
358
359
360#/////////////////////////////////////////////////////////////////////////////
361  proc ::project::load {} {
362#
363# PURPOSE: Loads the given project. Looks for it in $toltk_library/$prj, if
364#          it is not found look as in development environment given by the
365#          alternative path $path (normally it will be
366#          $toltk_libray/../../../../entity)
367#
368#/////////////////////////////////////////////////////////////////////////////
369  variable data
370  variable projects
371  foreach prj $projects(Project,names) {
372    set prjname $projects(${prj},name)
373    if { [string length $prjname] } {
374      set init_file \
375          [file join $projects(${prj},path) tcl $projects(${prj},name).tcl]
376      if { [file exists $init_file] } {
377        source $init_file
378        eval $projects(${prj},name)::$projects(${prj},name)
379      } else {
380        error "could not load project '$projects(${prj},name)': \
381$projects(${prj},name).tcl not found. $init_file"
382      }
383    }
384  }
385}
386
387
388#/////////////////////////////////////////////////////////////////////////////
389  proc ::project::OnInitTcl { ev } {
390#
391# PURPOSE: Sets the proc to be invoked after toltk had loaded all its tcl/tk
392#          components.
393#
394# PARAMETERS:
395#  ev :
396#
397#/////////////////////////////////////////////////////////////////////////////
398  variable events
399
400  set events(OnInitTcl) $ev
401}
402
403
404#/////////////////////////////////////////////////////////////////////////////
405  proc ::project::OnInitTol { ev } {
406#
407# PURPOSE: Sets the proc to be invoked after toltk had loaded TOL.
408#
409# PARAMETERS:
410#  ev :
411#
412#/////////////////////////////////////////////////////////////////////////////
413  variable events
414
415  set events(OnInitTol) $ev
416}
417
418#/////////////////////////////////////////////////////////////////////////////
419  proc ::project::OnExit { ev } {
420#
421# PURPOSE: Sets the proc to be invoked before exiting.
422#
423# PARAMETERS:
424#  ev :
425#
426#/////////////////////////////////////////////////////////////////////////////
427  variable events
428
429  set events(OnExit) $ev
430}
431
432#/////////////////////////////////////////////////////////////////////////////
433  proc ::project::menu { desc } {
434#
435# PURPOSE: Defines the menu of the toplevel window. For now, the project menu
436#          excludes toltk menu.
437#
438# PARAMETERS:
439#  desc :
440#
441#/////////////////////////////////////////////////////////////////////////////
442  variable widgets
443
444  prjmenu::create . $desc
445#   update
446#   set vrootw [winfo vrootw .]
447  #wm maxsize .  $vrootw 1
448#   wm geometry . [expr ${vrootw}-6]x1+0+0
449  # poner un frame en . de dimension 0x0 y pedir [winfo rootx $f]
450  # y asi tener un aproximado de la altura de (main), sumarle 5 o 6.
451#   set widgets(dummyframe) [frame .dummy]
452#   pack $widgets(dummyframe)
453#   showMain
454#   wm resizable . 0 0
455}
456
457
458#/////////////////////////////////////////////////////////////////////////////
459  proc ::project::showMain { } {
460#
461# PURPOSE: Shows the main window, the one having the menu bar.
462#
463#/////////////////////////////////////////////////////////////////////////////
464  if { [string equal [wm state .] "withdrawn"] } {
465    wm withdraw .
466    wm deiconify .
467    update
468  }
469}
470
471
472#/////////////////////////////////////////////////////////////////////////////
473  proc ::project::splashWindow { } {
474#
475# PURPOSE: Shows a splash window for the project if it is defined or the one
476#          found in images in tolcon. The image to show is splash.gif
477#
478#/////////////////////////////////////////////////////////////////////////////
479  variable data
480  variable projects
481  global toltk_library
482
483  if { $data(splashed) } return
484  set w .__splashw
485  if { [winfo exists $w] } {
486    image delete [$w.l cget -image]
487    destroy $w
488    set data(splashed) 1
489  } else {
490    set imgfile $projects(Project,splash)
491    if { $projects(Project,splash) eq "" } {
492      set imgfile [file join $toltk_library toltk images splash.gif]
493    }
494    if { [file exists $imgfile] } {
495      set img [image create photo -file $imgfile]
496      toplevel $w
497      wm withdraw $w
498      wm overrideredirect $w 1
499      label $w.l -image $img -relief ridge -bd 2
500      pack $w.l
501      update
502      wm geometry $w +[expr ([winfo vrootw .]-[winfo reqwidth $w])/2]+[expr ([winfo vrooth .]-[winfo reqheight $w])/2]
503      update
504      wm withdraw $w
505      wm deiconify $w
506      update
507    } else {
508      set data(splashed) 1
509    }
510  }
511}
512
513#/////////////////////////////////////////////////////////////////////////////     
514proc project::raiseSplash { } {
515# 
516#/////////////////////////////////////////////////////////////////////////////       
517  set w .__splashw
518  if { [winfo exists $w] } {
519    raise $w
520  }
521}
522
523#/////////////////////////////////////////////////////////////////////////////
524  proc ::project::DisableMenu { m e } {
525#
526# PURPOSE: Disables an entry or menu inside a menu.
527#
528# PARAMETERS:
529#   m : menu
530#   e : entry or menu to disable
531#
532#/////////////////////////////////////////////////////////////////////////////
533  ::prjmenu::disable . $m $e
534}
535
536
537#/////////////////////////////////////////////////////////////////////////////
538  proc ::project::EnableMenu { m e } {
539#
540# PURPOSE: Enables an entry or menu inside a menu.
541#
542# PARAMETERS:
543#   m : menu
544#   e : entry or menu to enable
545#
546#/////////////////////////////////////////////////////////////////////////////
547  ::prjmenu::enable . $m $e
548}
549
550
551#/////////////////////////////////////////////////////////////////////////////
552  proc ::project::hasmenu { } {
553#
554# PURPOSE: Tells us if the toplevel has a menu defined. 
555#
556#/////////////////////////////////////////////////////////////////////////////
557  string length [. cget -menu]
558}
559
560#/////////////////////////////////////////////////////////////////////////////     
561proc ::project::raiseChild { w } {
562# 
563#/////////////////////////////////////////////////////////////////////////////       
564  if {[winfo ismapped $w]} {
565    raise $w
566  } else {
567    mapChild $w
568  }
569}
570
571#/////////////////////////////////////////////////////////////////////////////
572  proc ::project::toggleChild { w } {
573#
574# PURPOSE: Changes the state of a registered child.
575#
576# PARAMETERS:
577#   w :
578#
579#/////////////////////////////////////////////////////////////////////////////
580  variable widgets
581
582  puts toggleChild
583
584  if {[winfo ismapped $w]} {
585    #unmapChild $w
586    #El usuario suele desmapear minimizando
587    #raise $w
588    puts "ismapped"
589    mapChild $w
590  } else {
591    mapChild $w
592  }
593}
594
595#/////////////////////////////////////////////////////////////////////////////
596  proc ::project::mapChild { w } {
597#
598# PURPOSE: Map an unmaped & registered child window. The way of unmapping
599#          depend on minimizeMode defined.
600#
601# PARAMETERS:
602#   w :
603#
604#/////////////////////////////////////////////////////////////////////////////
605  variable widgets
606  if { [string equal [minimizeMode] "withdraw"] } {
607    wm withdraw $w
608    if ![info exists widgets(child,geometry,$w)] {
609      set widgets(child,geometry,$w) 800x600
610    }
611    wm geometry $w $widgets(child,geometry,$w)
612  }
613  wm deiconify $w
614}
615
616
617#/////////////////////////////////////////////////////////////////////////////
618  proc ::project::unmapChild { w } {
619#
620# PURPOSE: Unmap a maped & registered child window. The way of unmapping
621#          depend on minimizeMode defined.
622#
623# PARAMETERS:
624#   w :
625#
626#/////////////////////////////////////////////////////////////////////////////
627  variable data
628  variable widgets
629 
630  set data(minforzed) 1
631  if { [string equal [minimizeMode] "withdraw"] } {
632    set widgets(child,geometry,$w) [wm geometry $w]
633    wm withdraw $w
634  } else {
635    wm iconify $w
636  }
637}
638
639
640#/////////////////////////////////////////////////////////////////////////////
641  proc ::project::ExternalBottom { } {
642#
643# PURPOSE: Returns the external bottom y-coordinate of the toplevel window.
644#          This is only an approximate value.
645#
646#/////////////////////////////////////////////////////////////////////////////
647  global tcl_platform
648  variable widgets
649
650  return [winfo rooty $widgets(mainframe)]
651
652  if { [string equal $tcl_platform(platform) "unix"] } {
653    set extra 12
654  } else {
655    set extra 5
656  }
657  expr [winfo rooty $widgets(dummyframe)] + $extra
658}
659
660
661#/////////////////////////////////////////////////////////////////////////////
662  proc ::project::event { ev } {
663#
664# PURPOSE: Call an event. Valids events are: InitTcl, InitTol, Exit.
665#
666# PARAMETERS:
667#   ev : Event to call
668#
669#/////////////////////////////////////////////////////////////////////////////
670  variable events
671
672  if {$events(On$ev) ne ""} {
673    eval $events(On$ev)
674  }
675}
676
677
678#/////////////////////////////////////////////////////////////////////////////
679proc ::project::SetKilling {{what 1}} {
680#
681# PURPOSE: Signal the killing of the whole aplication. That way when the rest
682#          of its children know they should destroy in case the have provide
683#          WM_DELETE_WINDOW protocol.
684#
685#/////////////////////////////////////////////////////////////////////////////
686  variable data
687  set data(killing) $what
688}
689
690
691#/////////////////////////////////////////////////////////////////////////////
692  proc ::project::IsKilling { } {
693#
694# PURPOSE: Returns if Is the application destroying?
695#
696#/////////////////////////////////////////////////////////////////////////////
697  variable data
698
699  set data(killing)
700}
701
702
703#/////////////////////////////////////////////////////////////////////////////
704  proc ::project::minimizeMode { args } {
705#
706# PURPOSE: sets/returns the minimize mode, could be:
707#    - withdraw
708#    - minimize
709#
710# PARAMETERS:
711#   args :
712#
713#/////////////////////////////////////////////////////////////////////////////
714  variable data
715
716  switch [llength $args] {
717    0       { set data(minmode) }
718    1       { set data(minmode) [lindex $args 0] }
719    default { error "wrong # args: '$args'"  }
720  }
721}
722
723
724#/////////////////////////////////////////////////////////////////////////////
725  proc ::project::postWindows { m } {
726#
727# PURPOSE: Proc to call when the menu Window is about to post.
728#
729# PARAMETERS:
730#   m : is the menu where to insert the entries. At least there will be one:
731#       "Tol Inspector".
732#
733#/////////////////////////////////////////////////////////////////////////////
734  variable widgets
735
736  $m delete 0 end
737  foreach subm [winfo children $m] {
738    $subm delete 0 end
739  }
740  $m add command -label [mc "Minimize all"]    -command "::project::minimizeAll"
741  $m add command -label [mc "Cascade"]         -command "::project::cascade"
742  $m add command -label [mc "Tile Horizontal"] -command "::project::tileHorizontal"
743  $m add command -label [mc "Tile Vertical"]   -command "::project::tileVertical"
744  $m add separator
745  foreach w $widgets(children,type,default) {
746    $m add command \
747        -label $widgets(child,label,$w) -command "::project::raiseChild $w"
748  }
749  foreach t $widgets(children,types) {
750    if { [string compare $t "default"] } {
751      set subm $m.m[join $t _]
752      if { ![winfo exists $subm] } {
753        ::menu $subm -tearoff 0
754      }
755      $m add cascade -label [mc $t] -menu $subm
756      foreach w $widgets(children,type,$t) {
757        $subm add command \
758          -label $widgets(child,label,$w) -command "::project::raiseChild $w"
759      }
760      $subm add separator
761      $subm add command -label [mc "Close all"]\
762             -command [list ::project::closeType $t]
763    }
764  }
765}
766
767#/////////////////////////////////////////////////////////////////////////////
768  proc ::project::closeType {type} {
769#
770# PURPOSE: Closes all windows of a specified type
771#
772# PARAMETERS:
773#   type: Type of windows we want to close
774#
775#/////////////////////////////////////////////////////////////////////////////
776  variable widgets
777
778  foreach d [lindex [$widgets(mainmdi) get_documents $type] 1] {
779    $d kill
780  }
781}
782
783#/////////////////////////////////////////////////////////////////////////////
784  proc ::project::registerChild { w args } {
785#
786# PURPOSE: registers a toplevel to be handled by window menu
787#
788# PARAMETERS:
789#   w:
790#   args:
791#
792#/////////////////////////////////////////////////////////////////////////////
793  variable widgets
794
795  if { [string compare [winfo toplevel $w] $w] } {
796    error "$w must be a toplevel"
797  }
798  array set options {
799    -type     default
800    -killmode kill
801  }
802  set options(-label) [wm title $w]
803  # override defaults options
804  array set options $args
805  if { [lsearch $widgets(children) $w] != -1} {
806    error "window $w is already registered"
807  }
808  if { [info exists options(-varlabel)] } {
809    set varlabel $options(-varlabel)
810    upvar \#0 $varlabel label
811    trace variable $options(-varlabel) w \
812        "::project::updateWindowDesc $w $varlabel; #"
813    set options(-label) $label
814  }
815  lappend widgets(children) $w
816  if { [lsearch $widgets(children,types) $options(-type)] == -1 } {
817    lappend widgets(children,types) $options(-type)
818  }
819  lappend widgets(children,type,$options(-type)) $w
820  set widgets(child,type,$w)     $options(-type)
821  set widgets(child,killmode,$w) $options(-killmode)
822  set widgets(child,label,$w)    $options(-label)
823  if { [string equal $options(-killmode) "hide"] } {
824    wm protocol $w WM_DELETE_WINDOW [list ::project::minimizeChild $w $w]
825  }
826  bind $w <Destroy> +[list ::project::deleteChildren %W $w]
827  bind $w <Unmap>   "::project::minimizeChild %W $w" 
828}
829
830
831#/////////////////////////////////////////////////////////////////////////////
832  proc ::project::updateWindowDesc { w varlabel } {
833#
834# PURPOSE:
835#
836# PARAMETERS:
837#   w :
838#   varlabel :
839#
840#/////////////////////////////////////////////////////////////////////////////
841  upvar \#0 $varlabel label
842  variable widgets
843
844  set widgets(child,label,$w) $label
845}
846
847
848#/////////////////////////////////////////////////////////////////////////////
849  proc ::project::minimizeAll {} {
850#
851# PURPOSE: Minimizes all windows
852#
853#/////////////////////////////////////////////////////////////////////////////
854  variable widgets
855  foreach c $widgets(children) {
856    unmapChild $c
857  }
858}
859
860
861#/////////////////////////////////////////////////////////////////////////////
862  proc ::project::cascade {} {
863#
864# PURPOSE:
865#
866#/////////////////////////////////////////////////////////////////////////////
867  variable widgets
868  set x 0
869  set y [ExternalBottom]
870  foreach c $widgets(children) {
871    wm geometry $c +$x+$y
872    mapChild $c
873    incr x 20
874    incr y 20
875  }
876}
877
878
879#/////////////////////////////////////////////////////////////////////////////
880  proc ::project::tileHorizontal {} {
881#
882# PURPOSE:
883#
884#/////////////////////////////////////////////////////////////////////////////
885  variable widgets
886  set widgets(children,tileVer) {}
887  foreach c $widgets(children) {
888    if [winfo ismapped $c] {
889      lappend widgets(children,tileVer) $c
890    }
891  }
892  set num    [llength $widgets(children,tileVer)]
893  set y [ExternalBottom]
894  set tWidth  [winfo vrootwidth  .]
895  set tHeight [expr [winfo vrootheight .] - $y - 30]
896 
897  if $num {
898    set height [expr ($tHeight/$num)-6]
899  }
900
901  foreach c $widgets(children,tileVer) {
902    wm geometry $c ${tWidth}x${height}+0+$y
903    incr y [expr $height + 6]
904  }
905}
906
907
908#/////////////////////////////////////////////////////////////////////////////
909  proc ::project::tileVertical {} {
910#
911# PURPOSE:
912#
913#/////////////////////////////////////////////////////////////////////////////
914  variable widgets
915  set widgets(children,tileHor) {}
916  foreach c $widgets(children) {
917    if [winfo ismapped $c] {
918      lappend widgets(children,tileHor) $c
919    }
920  }
921  set num    [llength $widgets(children,tileHor)]
922  set x 0
923  set y [ExternalBottom]
924  set tWidth  [winfo vrootwidth  .]
925  set tHeight [expr [winfo vrootheight .] - $y - 30]
926   
927  if $num  {
928    set width [expr ($tWidth/$num)-6]
929  }
930  foreach c $widgets(children,tileHor) {
931    wm geometry $c ${width}x${tHeight}+$x+$y
932    incr x [expr $width + 6]
933  }
934  #Tolcon_Trace "tWidth: $tWidth, tHeight: $tHeight, mapped: $num, width: $width, x: $x, y: $y"
935}
936
937
938#/////////////////////////////////////////////////////////////////////////////
939  proc ::project::minimizeChild { w _w } {
940#
941# PURPOSE: This is invoked when w == _w is going to be minimized. Actually it
942#          is invoked for all of it's descendents.
943#
944# PARAMETERS:
945#   w  :
946#   _w :
947#
948#/////////////////////////////////////////////////////////////////////////////
949  variable data
950  variable widgets
951
952  if { [string compare $w $_w] } return
953  if { $data(minforzed) } {
954    set data(minforzed) 0
955    return
956  }
957  if { [string equal [minimizeMode] "withdraw"] } {
958    set widgets(child,geometry,$w) [wm geometry $w]
959    wm withdraw $w
960  }
961}
962
963
964#/////////////////////////////////////////////////////////////////////////////
965  proc ::project::deleteChildren { w _w } {
966#
967# PURPOSE: handler to delete a child window registred by registerChild
968#
969# PARAMETERS:
970#   w  :
971#   _w :
972#
973#/////////////////////////////////////////////////////////////////////////////
974  variable widgets
975  if { [string compare $w $_w] } return
976  if { [string equal $widgets(child,killmode,$w) kill] } {
977    # unregister $w
978    blremove widgets(children) $w
979    set type $widgets(child,type,$w)
980    blremove widgets(children,type,$type) $w
981    unset widgets(child,type,$w)
982    set type_found 0
983    foreach i [array names widgets child,type,*] {
984      if {[string equal $type $widgets($i)]} {
985        set type_found 1
986        break
987      }
988    }
989    if { !$type_found } {
990      blremove widgets(children,types) $type
991    }
992    unset widgets(child,killmode,$w)
993    unset widgets(child,label,$w)
994    # kill $w as requested in registerChild
995    #destroy $w
996  } else {
997    if { [IsKilling] } {
998      # . is going down
999      # destroy $w
1000    } else {
1001      if { [string equal [minimizeMode] "withdraw"] } {
1002        set widgets(child,geometry,$w) [wm geometry $w]
1003        wm withdraw $w
1004      } else {
1005        wm iconify $w
1006      }
1007    }
1008  }
1009}
1010
1011#/////////////////////////////////////////////////////////////////////////////
1012  proc ::project::CreateForm {args} {
1013#
1014# PURPOSE: Create form
1015#
1016# PARAMETERS:
1017#   args : option-value pairs
1018#
1019#/////////////////////////////////////////////////////////////////////////////
1020  variable widgets
1021  # Default
1022
1023  #set path {}
1024  array set opts [list \
1025    -height   300 \
1026    -width    300 \
1027    -title    {} \
1028    -closecmd {} \
1029    -iniconfig {} \
1030    -type     {} \
1031    -unique 0 \
1032    -modal 0 \
1033    -x 0 \
1034    -y 0 \
1035    -state normal \
1036    -resizable 1 \
1037    -helpkey "Tb4Mai"
1038  ]
1039
1040  array set opts $args
1041
1042  if {([info exist opts(-geometry)]) && ([string length $opts(-geometry)])} {
1043    set opts(-state) normal
1044    set opts(-width)  [lindex [split $opts(-geometry) x] 0]
1045    set restgeom      [lindex [split $opts(-geometry) x] 1]
1046    set opts(-height) [lindex [split $restgeom +] 0]
1047    set opts(-x)      [lindex [split $restgeom +] 1]
1048    set opts(-y)      [lindex [split $restgeom +] 2]
1049  }
1050  #puts "Nombre: $w Lista: \n\ [array get opts]"
1051  set path [.main.mdi slave -title $opts(-title)   -type  $opts(-type) \
1052      -width $opts(-width) -height $opts(-height) -modal $opts(-modal) \
1053      -closecmd $opts(-closecmd) -iniconfig $opts(-iniconfig) \
1054      -resizable $opts(-resizable) -x $opts(-x) -y $opts(-y) \
1055      -state $opts(-state) -helpkey $opts(-helpkey) ]
1056  update
1057  return $path
1058}
1059
1060
1061#/////////////////////////////////////////////////////////////////////////////
1062  proc ::project::SelectDoc { dw } {
1063#
1064# PURPOSE: selects a mdi document
1065#
1066# PARAMTERS:
1067#  dw: the document window to select
1068#
1069#/////////////////////////////////////////////////////////////////////////////
1070  if { ([$dw cget -state] eq "minimized" ) ||
1071       ([$dw cget -state] eq "withdrawn") } {
1072    $dw restore
1073  } else  {
1074    $dw raise
1075  }
1076}
1077
1078
1079#/////////////////////////////////////////////////////////////////////////////
1080  proc ::project::FillWindowMenu {mdi m} {
1081#
1082# PURPOSE: Rellena el menu window
1083#
1084#/////////////////////////////////////////////////////////////////////////////
1085
1086  $m delete 0 end
1087  foreach cw [winfo children $m] {
1088    destroy $cw
1089  }
1090  $m add command -label [mc "Tile across"] -underline 0 -command "$mdi arrange tile"
1091  $m add command -label [mc "Tile horizontally"] -underline 5 \
1092                 -command "$mdi arrange hor"
1093  $m add command -label [mc "Tile vertically"] -underline 5 -command "$mdi arrange ver"
1094  $m add command -label [mc "Cascade"] -underline 0 -command "$mdi arrange cascade"
1095  $m add separator
1096  $m add command -label [mc "Arrange icons"] -underline 0 -command "$mdi arrange icons"
1097  $m add command -label [mc "Minimize all"] -underline 0 -command "$mdi arrange min"
1098  foreach t [$mdi get_types] {
1099    $m add cascade -label $t -menu $m.sub$t
1100    ::menu $m.sub$t -tearoff 0
1101    foreach d [lindex [$mdi get_documents $t] 1] {
1102      if {[$d cget -state] != "withdrawn"} {
1103        $m.sub$t add command -label [$d cget -title] -command "::project::SelectDoc $d "
1104      }
1105    }
1106    $m.sub$t add separator
1107    $m.sub$t add command -label [mc "Close all"] \
1108             -command [list ::project::closeType $t]
1109  }
1110  foreach d [lindex [$mdi get_documents {}] 1] {
1111    if {[$d cget -state] != "withdrawn"} {
1112      $m add command -label [$d cget -title] -command "::project::SelectDoc $d"
1113    }
1114  }
1115  if {[$m index end] > 6} {
1116    $m insert 7 separator
1117  }
1118}
1119
1120
1121#/////////////////////////////////////////////////////////////////////////////
1122  proc ::project::CreateMdiMenu { mdi } {
1123#
1124# PURPOSE: Crea un menu para mdi con las entradas basicas ayuda y ventanas
1125#
1126#/////////////////////////////////////////////////////////////////////////////
1127  set md [menudef create %AUTO%]
1128
1129  set id [$md add root cascade -label [mc &Window] \
1130              -postcommand [list ::project::FillWindowMenu $mdi %W]]
1131  set ::project::data(menuhook) $id
1132  $md add root separator
1133 
1134  set id [$md add root cascade -label [mc &Help]]
1135  set ::project::data(menuhookhelp) $id
1136 
1137  $md add $id command -label [mc "&About"]... \
1138      -command "::TolConsole::AboutShow"
1139  $md add $id command -label [mc "&TolBase"] \
1140      -command "::TolConsole::TolBaseHelp"
1141  mdimenu .mainmenu -definition $md
1142  return .mainmenu
1143}
Note: See TracBrowser for help on using the repository browser.