source: tol/tolbase/lib/toltk/project.tcl @ 387e94b

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

Refs #1827
Se incorporan nuevos iconos para TOLBase 3.2. Se hace diferencia entre el TOL compilado con GNU-GCC (MinGW en Windows) y el TOL con MSVC.
Se introducen cambios en TOLBase para adoptar estas nuevas imágenes.

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