source: tol/tolbaseBLT/lib/toltk/project.tcl @ 56ade3b

1941-docker-image-to-testdevel
Last change on this file since 56ade3b was 56ade3b, checked in by Jorge Pérez <josp.jorge@…>, 10 years ago

fixes #1932, se ha creado la rama trunk/tolbaseBLT copia de trunk/tolbase

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