source: tol/tolbase/lib/toltk/project.tcl @ 9bb96e0b

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

refs #1259, implementamos el argumento '-np' en tol::initlibrary, interpretamos la opcion -np en tolsh y tolbase

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