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

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

Refs #1938
Se generaliza la versión en los archivos de recursos .rc.
Se crean variables en tcl con las versiones de tolsh y tolbase.
Se simplifica el icono de tolbase en el caso GNU.
Se modifica el título de la aplicación para indicar versión y si es de 32-bits o de 64-bits.

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