--- /dev/null
+proc BrowserOMTDestroyWin {win} {
+ global Browser_Menu Browser_packinfo BrowserOMT_clarray BrowserOMT_maxy
+
+ set swin [$win.swin subwidget window]
+ $swin.can delete all
+ destroy $win
+ $Browser_Menu.windows.options delete $Browser_packinfo(womt)
+}
+
+# display a graph from class <classe> in a
+# toplevel window named $win.womt
+#
+# win : a window
+# classe : a class full name
+#
+proc BrowserOMTInitWindow {win classe disp} {
+ global Browser_Menu Browser_packinfo BrowserOMT_clarray BrowserOMT_maxy
+
+ if {$classe != "this"} {
+ set BrowserOMT_clarray(root) $classe
+ } else {
+ set classe $BrowserOMT_clarray(root)
+ }
+
+ if {[winfo exist $win.womt] == 0} {
+ toplevel $win.womt
+ $Browser_Menu.windows.options add command -label "Graphic" -command "raise $win.womt"
+ set Browser_packinfo(womt) [$Browser_Menu.windows.options index last]
+ wm title $win.womt "Graph"
+ wm geometry $win.womt 600x600+100+100
+
+ tixScrolledWindow $win.womt.swin
+
+ button $win.womt.menubar -state disabled -relief raise
+ menubutton $win.womt.menubar.menu1 -menu $win.womt.menubar.menu1.options -text "File"
+ menu $win.womt.menubar.menu1.options
+ $win.womt.menubar.menu1.options add command -label "PostScript" -command "BrowserOMTPostScript $win.womt"
+ $win.womt.menubar.menu1.options add command -label "Close" -command "BrowserOMTDestroyWin $win.womt"
+
+ tixForm $win.womt.menubar -top 2 -left 0 -right -0
+ tixForm $win.womt.menubar.menu1 -left 0 -top 0
+ tixForm $win.womt.swin -left 0 -top $win.womt.menubar -right -0 -bottom -0
+
+ set swin [$win.womt.swin subwidget window]
+ canvas $swin.can
+ pack $swin.can
+ }
+
+ set swin [$win.womt.swin subwidget window]
+ $swin.can delete all
+
+ wm title $win.womt "Graph : $classe"
+
+ set BrowserOMT_maxy {}
+ lappend BrowserOMT_maxy 5.0
+ lappend BrowserOMT_maxy 5.0
+ $swin.can configure -width 100.0 -height 100.0
+ BrowserOMTDrawBox $swin.can $classe [lindex $BrowserOMT_maxy 0] [lindex $BrowserOMT_maxy 1] $classe
+ BrowserOMTSetupCanva $swin.can
+
+ BrowserOMTInitScrollBar $win.womt.swin
+
+ unset BrowserOMT_clarray
+ unset BrowserOMT_maxy
+ set BrowserOMT_clarray(root) $classe
+}
+
+proc BrowserOMTSetupCanva {c} {
+ global BrowserOMT_maxy
+
+ set mx [expr {[lindex $BrowserOMT_maxy 0] + 10.0}]
+ set my [lindex $BrowserOMT_maxy 1]
+
+ if {$mx > $my} {
+ set r [expr {$my / $mx}]
+
+ if {$r < 0.65} {
+ set my [expr {$mx * 0.65}]
+ }
+ } elseif {$my > $mx} {
+ set r [expr {$mx / $my}]
+
+ if {$r < 0.65} {
+ set mx [expr {$my * 0.65}]
+ }
+ }
+ $c configure -height $my -width $mx
+# puts "$mx $my"
+}
+
+proc BrowserOMTPostScript {win} {
+ global BrowserOMT_printer BrowserOMT_printerok BrowserOMT_printerrotate
+
+ set BrowserOMT_printerrotate 0
+
+ toplevel $win.printer
+ label $win.printer.label -text "Printer name :"
+ entry $win.printer.entry -width 20 -relief sunken -bd 2 -textvariable BrowserOMT_printer
+ button $win.printer.ok -text "Ok"
+ button $win.printer.cancel -text "Cancel"
+ checkbutton $win.printer.rotate -text "Rotate" -variable BrowserOMT_printerrotate
+ tixForm $win.printer.label -top 4 -left 4
+ tixForm $win.printer.entry -top 4 -left $win.printer.label -right -4
+ tixForm $win.printer.rotate -top $win.printer.entry -left $win.printer.ok -right $win.printer.cancel
+ tixForm $win.printer.ok -top $win.printer.entry -bottom -0 -left 0
+ tixForm $win.printer.cancel -top $win.printer.entry -bottom -0 -right -0
+
+ set BrowserOMT_printerok -1
+
+ bind $win.printer.entry <Return> {
+ focus -force [winfo toplevel %W].ok
+ }
+ bind $win.printer.ok <Return> {
+ set BrowserOMT_printerok 1
+ }
+ bind $win.printer.ok <ButtonRelease-1> {
+ set BrowserOMT_printerok 1
+ }
+ bind $win.printer.cancel <ButtonRelease-1> {
+ set BrowserOMT_printerok 0
+ }
+ tixBusy $win on
+ tkwait variable BrowserOMT_printerok
+ tixBusy $win off
+
+ if {$BrowserOMT_printerok == 1} {
+ set swin [$win.swin subwidget window]
+ $swin.can postscript -file "/tmp/can.ps" -rotate $BrowserOMT_printerrotate -pageheight 28.5c -pagewidth 18.5c
+ catch {exec lpr -P$BrowserOMT_printer /tmp/can.ps}
+ }
+
+ destroy $win.printer
+}
+
+proc BrowserOMTToggleArrow {win type} {
+ set swin [$win.swin subwidget window]
+
+ if {$type == "I"} {
+ set color [$swin.can itemcget I -fill]
+
+ if {$color == ""} {
+ $swin.can itemconfigure I -fill grey40
+ } else {
+ $swin.can itemconfigure I -fill ""
+ }
+ } else {
+ set color [$swin.can itemcget C -fill]
+
+ if {$color == ""} {
+ $swin.can itemconfigure C -fill black
+ } else {
+ $swin.can itemconfigure C -fill ""
+ }
+ }
+}
+
+proc BrowserOMTGetMax {lmax l} {
+ set res {}
+
+ if {[lindex $lmax 0] < [lindex $l 0]} {
+ lappend res [lindex $l 0]
+ } else {
+ lappend res [lindex $lmax 0]
+ }
+
+ if {[lindex $lmax 1] < [lindex $l 1]} {
+ lappend res [lindex $l 1]
+ } else {
+ lappend res [lindex $lmax 1]
+ }
+
+ return $res
+}
+
+proc BrowserOMTDrawBox {where classe x y tag} {
+ global BrowserOMT_clarray BrowserOMT_maxy
+
+ set error [catch {msclinfo -t $classe}]
+
+ if {$error != 0} return
+
+ set incomplete [msclinfo -e $classe]
+
+ if {[info exist BrowserOMT_clarray($tag)]} return
+
+ set fnt "-adobe-helvetica-medium-r-normal--12-120-75-75-p-67-iso8859-1"
+ set x1 $x
+ set y1 $y
+ set x2 $x
+ set y2 $y
+ set inherits {}
+ set hasinh 0
+ set backcolor "yellow"
+ set thisbackcolor "yellow"
+
+ if {$incomplete == 0} {
+ if {$BrowserOMT_clarray(root) == $classe} {
+ set inherits [msclinfo -i $classe]
+ set hasinh [llength $inherits]
+ }
+ set backcolor "black"
+ set thisbackcolor "black"
+ }
+
+ if {$hasinh} {
+ set l {}
+ lappend l $x
+ lappend l $y
+ set BrowserOMT_maxy [BrowserOMTGetMax $BrowserOMT_maxy $l]
+ BrowserOMTSetupCanva $where
+
+ set p [lindex $inherits 0]
+ set rwidth [BrowserOMTDrawClass $where $p $x $y $p 0]
+ set x1 [lindex $rwidth 0]
+ set y1 [lindex $rwidth 1]
+ set x2 [lindex $rwidth 2]
+ set y2 [lindex $rwidth 3]
+ set xinh [expr {([lindex $BrowserOMT_clarray($p) 2] + [lindex $BrowserOMT_clarray($p) 0]) / 2.0}]
+ set yinh [lindex $BrowserOMT_clarray($p) 3]
+ }
+
+ if {![info exist BrowserOMT_clarray($tag)]} {
+ set thisclass 0
+
+ if {$BrowserOMT_clarray(root) == $classe} {
+ set thisclass 1
+ }
+ set rwidth [BrowserOMTDrawClass $where $classe $x1 [expr {$y2 + 40}] $tag $thisclass]
+ set x1 [lindex $rwidth 0]
+ set y1 [lindex $rwidth 1]
+ set x2 [lindex $rwidth 2]
+ set y2 [lindex $rwidth 3]
+ set l {}
+ lappend l [expr {$x2 - 10.0}]
+ lappend l [expr {$y2 + 40.0}]
+ set BrowserOMT_maxy [BrowserOMTGetMax $BrowserOMT_maxy $l]
+ BrowserOMTSetupCanva $where
+
+ if {$hasinh} {
+ set xinh [expr {$xinh - 10.0}]
+ set xout [expr {($x1 + $x2) / 2.0 - 10.0}]
+ set yout $y1
+ set xmid $xout
+ set ymid [expr {$yinh + 20.0}]
+ $where create line $xout $yout $xmid $ymid $xinh $ymid $xinh $yinh -arrow last -fill black -tags I -joinstyle round -width 0.1c
+ }
+
+ #
+ # RETURN if the class is incomplete
+ #
+ if {$incomplete != 0} {
+ return
+ }
+
+ if {$BrowserOMT_clarray(root) == $classe} {
+ set typeClass [msclinfo -t $classe]
+
+ foreach p [msclinfo -C $classe] {
+ set name [lindex $p 0]
+ set error [catch {msclinfo -t $name}]
+
+ if {$error == 0} {
+ if {$name != $classe} {
+ set rwidth [BrowserOMTDrawBox $where $name $x2 [lindex $BrowserOMT_maxy 1] $name]
+ lappend l [lindex $rwidth 2]
+ lappend l [lindex $rwidth 3]
+ set BrowserOMT_maxy [BrowserOMTGetMax $BrowserOMT_maxy $l]
+ BrowserOMTSetupCanva $where
+
+ set error [catch {msclinfo -t $name}]
+
+ if {$error == 0} {
+ set xout [expr {($x1 + $x2) / 2.0}]
+ set yin [expr {([lindex $BrowserOMT_clarray($name) 3] + [lindex $BrowserOMT_clarray($name) 1]) / 2.0}]
+ if {$yin < $y2} {
+ set yout $y1
+ } else {
+ set yout $y2
+ }
+ if {$xout > [lindex $BrowserOMT_clarray($name) 0]} {
+ set xin [lindex $BrowserOMT_clarray($name) 2]
+ } else {
+ set xin [lindex $BrowserOMT_clarray($name) 0]
+ }
+ set xmid $xout
+ set ymid $yin
+ $where create line $xout $yout $xmid $ymid $xin $yin -tags C -width 0.1c
+ $where create oval [expr {$xout - 5}] $yout [expr {$xout + 5}] [expr {$yout + 10}] -outline $thisbackcolor -fill black
+ if {[msclinfo -e $name] == 0} {
+ if {[msclinfo -P $name] || [msclinfo -T $name]} {
+ $where create rectangle [expr {$xin - 10}] [expr {$yin -5}] [expr {$xin}] [expr {$yin + 5}] -outline $thisbackcolor -fill white
+ } else {
+ $where create rectangle [expr {$xin - 10}] [expr {$yin -5}] [expr {$xin}] [expr {$yin + 5}] -outline $thisbackcolor -fill black
+ }
+ }
+ }
+ } else {
+ $where create line $x1 $y1 $x1 [expr {$y1 - 15.0}] [expr {$x1 + 15.0}] [expr {$y1 - 15.0}] [expr {$x1 + 15.0}] $y1 -tags C -width 0.1c
+ $where create oval $x1 $y1 [expr {$x1 + 10}] [expr {$y1 + 10}] -outline $thisbackcolor -fill black
+ }
+ }
+ }
+ set usex [expr {[lindex $BrowserOMT_maxy 0] + 70}]
+ set usey $y
+ set genclass ""
+ if {$typeClass == "instclass"} {
+ set genclass [msinstinfo -g $classe]
+ }
+ foreach p [msclinfo -u $classe] {
+ set error [catch {msclinfo -t $p}]
+
+ if {$error == 0 && ($genclass != $p)} {
+
+ if {$p != $classe} {
+ if {[info exist BrowserOMT_clarray($p)] == 0} {
+ set usey [expr {$usey + 50}]
+ set rwidth [BrowserOMTDrawClass $where $p $usex $usey $p 0]
+ set usey [lindex $rwidth 3]
+ set l {}
+ lappend l [lindex $rwidth 2]
+ lappend l [lindex $rwidth 3]
+ set BrowserOMT_maxy [BrowserOMTGetMax $BrowserOMT_maxy $l]
+ BrowserOMTSetupCanva $where
+
+ set error [catch {msclinfo -t $p}]
+
+ if {$error == 0} {
+ set xout $x2
+ set yout [expr {($y1 + $y2) / 2.0}]
+ set yin [expr {([lindex $BrowserOMT_clarray($p) 3] + [lindex $BrowserOMT_clarray($p) 1]) / 2.0}]
+ set xin [lindex $BrowserOMT_clarray($p) 0]
+ set xmid [expr {$usex - 30}]
+
+ set ymid $yout
+ set xmid1 $xmid
+ set ymid1 $yin
+ $where create line $xout $yout $xmid $ymid $xmid1 $ymid1 $xin $yin -tags C -width 0.1c -fill black
+ $where create oval $xout [expr {$yout - 5}] [expr {$xout + 10}] [expr {$yout + 5}] -outline $thisbackcolor -fill white
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+}
+
+
+proc BrowserOMTInitScrollBar {w} {
+ set hsb [$w subwidget hsb]
+ set vsb [$w subwidget vsb]
+ set hcmd [lindex [$hsb configure -command] 4]
+ set vcmd [lindex [$vsb configure -command] 4]
+ eval $hcmd moveto 0
+ eval $vcmd moveto 0
+ return
+}
+
+proc BrowserOMTDrawStandardClass {where classe x y tag istheclass} {
+ global BrowserOMT_clarray BrowserOMT_maxy
+
+ set incomplete [msclinfo -e $classe]
+ set txt ""
+ set fnt "-adobe-helvetica-medium-r-normal--12-120-75-75-p-67-iso8859-1"
+ set inherits {}
+ set hasinh 0
+ set backcolor "yellow"
+ set thisbackcolor "yellow"
+ set nestedclass ""
+
+ if {$incomplete == 0} {
+ set backcolor "black"
+ set thisbackcolor "black"
+ if {[msclinfo -n $classe]} {
+ set nestedclass [msclinfo -N $classe]
+ set nestedclass "($nestedclass) "
+ }
+ }
+
+ if {$BrowserOMT_clarray(root) == $classe} {
+ set txt "< $classe $nestedclass>\n\n"
+ } else {
+ set txt "$classe $nestedclass\n\n"
+ }
+
+ if {$incomplete == 0} {
+ if {$istheclass} {
+ set len [expr {[string length $classe] + 2}]
+ foreach p [msclinfo -m $classe] {
+ set mth [string range $p $len [string length $p]]
+ set txt "$txt $mth\n"
+ }
+ set txt "$txt\n"
+ }
+ }
+
+ $where create text $x $y -text $txt -anchor nw -tags grotas -font $fnt -justify left
+ set rwidth [$where bbox grotas]
+ set BrowserOMT_clarray($tag) $rwidth
+ $where delete grotas
+
+ set linex2 [lindex $rwidth 2]
+ set liney2 [lindex $rwidth 3]
+ set x1 [lindex $rwidth 0]
+ set y1 [lindex $rwidth 1]
+ set x2 [lindex $rwidth 2]
+ set y2 [lindex $rwidth 3]
+
+ if {$incomplete == 0} {
+ if {$istheclass} {
+ set len [expr {[string length $classe] + 2}]
+ set txt "$txt\n"
+ foreach p [msclinfo -C $classe] {
+ set txt "$txt $p\n"
+ }
+ set txt "$txt\n"
+ }
+ $where create text $x $y -text $txt -anchor nw -tags grotas -font $fnt -justify left
+ set rwidth [$where bbox grotas]
+ set BrowserOMT_clarray($tag) $rwidth
+ $where delete grotas
+ set x1 [lindex $rwidth 0]
+ set y1 [lindex $rwidth 1]
+ set x2 [lindex $rwidth 2]
+ set y2 [lindex $rwidth 3]
+ }
+
+ $where delete $tag
+
+ if {$BrowserOMT_clarray(root) == $classe} {
+ $where create rectangle $x1 $y1 $x2 $y2 -outline $thisbackcolor -fill white
+ $where create rectangle $x1 $y1 $x2 [expr {$y1+20.0}] -outline $thisbackcolor -fill grey
+ $where create line $x1 $liney2 $linex2 $liney2 -fill black
+ } else {
+ $where create rectangle $x1 $y1 $x2 $y2 -outline $backcolor -fill white
+ $where create rectangle $x1 $y1 $x2 [expr {$y1+20.0}] -outline $backcolor -fill grey
+ }
+
+ set tagtext [$where create text $x1 [expr {$y1 + 5.0}] -text $txt -anchor nw -tags $tag -font $fnt -justify left]
+
+ $where bind $tagtext <Button-1> {
+ global Browser_win
+ set t [%W find withtag current]
+
+ if {$t != ""} {
+ set name [lindex [%W gettags $t] 0]
+ BrowserOMTInitWindow $Browser_win $name 0
+ }
+ }
+
+ $where bind $tagtext <Any-Enter> {
+ %W itemconfigure current -fill red
+ }
+
+ $where bind $tagtext <Any-Leave> {
+ %W itemconfigure current -fill black
+ }
+
+ set posx [expr {$x1 + 10}]
+ set posy [expr {$y2 - 10}]
+ BrowserOMTAddStuff $where $classe $posx $posy $tag
+
+ return $rwidth
+}
+
+proc BrowserOMTDrawGenericClass {where classe x y tag istheclass} {
+ global BrowserOMT_clarray BrowserOMT_maxy
+
+ set incomplete [msclinfo -e $classe]
+ set txt ""
+ set fnt "-adobe-helvetica-medium-r-normal--12-120-75-75-p-67-iso8859-1"
+ set inherits {}
+ set hasinh 0
+ set backcolor "yellow"
+ set thisbackcolor "yellow"
+ set nestedclass ""
+
+ if {$incomplete == 0} {
+ set backcolor "black"
+ set thisbackcolor "black"
+ if {[msclinfo -n $classe]} {
+ set nestedclass [msclinfo -N $classe]
+ set nestedclass "($nestedclass) "
+ }
+ }
+
+ if {$BrowserOMT_clarray(root) == $classe} {
+ set txt "< $classe $nestedclass> : Generic\n\n"
+ } else {
+ set txt "$classe $nestedclass: Generic\n\n"
+ }
+
+ if {$incomplete == 0} {
+ set genType [msgeninfo -g $classe]
+ set len [llength $genType]
+ set txt "$txt <"
+ for {set i 0} {$i < $len} {incr i} {
+ if {$i != 0} {
+ set txt "$txt,[lindex $genType $i]"
+ } else {
+ set txt "$txt [lindex $genType $i]"
+ }
+ }
+ set txt "$txt >\n\n"
+
+ if {$istheclass} {
+ set len [expr {[string length $classe] + 2}]
+ foreach p [msclinfo -m $classe] {
+ set mth [string range $p $len [string length $p]]
+ set txt "$txt $mth\n"
+ }
+ set txt "$txt\n"
+ }
+ }
+
+ $where create text $x $y -text $txt -anchor nw -tags grotas -font $fnt -justify left
+ set rwidth [$where bbox grotas]
+ set BrowserOMT_clarray($tag) $rwidth
+ $where delete grotas
+
+ set linex2 [lindex $rwidth 2]
+ set liney2 [lindex $rwidth 3]
+ set x1 [lindex $rwidth 0]
+ set y1 [lindex $rwidth 1]
+ set x2 [lindex $rwidth 2]
+ set y2 [lindex $rwidth 3]
+
+ if {$incomplete == 0} {
+ if {$istheclass} {
+ set len [expr {[string length $classe] + 2}]
+ set txt "$txt\n"
+ foreach p [msclinfo -C $classe] {
+ set txt "$txt $p\n"
+ }
+ set txt "$txt\n"
+ }
+ $where create text $x $y -text $txt -anchor nw -tags grotas -font $fnt -justify left
+ set rwidth [$where bbox grotas]
+ set BrowserOMT_clarray($tag) $rwidth
+ $where delete grotas
+ set x1 [lindex $rwidth 0]
+ set y1 [lindex $rwidth 1]
+ set x2 [lindex $rwidth 2]
+ set y2 [lindex $rwidth 3]
+ }
+
+ $where delete $tag
+
+ if {$BrowserOMT_clarray(root) == $classe} {
+ $where create rectangle $x1 $y1 $x2 $y2 -outline $thisbackcolor -fill white
+ $where create rectangle $x1 $y1 $x2 [expr {$y1+20.0}] -outline $thisbackcolor -fill grey
+ $where create line $x1 $liney2 $linex2 $liney2 -fill black
+ } else {
+ $where create rectangle $x1 $y1 $x2 $y2 -outline $backcolor -fill white
+ $where create rectangle $x1 $y1 $x2 [expr {$y1+20.0}] -outline $backcolor -fill grey
+ }
+
+ set tagtext [$where create text $x1 [expr {$y1 + 5.0}] -text $txt -anchor nw -tags $tag -font $fnt -justify left]
+
+ $where bind $tagtext <Button-1> {
+ global Browser_win
+ set t [%W find withtag current]
+
+ if {$t != ""} {
+ set name [lindex [%W gettags $t] 0]
+ BrowserOMTInitWindow $Browser_win $name 0
+ }
+ }
+
+ $where bind $tagtext <Any-Enter> {
+ %W itemconfigure current -fill red
+ }
+
+ $where bind $tagtext <Any-Leave> {
+ %W itemconfigure current -fill black
+ }
+
+ set posx [expr {$x1 + 10}]
+ set posy [expr {$y2 - 10}]
+ BrowserOMTAddStuff $where $classe $posx $posy $tag
+
+ return $rwidth
+}
+
+proc BrowserOMTDrawInstClass {where classe x y tag istheclass} {
+ global BrowserOMT_clarray BrowserOMT_maxy
+
+ set incomplete [msclinfo -e $classe]
+ set txt ""
+ set fnt "-adobe-helvetica-medium-r-normal--12-120-75-75-p-67-iso8859-1"
+ set inherits {}
+ set hasinh 0
+ set backcolor "yellow"
+ set thisbackcolor "yellow"
+ set nestedclass ""
+
+ if {$incomplete == 0} {
+ set backcolor "black"
+ set thisbackcolor "black"
+ if {[msclinfo -n $classe]} {
+ set nestedclass [msclinfo -N $classe]
+ set nestedclass "($nestedclass) "
+ }
+ }
+
+ set genclass [msinstinfo -g $classe]
+ if {$BrowserOMT_clarray(root) == $classe} {
+ set txt "< $classe $nestedclass> : Instantiates\n\n"
+ } else {
+ set txt "$classe $nestedclass: Instantiates\n\n"
+ }
+
+ if {$incomplete == 0} {
+ set genType [msgeninfo -g $genclass]
+ set instType [msinstinfo -s $classe]
+ set len [llength $genType]
+
+ set txt "$txt $genclass <"
+ for {set i 0} {$i < $len} {incr i} {
+ if {$i != 0} {
+ set txt "$txt,[lindex $instType $i]"
+ } else {
+ set txt "$txt [lindex $instType $i]"
+ }
+ }
+ set txt "$txt >\n\n"
+
+ if {$istheclass} {
+ set len [expr {[string length $classe] + 2}]
+ foreach p [msclinfo -m $classe] {
+ set mth [string range $p $len [string length $p]]
+ set txt "$txt $mth\n"
+ }
+ set txt "$txt\n"
+ }
+ }
+
+ $where create text $x $y -text $txt -anchor nw -tags grotas -font $fnt -justify left
+ set rwidth [$where bbox grotas]
+ set BrowserOMT_clarray($tag) $rwidth
+ $where delete grotas
+
+ set linex2 [lindex $rwidth 2]
+ set liney2 [lindex $rwidth 3]
+ set x1 [lindex $rwidth 0]
+ set y1 [lindex $rwidth 1]
+ set x2 [lindex $rwidth 2]
+ set y2 [lindex $rwidth 3]
+
+ if {$incomplete == 0} {
+ if {$istheclass} {
+ set len [expr {[string length $classe] + 2}]
+ set txt "$txt\n"
+ foreach p [msclinfo -C $classe] {
+ set txt "$txt $p\n"
+ }
+ set txt "$txt\n"
+ }
+ $where create text $x $y -text $txt -anchor nw -tags grotas -font $fnt -justify left
+ set rwidth [$where bbox grotas]
+ set BrowserOMT_clarray($tag) $rwidth
+ $where delete grotas
+ set x1 [lindex $rwidth 0]
+ set y1 [lindex $rwidth 1]
+ set x2 [lindex $rwidth 2]
+ set y2 [lindex $rwidth 3]
+ }
+
+ $where delete $tag
+
+ if {$BrowserOMT_clarray(root) == $classe} {
+ $where create rectangle $x1 $y1 $x2 $y2 -outline $thisbackcolor -fill white
+ $where create rectangle $x1 $y1 $x2 [expr {$y1+20.0}] -outline $thisbackcolor -fill grey
+ $where create line $x1 $liney2 $linex2 $liney2 -fill black
+ } else {
+ $where create rectangle $x1 $y1 $x2 $y2 -outline $backcolor -fill white
+ $where create rectangle $x1 $y1 $x2 [expr {$y1+20.0}] -outline $backcolor -fill grey
+ }
+
+ set tagtext [$where create text $x1 [expr {$y1 + 5.0}] -text $txt -anchor nw -tags $tag -font $fnt -justify left]
+
+ $where bind $tagtext <Button-1> {
+ global Browser_win
+ set t [%W find withtag current]
+
+ if {$t != ""} {
+ set name [lindex [%W gettags $t] 0]
+ BrowserOMTInitWindow $Browser_win $name 0
+ }
+ }
+
+ $where bind $tagtext <Any-Enter> {
+ %W itemconfigure current -fill red
+ }
+
+ $where bind $tagtext <Any-Leave> {
+ %W itemconfigure current -fill black
+ }
+ set posx [expr {$x1 + 10}]
+ set posy [expr {$y2 - 10}]
+ BrowserOMTAddStuff $where $classe $posx $posy $tag
+
+ return $rwidth
+}
+
+proc BrowserOMTAddStuff {where classe x y tag} {
+ set posx $x
+ set posy $y
+
+ if {[msclinfo -p $classe]} {
+ set btm [tix getimage private]
+ $where create image $posx $posy -image $btm -tags $tag
+ set posx [expr {$posx + 16}]
+ }
+
+ if {[msclinfo -d $classe]} {
+ set btm [tix getimage abstract]
+ $where create image $posx $posy -image $btm -tags $tag
+ set posx [expr {$posx + 16}]
+ }
+
+ if {[msclinfo -P $classe]} {
+ set btm [tix getimage persistent]
+ $where create image $posx $posy -image $btm -tags $tag
+ set posx [expr {$posx + 16}]
+ } elseif {[msclinfo -S $classe]} {
+ set btm [tix getimage storable]
+ $where create image $posx $posy -image $btm -tags $tag
+ set posx [expr {$posx + 16}]
+ } elseif {[msclinfo -T $classe]} {
+ set btm [tix getimage transient]
+ $where create image $posx $posy -image $btm -tags $tag
+ set posx [expr {$posx + 16}]
+ }
+}
+
+proc BrowserOMTDrawClass {where classe x y tag istheclass} {
+ set Classtype [msclinfo -t $classe]
+ set rwidth {}
+
+ if {$Classtype == "stdclass"} {
+ set rwidth [BrowserOMTDrawStandardClass $where $classe $x $y $tag $istheclass]
+ } elseif {$Classtype == "genclass"} {
+ set rwidth [BrowserOMTDrawGenericClass $where $classe $x $y $tag $istheclass]
+ } elseif {$Classtype == "instclass"} {
+ set rwidth [BrowserOMTDrawInstClass $where $classe $x $y $tag $istheclass]
+ } else {
+ puts "Unknown type $Classtype for $classe"
+ }
+
+ return $rwidth
+}
--- /dev/null
+/* XPM */
+static char *MatraDatavision[] = {
+/* width height num_colors chars_per_pixel */
+" 110 40 6 1",
+/* colors */
+". c #ffffff",
+"# c #000000",
+"a c #999999",
+"b c #c7c7c7",
+"c c #0000ff",
+"d c #20b2aa",
+/* pixels */
+"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc",
+"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc",
+"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc",
+"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc",
+"ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc.c.c..dcccccccccccc",
+"cccc.ccccccccccc.ccccccccc.ccccccc.............ccc.......dccccccccccccc.cccccccccccccccccd.c.c..c..dcccccccccc",
+"cccc..ccccccccc..ccccccccd.dcccccc.............ccc........dcccccccccccd.dcccccccccccccccd.c.c..c..c.dccccccccc",
+"cccc...ccccccc...cccccccc...cccccc.............ccc...cc....ccccccccccc...ccccccccccccccd.c.c..c..c..ddcccccccc",
+"cccc....ccccc....cccccccd...dcccccccccc...cccccccc...ccd...ccccccccccd...dccccccccccccd.cccd.c..c..c..cccccccc",
+"cccc.....ccc.....ccccccc.....cccccccccc...cccccccc...cccd..cccccccccc.....cccccccccccd.c.ccccd.c..c...dccccccc",
+"cccc......c......ccccccc.....cccccccccc...cccccccc...ccd...cccccccccc.....ccccccccccc.c.c.cccccd.c....cccccccc",
+"cccc.............ccccccd.....dccccccccc...cccccccc...cc...dcccccccccd.....dcccccccccdc.c...dccccccd..c.ccccccc",
+"cccc...c.....c...cccccc...d...ccccccccc...cccccccc........cccccccccc...d...cccccccccc.c..c..dcccccccc..ccccccc",
+"cccc...cc...cc...cccccd...c...dcccccccc...cccccccc......dccccccccccd...d...dccccccccdc..c..dccccccccd..ccccccc",
+"cccc...ccc.ccc...ccccc...dcd...cccccccc...cccccccc......ccccccccccc...dcd...ccccccccc..c..ccccccc.c....ccccccc",
+"cccc...ccccccc...ccccc...ccc...cccccccc...cccccccc...d...cccccccccc...ccc...ccccccccc.c..cccccd..c.....ccccccc",
+"cccc...ccccccc...ccccd.........dccccccc...cccccccc...cd..dccccccccd.........dccccccccc..cccd....c.....dccccccc",
+"cccc...ccccccc...cccc...........ccccccc...cccccccc...cc...dccccccc...........ccccccccc.c..c....c......cccccccc",
+"cccc...ccccccc...cccd...ccccc...dcccccc...cccccccc...ccd...ccccccd...dcccd...dccccccccc..c....c......dcccccccc",
+"cccc...ccccccc...ccc...dcccccd...cccccc...cccccccc...cccd...ccccc...dcccccd...ccccccccccd....c......dccccccccc",
+"cccc...ccccccc...ccc...ccccccc...cccccc...cccccccc...cccc....cccc...ccccccc...ccccccccccc...c......dcccccccccc",
+"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccd.....dcccccccccccc",
+"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc",
+"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc",
+"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc",
+"cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc",
+"..............................................................................................................",
+"bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb",
+"bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb",
+"bbbbbbbbbbbbbbbbbbb####bbbbbbb#bbbb#####bbbb#bbbb#bbbbb#bb#bbb###bbb#bbb####bbb##bbb#bbbbbbbbbbbbbbbbbbbbbbbbb",
+"bbbbbbbbbbbbbbbbbbb#bbb#bbbbba#abbbbb#bbbbba#abbb#bbbbb#bb#bb#bbb#bb#bb#bbbb#bb#aabb#bbbbbbbbbbbbbbbbbbbbbbbbb",
+"bbbbbbbbbbbbbbbbbbb#bbbb#bbbb#b#bbbbb#bbbbb#b#bbbaabbbaabb#bb#bbbbbb#bb#bbbb#bb#b#bb#bbbbbbbbbbbbbbbbbbbbbbbbb",
+"bbbbbbbbbbbbbbbbbbb#bbbb#bbbaabaabbbb#bbbbaabaabbb#bbb#bbb#bbb###bbb#bb#bbbb#bb#baab#bbbbbbbbbbbbbbbbbbbbbbbbb",
+"bbbbbbbbbbbbbbbbbbb#bbbb#bbb#bbb#bbbb#bbbb#bbb#bbb#bbb#bbb#bbbbbb#bb#bb#bbbb#bb#bb#b#bbbbbbbbbbbbbbbbbbbbbbbbb",
+"bbbbbbbbbbbbbbbbbbb#bbbb#bba#####abbb#bbba#####abbaabaabbb#bbbbbb#bb#bb#bbbb#bb#bb#b#bbbbbbbbbbbbbbbbbbbbbbbbb",
+"bbbbbbbbbbbbbbbbbbb#bbb#bbb#bbbbb#bbb#bbb#bbbbb#bbb#b#bbbb#bb#bbb#bb#bb#bbbb#bb#bbaa#bbbbbbbbbbbbbbbbbbbbbbbbb",
+"bbbbbbbbbbbbbbbbbbb####bbbb#bbbbb#bbb#bbb#bbbbb#bbbb#bbbbb#bbb###bbb#bbb####bbb#bbb##bbbbbbbbbbbbbbbbbbbbbbbbb",
+"bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb",
+"bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb",
+"bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
+};
--- /dev/null
+proc wokBuild { {fast 0} } {
+
+ global IWOK_WINDOWS
+ global IWOK_GLOBALS
+ set w $IWOK_GLOBALS(toplevel)
+ set top [frame $w.thu -bd 1 -relief raised]
+
+ # Paned Window
+ #
+ set p [tixPanedWindow $top.p -orient horizontal]
+ pack $p -expand yes -fill both -padx 4 -pady 4
+
+ set p1 [$p add pane1 -expand 1] ; $p1 config -relief flat ; set IWOK_GLOBALS(tree,name) $p1
+ set p2 [$p add pane2 -expand 4] ; $p2 config -relief flat ; set IWOK_GLOBALS(canvas,name) $p2
+
+ # Tree
+ #
+ set tree [tixTree $p1.tree -options {hlist.separator "^" hlist.selectMode single }]
+
+ $tree config -opencmd [list wokNAV:Tree:Open $w] -browsecmd [list wokNAV:Tree:Browse $w]
+
+ # ScrolledWindow
+ #
+ set scr [tixScrolledWindow $p2.st]
+
+ pack $p1.tree -expand yes -fill both -padx 4 -pady 4
+ pack $p2.st -expand yes -fill both -padx 4 -pady 4
+
+ set IWOK_WINDOWS($w,NAV,tree) $tree
+ set IWOK_WINDOWS($w,NAV,hlist) [$tree subwidget hlist]
+ set IWOK_WINDOWS($w,NAV,scrolled) $scr
+ set IWOK_WINDOWS($w,NAV,window) [$p2.st subwidget window]
+
+ set IWOK_GLOBALS(canvas) [canvas $IWOK_WINDOWS($w,NAV,window).c]
+ $IWOK_GLOBALS(canvas) configure -width $IWOK_GLOBALS(canvas,width) -height $IWOK_GLOBALS(canvas,height)
+
+ wokButton initialize
+
+ button $w.mnu -state disabled -relief raised
+ menubutton $w.mnu.fil -menu $w.mnu.fil.menu0 -text "File"
+ menu $w.mnu.fil.menu0
+ $w.mnu.fil.menu0 add command -label "Exit" -command wokKillAll
+
+ menubutton $w.mnu.but -menu $w.mnu.but.menu1 -text "Windows"
+ $w.mnu.but configure -state disabled
+ menu $w.mnu.but.menu1
+ $w.mnu.but.menu1 add command -label "Hide all" -command wokHideAll
+ $w.mnu.but.menu1 add command -label "Show all" -command wokShowAll
+ $w.mnu.but.menu1 add separator
+
+ menubutton $w.mnu.hlp -menu $w.mnu.hlp.menu -text "Help"
+ menu $w.mnu.hlp.menu
+ $w.mnu.hlp.menu add command -label "Help" -command [list wokMainHelp $w]
+
+ tixForm $w.mnu -left 0 -right -0 -top 0
+ tixForm $w.mnu.fil -left 0 -top 0
+ tixForm $w.mnu.but -left $w.mnu.fil
+ tixForm $w.mnu.hlp -right -0 -top 0
+
+ set lastbut [wokButton create $w]
+ wokButton balloon
+
+ set dis [wokDSP:Init $w]
+ set mov [wokMOV:Init $w]
+
+ tixComboBox $w.l \
+ -variable IWOK_GLOBALS(CWD) \
+ -command wokSetLoc -label "Contents of:" \
+ -editable true -labelside left \
+ -history 1 -prunehistory 1 -histlimit 20
+ set IWOK_GLOBALS(label) $w.l
+ [set IWOK_GLOBALS(label,entry) [$IWOK_GLOBALS(label) subwidget entry]] configure -relief sunken
+
+ set arr [$w.l subwidget arrow] ; tixBalloon $arr.bal ; $arr.bal bind $arr -msg "Last spots"
+
+ button $w.mdtv -image [tix getimage MatraDatavision] -command wokSeeLayout
+ tixBalloon $w.mdtv.bal
+ $w.mdtv.bal bind $w.mdtv -msg "See Layout"
+
+ tixForm $dis -left $lastbut -bottom $top -top $w.mnu
+
+ tixForm $mov -left $dis -bottom $top -top $w.mnu
+
+ tixForm $IWOK_GLOBALS(label) -left $mov -bottom $top -top $w.mnu -right $w.mdtv
+ tixForm $w.mdtv -right -0 -bottom $top -top $w.mnu
+ tixForm $top -top $lastbut -left 0 -right -0 -bottom -0
+
+ set poph [wokPOP:hlist create $w] ; wokPOP:hlist initialize ; $poph bind $IWOK_WINDOWS($w,NAV,hlist)
+ set popc [wokPOP:canvas create $w] ; wokPOP:canvas initialize ; $popc bind $IWOK_GLOBALS(canvas)
+ ;#
+ ;# Go from current location.
+
+ wokNAV:Tree:UpdateSession $IWOK_GLOBALS(toplevel) [id user]
+ if { $fast == 0 } {
+ tixBusy $IWOK_GLOBALS(toplevel) on
+ update
+ wokMOV:Alonzi $IWOK_GLOBALS(toplevel) [wokcd]
+ wokMOV:wokcd
+ tixBusy $IWOK_GLOBALS(toplevel) off
+ } else {
+ wokButton session
+ }
+
+ wokCWD disable
+
+ $IWOK_GLOBALS(canvas) bind current <Button-1> {
+ wokNAV:Tree:Focus [winfo toplevel %W] [lindex [%W gettags current] 0]
+ }
+
+ $IWOK_GLOBALS(canvas) bind current <Button-3> {
+ eval "proc wokPOP:canvas:GetInfo { } { return \"[%W gettags current]\" }"
+ }
+
+}
+
+
+proc wokSetTypeDisplayed { str } {
+ global IWOK_GLOBALS
+ set IWOK_GLOBALS(canvas,TypeDisplayed) $str
+ return
+}
+
+proc wokGetTypeDisplayed { } {
+ global IWOK_GLOBALS
+ if [info exists IWOK_GLOBALS(canvas,TypeDisplayed)] {
+ return $IWOK_GLOBALS(canvas,TypeDisplayed)
+ } else {
+ return {}
+ }
+}
+
+proc wokSeeLayout { } {
+ global IWOK_GLOBALS
+ if { $IWOK_GLOBALS(layout) == 0 } {
+ set IWOK_GLOBALS(layout) 1
+ if { $IWOK_GLOBALS(layout,update) == 1 } {
+ wokUpdateLayout $IWOK_GLOBALS(CWD)
+ set IWOK_GLOBALS(layout,update) 0
+ }
+ wm geometry $IWOK_GLOBALS(toplevel) $IWOK_GLOBALS(toplevel,opened)
+ raise $IWOK_GLOBALS(toplevel)
+ } else {
+ set IWOK_GLOBALS(layout) 0
+ wm geometry $IWOK_GLOBALS(toplevel) $IWOK_GLOBALS(toplevel,closed)
+ }
+ return
+}
+
+proc wokSetLoc { loc } {
+ global IWOK_GLOBALS
+ tixBusy $IWOK_GLOBALS(toplevel) on
+ wokCWD updatehistory $loc
+ if { $IWOK_GLOBALS(layout) == 1 } {
+ set IWOK_GLOBALS(layout,update) 0
+ wokUpdateLayout $loc
+ } else {
+ set IWOK_GLOBALS(layout,update) 1
+ wokButton [wokNAV:tlist:Type $IWOK_GLOBALS(toplevel) $loc]
+ }
+ tixBusy $IWOK_GLOBALS(toplevel) off
+ return
+}
+
+proc wokUpdateLayout { loc } {
+ global IWOK_GLOBALS
+ set w $IWOK_GLOBALS(toplevel)
+ wokNAV:Tree:Show $w [wokNAV:tlist:Get $IWOK_GLOBALS(toplevel) $loc]
+ set type [wokNAV:tlist:Type $w $loc]
+ wokUpdateCanvas $w $loc
+ wokButton $type
+ raise $IWOK_GLOBALS(toplevel)
+ return
+}
+#
+# Retourne la liste des elements affiches dans le canvas.
+#
+proc wokListLayout { {option location} } {
+ global IWOK_GLOBALS
+ set canv $IWOK_GLOBALS(canvas)
+ set ll {}
+ foreach i [$canv find all] {
+ set x [$canv gettags $i]
+ if { "$option" == "location" } {
+ if { [lsearch $ll [lindex $x 1]] == -1 } {
+ lappend ll [lindex $x 1]
+ }
+ } elseif { "$option" == "anchor" } {
+ if { [lsearch $ll [lindex $x 0]] == -1 } {
+ lappend ll [lindex $x 0]
+ }
+ } elseif { "$option" == "type" } {
+ if { [lsearch $ll [lindex $x 2]] == -1 } {
+ lappend ll [lindex $x 2]
+ }
+ } elseif { "$option" == "names" } {
+ if { [lsearch $ll [lindex $x 3]] == -1 } {
+ lappend ll [lindex $x 3]
+ }
+ }
+ }
+ return $ll
+}
+;#
+;# Configure/cree les boutons
+;#
+;# Pour savoir si la fenetre browser est la:
+;# set val [wokButton getw browser]
+;# if $val != {} { val = list des toplevels allumes par le bouton }
+;# Pour avoir la liste des toplevels allumes par les boutons:
+;# set lst [wokButton listw]
+;# Pour remettre a zero l'etat du bouton browser:
+;# wokButton resetw browser
+;#
+proc wokButton { option {w nil} } {
+ global IWOK_GLOBALS
+
+ switch -glob -- $option {
+
+ initialize {
+ keylset IWOK_GLOBALS(blist) prepare [list z wokPrepare {wprepare}]
+ keylset IWOK_GLOBALS(blist) wbuild [list w winbuild {umake}]
+ keylset IWOK_GLOBALS(blist) browser [list b wokbrowser {CDL Browser}]
+ keylset IWOK_GLOBALS(blist) params [list p wokPRMAff {Parameters}]
+ }
+
+ create {
+ set blist $IWOK_GLOBALS(blist)
+ foreach i [keylkeys blist] {
+ set v [keylget blist $i]
+ set m [lindex $v 0]
+ set f [lindex $v 1]
+ lappend v [button $w.$m -height 32 -width 32 -image [tix getimage $i] -command $f]
+ keylset blist $i $v
+ set IWOK_GLOBALS(buttons,state,$i) {}
+ }
+
+ set prev {}
+ set curr {}
+
+ foreach i [keylkeys blist] {
+ set v [keylget blist $i]
+ set curr [lindex $v 0]
+ if { $prev == {} } {
+ tixForm $w.$curr -top $w.mnu
+ } else {
+ tixForm $w.$curr -left $w.$prev -top $w.mnu
+ }
+ set prev $curr
+ }
+
+ set IWOK_GLOBALS(buttons) $blist
+ return $w.$curr
+ }
+
+ balloon {
+ foreach b $IWOK_GLOBALS(buttons) {
+ set x [lindex $b 1]
+ tixBalloon [lindex $x end].bal
+ [lindex $x end].bal bind [lindex $x end] -msg "[lindex $x 2]"
+ }
+ }
+
+ disable {
+ foreach bt $w {
+ [lindex [keylget IWOK_GLOBALS(buttons) $bt] end] configure -state disabled
+ }
+
+ }
+
+ activate {
+ foreach bt $w {
+ [lindex [keylget IWOK_GLOBALS(buttons) $bt] end] configure -state normal
+ }
+ }
+
+
+ setw {
+ lappend IWOK_GLOBALS(buttons,state,[lindex $w 0]) [lindex $w 1]
+ wokUpdateWindowMenu [lindex $w 1]
+ }
+
+ delw {
+ set ltpl $IWOK_GLOBALS(buttons,state,[lindex $w 0])
+ set tpl [lindex $w 1]
+ set i [lsearch $ltpl $tpl]
+ if { $i != -1 } {
+ set IWOK_GLOBALS(buttons,state,[lindex $w 0]) [lreplace $ltpl $i $i]
+ wokRemoveWindowMenu $tpl
+ }
+ }
+
+ resetw {
+ set IWOK_GLOBALS(buttons,state,[lindex $w 0]) {}
+ }
+
+
+ getw {
+ return $IWOK_GLOBALS(buttons,state,[lindex $w 0])
+ }
+
+ listw {
+ set ll {}
+ foreach bb [array names IWOK_GLOBALS buttons,state,*] {
+ lappend ll [list [lindex [split $bb ,] 2] $IWOK_GLOBALS($bb)]
+ }
+ return $ll
+ }
+
+ session {
+ wokButton disable {params prepare wbuild browser}
+ }
+
+ factory {
+ wokButton disable {prepare wbuild browser}
+ wokButton activate params
+ }
+
+ workshop {
+ wokButton disable {prepare wbuild browser}
+ wokButton activate params
+ }
+
+ workbench {
+ wokButton activate {prepare wbuild browser params}
+ }
+
+ devunit_* {
+ wokButton activate {prepare wbuild browser params}
+ }
+
+ devunitstuff {
+ wokButton activate {prepare browser wbuild params}
+ }
+
+ }
+ return
+}
+
+proc wokReaff { } {
+ global IWOK_GLOBALS
+ if { "[set cwd [wokCWD read]]" != ":" } {
+ if { [set dad [wokNAV:Tlist:Dad $IWOK_GLOBALS(toplevel) $cwd]] != {} } {
+ wokCWD write $dad
+ }
+ }
+ return
+}
+
+proc wokReaffCanvas { } {
+ global IWOK_GLOBALS
+ wokUpdateCanvas $IWOK_GLOBALS(toplevel) [wokCWD read]
+ return
+}
+
+
+proc wokUpdateWindowMenu {wl} {
+ global IWOK_GLOBALS
+ if {![info exist IWOK_GLOBALS(menuwin,$wl)]} {
+ set wroot $IWOK_GLOBALS(toplevel)
+ set t "[wm title $wl]"
+ $wroot.mnu.but.menu1 add command -label $t -command "wokRaise $wl"
+ set ind [$wroot.mnu.but.menu1 index last]
+ set IWOK_GLOBALS(menuwin,$wl) $ind
+ $wroot.mnu.but configure -state active
+ }
+ return
+}
+
+proc wokRemoveWindowMenu {wl} {
+ global IWOK_GLOBALS
+ set wroot $IWOK_GLOBALS(toplevel)
+ if {[info exist IWOK_GLOBALS(menuwin,$wl)]} {
+ $wroot.mnu.but.menu1 delete $IWOK_GLOBALS(menuwin,$wl)
+ unset IWOK_GLOBALS(menuwin,$wl)
+ if { [$wroot.mnu.but.menu1 index last] == 0 } {
+ $wroot.mnu.but configure -state disabled
+ }
+ }
+ return
+}
+
+proc wokRaise { w } {
+ catch {
+ wm deiconify $w
+ raise $w
+ }
+ return
+}
+
+proc wokHideAll { } {
+ foreach ws [wokButton listw] {
+ foreach tpl [lindex $ws 1] {
+ catch {
+ lower $tpl
+ }
+ }
+ }
+}
+proc wokShowAll { } {
+ foreach ws [wokButton listw] {
+ wokRaise [lindex $ws 1]
+ }
+}
+proc wokMainHelp { w } {
+ global IWOK_GLOBALS
+ global IWOK_WINDOWS
+ global env
+
+ set IWOK_WINDOWS($w,help) [set wh .wokMainHelp]
+ if {[info exist IWOK_GLOBALS(windows)]} {
+ if {[lsearch $IWOK_GLOBALS(windows) $wh ] == -1} {
+ lappend IWOK_GLOBALS(windows) $wh
+ }
+ }
+
+ set whelp [wokHelp $wh "About iwok"]
+ set texte [lindex $whelp 0] ; set label [lindex $whelp 1]
+ wokReadFile $texte $env(WOK_LIBRARY)/wokMainHelp.hlp
+ wokFAM $texte <.*> { $texte tag add big first last }
+ $texte tag configure big -background Bisque3 -foreground black -borderwidth 2 \
+ -font -Adobe-Helvetica-Medium-R-Normal--*-120-* -relief raised
+ update
+ $texte configure -state disabled
+ return
+}
+;#
+;# Lit/ecrit/decode le contenu de Location. lire: [list fact shop wb unit]
+;#
+proc wokCWD { option args } {
+ global IWOK_GLOBALS
+ switch -- $option {
+
+ read {
+ return $IWOK_GLOBALS(CWD)
+ }
+
+
+ split {
+ set l {}
+ set str [wokCWD read]
+ if [wokinfo -x $str] {
+ set fact [wokinfo -f $str]
+ set shop [ lindex [split [wokinfo -s $str] :] end]
+ set wb [ lindex [split [wokinfo -w $str] :] end]
+ set unit [ lindex [split [wokinfo -u $str] :] end]
+ set l [list $fact $shop $wb $unit]
+ }
+ return $l
+ }
+
+ readnocell {
+ set ll [llength [set lc [split $IWOK_GLOBALS(CWD) :]]]
+ if { $ll != 5 } {
+ return $IWOK_GLOBALS(CWD)
+ } else {
+ return [join [lrange $lc 0 [expr $ll - 2]] :]
+ }
+ }
+
+ write {
+ set IWOK_GLOBALS(CWD) $args
+ return
+ }
+
+ writenocallback {
+ $IWOK_GLOBALS(label) configure -disablecallback true
+ set IWOK_GLOBALS(CWD) $args
+ $IWOK_GLOBALS(label) configure -disablecallback false
+ }
+
+ updatehistory {
+ $IWOK_GLOBALS(label,entry) configure -state normal
+ $IWOK_GLOBALS(label) appendhistory $args
+ $IWOK_GLOBALS(label,entry) configure -state disabled
+ }
+
+ deletefromhistory {
+ set entry $args
+ set lstb [$IWOK_GLOBALS(label) subwidget listbox]
+ set inx [lsearch [$lstb get 0 end] $entry]
+ if { $inx != -1 } {
+ $lstb delete $inx
+ }
+ }
+
+ disable {
+ $IWOK_GLOBALS(label,entry) configure -state disabled
+ }
+
+ }
+
+}
+;# (((((((((((((((((( P O P U P C A N V A S ))))))))))))))))))))
+;#
+;#
+;#^WOK^k3dev^iwok^WOKTclLib^admfile WOK:k3dev:iwok:WOKTclLib:admfile stuff_admfile admfile image35
+;# wokGetdevunitstuffdate {18 18 600 18 10 1.2} current
+;#
+proc wokPOP:canvas:cmd { action } {
+ set data [wokPOP:canvas:Selection]
+ set dir [lindex $data 0]
+ set loc [lindex $data 1]
+ set typ [lindex $data 2]
+ switch -- $action {
+ wokcd {
+ wokMOV:wokcd $loc
+ }
+
+ Add {
+ wokCreate $dir $loc
+ }
+
+ Delete {
+ wokDelete $dir $loc
+ }
+
+ Build {
+ set lud {}
+ set ltyp [split $typ _]
+ if { "[lindex $ltyp 0]" == "devunit" } { set lud [list [lindex $ltyp 1] [wokinfo -n $loc]] }
+ winbuild $loc $lud
+ }
+
+ Prepare {
+ set lud {}
+ set ltyp [split $typ _]
+ if { "[lindex $ltyp 0]" == "devunit" } { set lud [list [lindex $ltyp 1] [wokinfo -n $loc]] }
+ wokPrepare $loc $lud
+ }
+
+ Properties {
+ wokProperties $dir $loc $typ
+ }
+
+ }
+ return
+}
+;#
+;# retourne 1 si il faut filtrer des UDS ou activer le pop
+;#
+proc wokPOP:DoSelect { } {
+ if { [wokinfo -x [wokCWD read]] } {
+ if { "[wokinfo -t [wokCWD read]]" == "workbench" } {
+ return 1
+ } else {
+ return 0
+ }
+ } else {
+ return 0
+ }
+}
+proc wokPOP:canvas { option {w nil} } {
+ global IWOK_GLOBALS
+
+ switch -glob -- $option {
+
+ initialize {
+ $IWOK_GLOBALS(popc,mnu) add comm -lab [wokUtils:EASY:OneHead wokcd 30] \
+ -command [list wokPOP:canvas:cmd wokcd]
+ $IWOK_GLOBALS(popc,mnu) add separator
+ $IWOK_GLOBALS(popc,mnu) add casc -lab Select -menu $IWOK_GLOBALS(popc,mnu).selud
+ wokPOP:canvas initselud [menu $IWOK_GLOBALS(popc,mnu).selud -font $IWOK_GLOBALS(font)]
+ wokPOP:canvas initselext [menu $IWOK_GLOBALS(popc,mnu).selext -font $IWOK_GLOBALS(font)]
+ set IWOK_GLOBALS(popc,Selected) All
+ $IWOK_GLOBALS(popc,mnu) add separator
+ $IWOK_GLOBALS(popc,mnu) add comm -lab [wokUtils:EASY:OneHead Add 30] \
+ -command [list wokPOP:canvas:cmd Add]
+ $IWOK_GLOBALS(popc,mnu) add comm -lab [wokUtils:EASY:OneHead Delete 30] \
+ -command [list wokPOP:canvas:cmd Delete]
+ $IWOK_GLOBALS(popc,mnu) add separator
+ $IWOK_GLOBALS(popc,mnu) add comm -lab [wokUtils:EASY:OneHead Build 30] \
+ -command [list wokPOP:canvas:cmd Build]
+ $IWOK_GLOBALS(popc,mnu) add comm -lab [wokUtils:EASY:OneHead Prepare 30] \
+ -comm [list wokPOP:canvas:cmd Prepare]
+ $IWOK_GLOBALS(popc,mnu) add separator
+ $IWOK_GLOBALS(popc,mnu) add comm -lab [wokUtils:EASY:OneHead Properties 30] \
+ -comm [list wokPOP:canvas:cmd Properties]
+ }
+
+ create {
+ set IWOK_GLOBALS(popc) [tixPopupMenu $w.popc -postcmd [list wokPOP:canvas:PostCommand $w]]
+ set IWOK_GLOBALS(popc,mnu) [$IWOK_GLOBALS(popc) subwidget menu]
+ $IWOK_GLOBALS(popc,mnu) configure -font $IWOK_GLOBALS(font)
+ $IWOK_GLOBALS(popc) subwidget menubutton configure -font $IWOK_GLOBALS(font)
+ return $w.popc
+ }
+
+ initselud {
+ set llitm [linsert $IWOK_GLOBALS(ucreate-P) 0 [list All All]]
+ foreach t $llitm {
+ set xt [lindex $t 1]
+ $w add radio -lab $xt -vari IWOK_GLOBALS(popc,Selected) -comm wokReaffCanvas
+ }
+ }
+
+ initselext {
+ set llitm [linsert $IWOK_GLOBALS(ucreate-P) 0 [list All All]]
+ foreach t $llitm {
+ set xt [lindex $t 1]
+ if [info exists IWOK_GLOBALS(EXT,$xt,ext)] {
+ foreach e $IWOK_GLOBALS(EXT,$xt,ext) {
+ ;#puts "$w add radio -lab $e -comm "
+ }
+ }
+ }
+ }
+
+ disable {
+ foreach e $w {
+ $IWOK_GLOBALS(popc,mnu) entryconfigure ${e}* -state disabled
+ }
+ }
+
+ activate {
+ foreach e $w {
+ $IWOK_GLOBALS(popc,mnu) entryconfigure ${e}* -state active
+ }
+ }
+
+ activeselect {
+ set last [$IWOK_GLOBALS(popc,mnu) index last]
+ for {set i 0} {$i <= $last} {incr i} {
+ if { "[$IWOK_GLOBALS(popc,mnu) type $i]" != "separator" } {
+ $IWOK_GLOBALS(popc,mnu) entryconfigure $i -state disabled
+ }
+ }
+
+ if { [wokPOP:DoSelect] } {wokPOP:canvas activate Select}
+ }
+
+ factory {
+ wokPOP:canvas activate {wokcd Add Delete Properties}
+ wokPOP:canvas disable {Select Build Prepare}
+ }
+
+ workshop {
+ wokPOP:canvas activate {wokcd Add Delete Properties}
+ wokPOP:canvas disable {Select Build Prepare}
+ }
+
+ warehouse {
+ wokPOP:canvas activate {wokcd Properties}
+ wokPOP:canvas disable {Select Add Delete Build Prepare}
+ }
+
+ parcel {
+ wokPOP:canvas activate {wokcd Properties}
+ wokPOP:canvas disable {Select Add Delete Build Prepare }
+ }
+
+ workbench {
+ wokPOP:canvas activate {wokcd Add Delete Build Prepare Properties}
+ wokPOP:canvas disable {Select}
+ }
+
+ session {
+ wokPOP:canvas activate {}
+ wokPOP:canvas disable {Select wokcd Build Prepare Add Delete Properties}
+ }
+
+ stuff_* {
+ wokPOP:canvas activate {wokcd}
+ wokPOP:canvas disable {Select Add Delete Build Prepare Properties}
+ }
+
+ parcel_* {
+ wokPOP:canvas activate {Delete}
+ wokPOP:canvas disable {Add Delete wokcd Select Build Prepare Properties}
+ }
+
+ parcelstuff_* {
+ wokPOP:canvas activate {}
+ wokPOP:canvas disable {wokcd Add Delete Select Build Prepare Properties}
+ }
+
+ devunit_* {
+ wokPOP:canvas activate {wokcd Delete Properties Select Build Prepare}
+ wokPOP:canvas disable {Add }
+ }
+
+ trig_Repository {
+ wokPOP:canvas activate {}
+ wokPOP:canvas disable {wokcd Select Build Prepare Add Delete Properties}
+ }
+
+ trig_terminal {
+ wokPOP:canvas activate {Properties}
+ wokPOP:canvas disable {wokcd Add Delete Select Build Prepare}
+ }
+
+ trig_Queue {
+ wokPOP:canvas activate {Properties}
+ wokPOP:canvas disable {wokcd Select Build Prepare Add Delete }
+ }
+
+ }
+}
+;#
+;# Appelee avant l affichage du Popup sur la canvas . Recupere la selection
+;# front = coord x du separateur de la paned window
+;# taily = coord y du coin hg du canvas (aussi donc de la canvas)
+;# $x < $front vrai on est a gauche donc dans la canvas etc..
+;# En fonction du type met les menus specifiques.
+;#
+;# DANS le CANVAS:
+;# Mb3 sur un element: ouvrir (fait le double click / sauf si c est un terminal)
+;# apercu rapide
+;# supprimer/renommer/reconstruire/preparer
+;# proprietes
+;#
+proc wokPOP:canvas:PostCommand { w x y } {
+ global IWOK_GLOBALS
+ global IWOK_WINDOWS
+
+ if { "[info procs wokPOP:canvas:GetInfo]" != "" } {
+ set seltag [wokPOP:canvas:GetInfo]
+ set mtx [lindex $seltag 1]
+ set option [lindex $seltag 2]
+ rename wokPOP:canvas:GetInfo {}
+ } else {
+ set seltag {}
+ set mtx {Display}
+ set option activeselect
+ }
+ eval "proc wokPOP:canvas:Selection {} { return \"$seltag\" }"
+ set len [string length [lindex $seltag 1]]
+ if { $len <= 30 } {
+ $IWOK_GLOBALS(popc) subwidget menubutton configure -text [lindex $seltag 1]
+ } else {
+ $IWOK_GLOBALS(popc) subwidget menubutton configure -text [string range [lindex $seltag 1] 0 28]..
+ }
+ update
+ wokPOP:canvas $option
+ return 1
+}
+
+;# (((((((((((((((((( P O P U P H L I S T ))))))))))))))))))))
+;#
+;#
+;#
+proc wokPOP:hlist:cmd { action } {
+ set data [wokPOP:hlist:Selection] ;#WOK:k3dev:cle workbench cle image33 wokGetworkbenchdate {18 18 ...}
+ set dir [lindex $data 0]
+ set loc [lindex $data 1]
+ set typ [lindex $data 2]
+ switch -- $action {
+ wokcd {
+ wokMOV:wokcd $loc
+ }
+
+ Add {
+ wokCreate $dir $loc
+ }
+
+ Delete {
+ wokDelete $dir $loc
+ }
+
+ Build {
+ set lud {}
+ set ltyp [split $typ _]
+ if { "[lindex $ltyp 0]" == "devunit" } { set lud [list [lindex $ltyp 1] [wokinfo -n $loc]] }
+ winbuild $loc $lud
+ }
+
+ Prepare {
+ set lud {}
+ set ltyp [split $typ _]
+ if { "[lindex $ltyp 0]" == "devunit" } { set lud [list [lindex $ltyp 1] [wokinfo -n $loc]] }
+ wokPrepare $loc $lud
+ }
+
+ Properties {
+ wokProperties $dir $loc $typ
+ }
+
+ }
+ return
+}
+
+proc wokPOP:hlist { option {w nil} } {
+ global IWOK_GLOBALS
+
+ switch -glob -- $option {
+
+ initialize {
+
+ $IWOK_GLOBALS(poph,mnu) add comm -lab [wokUtils:EASY:OneHead wokcd 30] \
+ -comm [list wokPOP:hlist:cmd wokcd]
+ $IWOK_GLOBALS(poph,mnu) add separator
+ $IWOK_GLOBALS(poph,mnu) add comm -lab [wokUtils:EASY:OneHead Add 30] \
+ -comm [list wokPOP:hlist:cmd Add]
+ $IWOK_GLOBALS(poph,mnu) add comm -lab [wokUtils:EASY:OneHead Delete 30] \
+ -comm [list wokPOP:hlist:cmd Delete]
+ $IWOK_GLOBALS(poph,mnu) add separator
+ $IWOK_GLOBALS(poph,mnu) add comm -lab [wokUtils:EASY:OneHead Build 30] \
+ -comm [list wokPOP:hlist:cmd Build]
+ $IWOK_GLOBALS(poph,mnu) add comm -lab [wokUtils:EASY:OneHead Prepare 30] \
+ -comm [list wokPOP:hlist:cmd Prepare]
+ $IWOK_GLOBALS(poph,mnu) add separator
+ $IWOK_GLOBALS(poph,mnu) add comm -lab [wokUtils:EASY:OneHead Properties 30] \
+ -comm [list wokPOP:hlist:cmd Properties]
+ }
+
+ adjust {
+ }
+
+ create {
+ set IWOK_GLOBALS(poph) [tixPopupMenu $w.poph -postcmd [list wokPOP:hlist:PostCommand $w]]
+ set IWOK_GLOBALS(poph,mnu) [$IWOK_GLOBALS(poph) subwidget menu]
+ $IWOK_GLOBALS(poph,mnu) configure -font $IWOK_GLOBALS(font)
+ $IWOK_GLOBALS(poph) subwidget menubutton configure -font $IWOK_GLOBALS(font)
+ return $w.poph
+ }
+
+ disable {
+ foreach e $w {
+ $IWOK_GLOBALS(poph,mnu) entryconfigure ${e}* -state disabled
+ }
+ }
+
+ activate {
+ foreach e $w {
+ $IWOK_GLOBALS(poph,mnu) entryconfigure ${e}* -state active
+ }
+ }
+
+ factory {
+ wokPOP:hlist activate {wokcd Add Delete Properties}
+ wokPOP:hlist disable {Build Prepare}
+ }
+
+ workshop {
+ wokPOP:hlist activate {wokcd Add Delete Properties}
+ wokPOP:hlist disable {Build Prepare}
+ }
+
+ warehouse {
+ wokPOP:hlist activate {wokcd Properties }
+ wokPOP:hlist disable {Build Add Delete Prepare }
+ }
+
+ parcel {
+ wokPOP:hlist activate {wokcd Properties }
+ wokPOP:hlist disable {Add Delete Build Prepare }
+ }
+
+ workbench {
+ wokPOP:hlist activate {wokcd Add Delete Build Prepare Properties}
+ wokPOP:hlist disable {}
+ }
+
+ session {
+ wokPOP:hlist activate {Properties}
+ wokPOP:hlist disable {wokcd Build Prepare Add Delete}
+ }
+
+ stuff_* {
+ wokPOP:hlist activate {wokcd}
+ wokPOP:hlist disable {Build Add Delete Prepare Properties}
+ }
+
+ parcel_* {
+ wokPOP:hlist activate {}
+ wokPOP:hlist disable {wokcd Add Delete Build Prepare Properties}
+ }
+
+ parcelstuff_* {
+ wokPOP:hlist activate {}
+ wokPOP:hlist disable {wokcd Add Delete Build Prepare Properties}
+ }
+
+ devunit_* {
+ wokPOP:hlist activate {wokcd Delete Properties Build Prepare}
+ wokPOP:hlist disable { Add }
+ }
+
+ trig_Repository {
+ wokPOP:hlist activate {}
+ wokPOP:hlist disable {wokcd Add Delete Build Prepare Properties}
+ }
+
+ trig_terminal {
+ wokPOP:hlist activate {Properties}
+ wokPOP:hlist disable {wokcd Add Delete Build Prepare}
+ }
+
+ trig_Queue {
+ wokPOP:hlist activate {Properties}
+ wokPOP:hlist disable {wokcd Add Delete Build Prepare}
+ }
+ }
+}
+;#
+;# appelee avant le Post
+;#
+proc wokPOP:hlist:PostCommand { w x y } {
+ global IWOK_GLOBALS
+ global IWOK_WINDOWS
+ $IWOK_WINDOWS($w,NAV,hlist) anchor clear
+ $IWOK_WINDOWS($w,NAV,hlist) selection clear
+ set Y [expr $y - [winfo rooty $IWOK_GLOBALS(tree,name)]]
+ set hlist $IWOK_WINDOWS($w,NAV,hlist)
+ set nearest [$hlist nearest $Y]
+ set seltag [$hlist info data [$hlist nearest $Y]]
+ eval "proc wokPOP:hlist:Selection {} { return \"$nearest $seltag\" }"
+
+ set len [string length [lindex $seltag 0]]
+ if { $len <= 30 } {
+ $IWOK_GLOBALS(poph) subwidget menubutton configure -text [lindex $seltag 0]
+ } else {
+ $IWOK_GLOBALS(popc) subwidget menubutton configure -text [string range [lindex $seltag 0] 0 28]..
+ }
+ update
+ wokPOP:hlist [lindex $seltag 1]
+ return 1
+}
+
+
+;# (((((((((((((((((( D I S P L A Y ))))))))))))))))))))
+;#
+;# Selectionne dans l les uds du type selectionne. (IWOK_GLOBALS(popc,Selected) = package..)
+;#
+;# faudrait voir a speeder qunad il ne s'agit pas d'UD.
+;# il faut initialiser IWOK_GLOBALS(popc,Selected) a All
+proc wokSelType { l } {
+ global IWOK_GLOBALS
+ if { ![wokPOP:DoSelect] } { return $l }
+ if { "$IWOK_GLOBALS(popc,Selected)" == "All" } { return $l }
+ set ll {}
+ foreach x $l {
+ set rtyp [lindex [split [lindex $x 2] _] 1]
+ if { "$IWOK_GLOBALS(popc,Selected)" == "$rtyp" } {
+ lappend ll $x
+ }
+ }
+ return $ll
+}
+;#
+;# affiche les items dans le canvas.
+;#
+proc wokUpdateCanvas { w loc } {
+ set l [wokSelType [wokNAV:tlist:GetData $w $loc]]
+ set disp [wokNAV:tlist:Display $w $loc]
+ set func [wokDSP:Func]
+ set fdate [wokNAV:tlist:date $w $loc]
+ if [wokDSP:IsLong] {
+ if [wokDSP:IsLast] {
+ set ll [$fdate $l 1]
+ } else {
+ set ll [$fdate $l 0]
+ }
+ } else {
+ set ll $l
+ }
+ $func $disp $ll
+
+ return
+}
+;#
+proc wokDSP:Display { button toggle } {
+ global IWOK_GLOBALS
+ if { $toggle == 1 } {
+ set IWOK_GLOBALS(canvas,func) $IWOK_GLOBALS(canvas,func,$button)
+ wokUpdateCanvas $IWOK_GLOBALS(toplevel) [wokCWD read]
+ }
+ return
+}
+proc wokDSP:Init { w } {
+ global IWOK_GLOBALS
+
+ set ww [frame $w.myf]
+ tixSelect $ww.dis -allowzero false -radio true -command wokDSP:Display \
+ -label "" \
+ -variable IWOK_GLOBALS(canvas,format) \
+ -options {
+ label.width 0
+ label.padx 0
+ label.anchor n
+ }
+
+ set msg(byrow) "Rows" ;set IWOK_GLOBALS(canvas,func,byrow) wokUpdatePage_xy;# X- X-
+ set msg(bycol) "Columns" ;set IWOK_GLOBALS(canvas,func,bycol) wokUpdatePage_tt;# X-
+ set msg(bylong) "Date/Size" ;set IWOK_GLOBALS(canvas,func,bylong) wokUpdatePage_cy;# X- -
+ set msg(bylast) "Last modified first" ;set IWOK_GLOBALS(canvas,func,bylast) wokUpdatePage_cy;# Y- -
+
+
+ foreach bix [array names msg] {
+ $ww.dis add $bix -image [tix getimage $bix]
+ set bux [$ww.dis subwidget $bix]
+ tixBalloon ${bux}.bal
+ ${bux}.bal bind ${bux} -msg $msg($bix)
+ }
+
+ pack $ww.dis -expand yes -fill both -padx 8 -pady 8
+
+ $ww.dis configure -disablecallback true ;# sinon boum CWD pas encore allouee
+ set IWOK_GLOBALS(canvas,format) byrow
+ set IWOK_GLOBALS(canvas,func) wokUpdatePage_xy
+ $ww.dis configure -disablecallback false
+
+ return $ww
+}
+#
+#
+#
+proc wokDSP:Func { } {
+ global IWOK_GLOBALS
+ return $IWOK_GLOBALS(canvas,func)
+}
+#
+# retourne 1 si on doit calculer la date des items a afficher.
+#
+proc wokDSP:IsLong { } {
+ global IWOK_GLOBALS
+ if { "$IWOK_GLOBALS(canvas,format)" == "bylong" || "$IWOK_GLOBALS(canvas,format)" == "bylast" } {
+ return 1
+ } else {
+ return 0
+ }
+}
+#
+# retourne 1 si on doit ordonner par rapport a mtime
+#
+proc wokDSP:IsLast { } {
+ global IWOK_GLOBALS
+ if { "$IWOK_GLOBALS(canvas,format)" == "bylast" } {
+ return 1
+ } else {
+ return 0
+ }
+}
+#
+# colle les scrollbars de w au debut de la w
+#
+proc wokUSB { w } {
+ set hsb [$w subwidget hsb]
+ set vsb [$w subwidget vsb]
+ set hcmd [lindex [$hsb configure -command] 4]
+ set vcmd [lindex [$vsb configure -command] 4]
+ eval $hcmd moveto 0
+ eval $vcmd moveto 0
+ return
+}
+#
+# ajuste la taille du canvas x et y en "screen units" i.e. celle retournee par coord ou bbox
+#
+proc wokSetCanvasSize { x y } {
+ global IWOK_GLOBALS
+ set Mx $IWOK_GLOBALS(canvas,width)
+ set My $IWOK_GLOBALS(canvas,height)
+ $IWOK_GLOBALS(canvas) configure \
+ -width [expr { ($x <= $Mx) ? $Mx : $x }] \
+ -height [expr { ($y <= $My) ? $My : $y }]
+ return
+}
+;#
+;# items en ligne
+;#
+proc wokUpdatePage_xy { param itemlist } {
+ global IWOK_GLOBALS
+ global IWOK_WINDOWS
+ set w $IWOK_GLOBALS(toplevel)
+
+ set fscr $IWOK_WINDOWS($w,NAV,scrolled)
+
+ set can $IWOK_GLOBALS(canvas)
+ wokUSB $fscr
+
+ $can delete all
+
+ set X [lindex $param 0]
+ set Y [lindex $param 1]
+ set WDTH [lindex $param 2]
+ set DY [lindex $param 3]
+ set DT [lindex $param 4]
+ set COEF [lindex $param 5]
+
+ set mdx 0
+ set lele {}
+ ;#^WOK^k3dev^iwok WOK:k3dev:iwok workbench iwok image17
+
+ foreach E $itemlist {
+ set name [lindex $E 3]
+ set btm [lindex $E 4]
+ set ima [$can create image 0 0 -image $btm -tag $E]
+ set itx [$can create text 0 0 -anchor w -text $name \
+ -fill $IWOK_GLOBALS(toplevel,fg) -font $IWOK_GLOBALS(font) -tag $E]
+ $can bind $ima <Any-Enter> {catch { %W configure -cursor {hand2 red white}}}
+ $can bind $ima <Any-Leave> {catch { %W configure -cursor {}}}
+ $can bind $itx <Any-Enter> {catch { %W configure -cursor {hand2 red white}}}
+ $can bind $itx <Any-Leave> {catch { %W configure -cursor {}}}
+ lappend lele [list $ima $itx]
+ set retl [$can bbox $itx]
+ set d [expr [lindex $retl 2] - [lindex $retl 0]]
+ set mdx [expr { ($d > $mdx) ? $d : $mdx }]
+ }
+
+ set supx 0 ; set supy 0 ; set mdx [expr { int ( $COEF * $mdx ) } ]
+
+ set INIX $X
+ foreach e $lele {
+ set ima [lindex $e 0]
+ set itx [lindex $e 1]
+ $can coords $ima $X $Y
+ $can coords $itx [expr $X+$DT] $Y
+ set NX [incr X $mdx]
+ if { $NX > $WDTH } {
+ set X $INIX
+ set Y [incr Y $DY]
+ } else {
+ set X $NX
+ }
+ set retl [wokMaxbbox [$can bbox $ima] [$can bbox $itx]]
+ set x2 [lindex $retl 0]
+ set y2 [lindex $retl 1]
+
+ set supx [expr { ($x2 > $supx) ? $x2 : $supx }]
+ set supy [expr { ($y2 > $supy) ? $y2 : $supy }]
+ }
+
+ wokSetCanvasSize $supx $supy
+ pack $can
+ return
+
+}
+;#
+;# item sur une seule colonne: x constant
+;#
+proc wokUpdatePage_cy { param itemlist } {
+ global IWOK_WINDOWS
+ global IWOK_GLOBALS
+ set w $IWOK_GLOBALS(toplevel)
+ set fscr $IWOK_WINDOWS($w,NAV,scrolled)
+ set can $IWOK_GLOBALS(canvas)
+ wokUSB $fscr
+
+ $can delete all
+
+ set X [lindex $param 0]
+ set Y [lindex $param 1]
+ set WDTH [lindex $param 2]
+ set DY [lindex $param 3]
+ set DT [lindex $param 4]
+ set COEF [lindex $param 5]
+
+
+ set supx 0 ; set supy 0 ;
+
+ foreach E $itemlist {
+ set name [lindex $E 3]
+ set btm [lindex $E 4]
+ set ima [$can create image $X $Y -image $btm -tag $E]
+ set itx [$can create text [expr $X+$DT] $Y -anchor w -fill $IWOK_GLOBALS(toplevel,fg) \
+ -text $name -font $IWOK_GLOBALS(font) -tag $E ]
+ $can bind $ima <Any-Enter> {catch { %W configure -cursor {hand2 red white}}}
+ $can bind $ima <Any-Leave> {catch { %W configure -cursor {}}}
+ $can bind $itx <Any-Enter> {catch { %W configure -cursor {hand2 red white}}}
+ $can bind $itx <Any-Leave> {catch { %W configure -cursor {}}}
+ set Y [incr Y $DY]
+ set retl [wokMaxbbox [$can bbox $ima] [$can bbox $itx]]
+ set x2 [lindex $retl 0]
+ set y2 [lindex $retl 1]
+ set supx [expr { ($x2 > $supx) ? $x2 : $supx }]
+ set supy [expr { ($y2 > $supy) ? $y2 : $supy }]
+ }
+
+ wokSetCanvasSize $supx $supy
+ pack $can
+ return
+
+}
+
+;#
+;# item ordonne sur une seule colonne
+;#
+proc wokUpdatePage_tt { param itemlist } {
+ global IWOK_WINDOWS
+ global IWOK_GLOBALS
+ set w $IWOK_GLOBALS(toplevel)
+ set fscr $IWOK_WINDOWS($w,NAV,scrolled)
+ set can $IWOK_GLOBALS(canvas)
+ wokUSB $fscr
+
+ $can delete all
+
+ set X [lindex $param 0]
+ set Y [lindex $param 1]
+ set WDTH [lindex $param 2]
+ set DY [lindex $param 3]
+ set DT [lindex $param 4]
+ set COEF [lindex $param 5]
+
+ set supx 0 ; set supy 0 ; set mdx 0
+
+ set nblm 0
+
+ set TA [lindex [lindex $itemlist end] 2]
+
+ set nlig 28
+ switch -glob -- $TA {
+ trig_terminal { set nlig 36 }
+ devunit_* { set nlig 21 }
+ }
+ set nb 38 ; set nbm2 36
+ foreach E $itemlist {
+ set ina [lindex $E 3]
+ set len [string length $ina]
+ if { $len <= $nb } {
+ set name $ina
+ } else {
+ set name [string range $ina 0 $nbm2]..
+ }
+ set btm [lindex $E 4]
+ set ima [$can create image $X $Y -image $btm -tag $E]
+ set itx [$can create text [expr $X+$DT] $Y -anchor w -fill $IWOK_GLOBALS(toplevel,fg) \
+ -text $name -font $IWOK_GLOBALS(font) -tag $E ]
+ $can bind $ima <Any-Enter> {catch { %W configure -cursor {hand2 red white}}}
+ $can bind $ima <Any-Leave> {catch { %W configure -cursor {}}}
+ $can bind $itx <Any-Enter> {catch { %W configure -cursor {hand2 red white}}}
+ $can bind $itx <Any-Leave> {catch { %W configure -cursor {}}}
+ incr nblm
+ if { $nblm > $nlig } {
+ set nblm 0
+ set X [expr $X + int ( $COEF * $mdx )]
+ set Y [lindex $param 1]
+ set mdx 0
+ } else {
+ set Y [incr Y $DY]
+ set bx1 [$can bbox $ima]
+ set lx1 [expr [lindex $bx1 2] - [lindex $bx1 0]]
+ set bx2 [$can bbox $itx]
+ set lx2 [expr [lindex $bx2 2] - [lindex $bx2 0]]
+ set d [expr $lx1 + $lx2]
+ set mdx [expr { ($d > $mdx) ? $d : $mdx }]
+ }
+ set x2 [lindex $bx2 2]
+ set y2 [lindex $bx1 2]
+ set supx [expr { ($x2 > $supx) ? $x2 : $supx }]
+ set supy [expr { ($y2 > $supy) ? $y2 : $supy }]
+ }
+
+ wokSetCanvasSize $supx $supy
+ pack $can
+ return
+
+}
+
+
+
+#
+# retourne le max de 2 bbox
+#
+proc wokMaxbbox { l1 l2 } {
+ return [list [max [lindex $l1 2] [lindex $l2 2]] [max [lindex $l1 3] [lindex $l2 3]]]
+}
+
+#
+# ((((((((((( D A T E ))))))))))) ll = ;#^WOK^k3dev^iwok WOK:k3dev:iwok workbench iwok imag17 ..
+#
+proc wokGetsessiondate { ll last } {
+ return $ll
+}
+
+proc wokGetfactorydate { ll last } {
+ return $ll
+}
+
+proc wokGetworkshopdate { ll last } {
+ return $ll
+}
+
+proc wokGetworkbenchdate { ll last } {
+ return $ll
+ set lt [woktutu4 $ll]
+ if { $last == 1 } {
+ set lr [lsort -decreasing -command wok5Sort $lt]
+ } else {
+ set lr $lt
+ }
+ set l {}
+ set nb 28
+ set fm 32
+ foreach e $lr {
+ set len [string length [lindex $e 3]]
+ if { $len <= [expr $nb + 2 ]} {
+ set str [lindex $e 3]
+ } else {
+ set str [string range [lindex $e 3] 0 $nb]..
+ }
+ set x [split [lindex $e 5] ,]
+ set dat [string range [fmtclock [lindex $x 0]] 4 18]
+ set siz [lindex $x 1]
+ lappend l [lreplace $e 3 3 [format "%-${fm}s %9s %14s" $str $siz $dat]]
+ }
+ return $l
+}
+;#
+;# retourne pour chaque Ud la date du fichier le plus recent et la somme des sizes de sources
+;#
+proc woktutu4 { ll } {
+ set l {}
+ foreach e $ll {
+ set st [wokUtils:FILES:StatDir [wokinfo -p source:. [lindex $e 1]]]
+ lappend l [lreplace $e 5 5 [lindex $st 0],[lindex $st 1]]
+ }
+ return $l
+}
+
+proc wokGetdevunitdate { ll last } {
+ return $ll
+ set lt [woktutu6 $ll]
+ if { $last == 1 } {
+ set lr [lsort -decreasing -command wok5Sort $lt]
+ } else {
+ set lr $lt
+ }
+ set l {}
+ set nb 28
+ set fm 32
+ foreach e $lr {
+ set len [string length [lindex $e 3]]
+ if { $len <= [expr $nb + 2 ]} {
+ set str [lindex $e 3]
+ } else {
+ set str [string range [lindex $e 3] 0 $nb]..
+ }
+ set x [split [lindex $e 5] ,]
+ set dat [string range [fmtclock [lindex $x 0]] 4 18]
+ set siz [lindex $x 1]
+ lappend l [lreplace $e 3 3 [format "%-${fm}s %9s %14s" $str $siz $dat]]
+ }
+ return $l
+}
+
+proc woktutu6 { ll } {
+ set l {}
+ foreach e $ll {
+ set L [llength [set lc [split [lindex $e 1] :]]]
+ set actloc [join [lrange $lc 0 [expr $L - 2]] :]
+ set st [wokUtils:FILES:StatDir [wokinfo -p [lindex $lc end]:. $actloc]]
+ lappend l [lreplace $e 5 5 [lindex $st 0],[lindex $st 1]]
+ }
+ return $l
+}
+
+
+proc wokGetparceldate { ll last } {
+ return $ll
+}
+proc wokGetparcelunitdate { ll last } {
+ return $ll
+}
+proc wokGetparcelunitstuffdate { ll last } {
+ return [wokGetdevunitstuffdate $ll $last]
+}
+;#
+;# ll est triee par ordre alphab;
+;#
+proc wokGetdevunitstuffdate { ll last } {
+ set lt [woktutu5 $ll]
+ if { $last == 1 } {
+ set lr [lsort -decreasing -command wok5Sort $lt]
+ } else {
+ set lr $lt
+ }
+ set l {}
+ set nb 28
+ set fm 32
+ foreach e $lr {
+ set len [string length [lindex $e 3]]
+ if { $len <= [expr $nb + 2 ]} {
+ set str [lindex $e 3]
+ } else {
+ set str [string range [lindex $e 3] 0 $nb]..
+ }
+ set x [split [lindex $e 5] ,]
+ set dat [string range [fmtclock [lindex $x 0]] 4 18]
+ set siz [lindex $x 1]
+ lappend l [lreplace $e 3 3 [format "%-${fm}s %9s %14s" $str $siz $dat]]
+ }
+ return $l
+}
+
+proc wok5Sort { a b } {
+ return [expr [lindex [split [lindex $a 5] ,] 0] - [lindex [split [lindex $b 5] ,] 0] ]
+}
+#
+# remplace le path par la date sous forme comparable
+#
+proc woktutu5 { ll } {
+ set l {}
+ foreach e $ll {
+ catch {unset m}
+ file lstat [lindex $e 5] m
+ lappend l [lreplace $e 5 5 $m(mtime),$m(size)]
+ }
+ return $l
+}
+#
+# Boutons up et Layout
+#
+proc wokMOV:Init { w } {
+ set ww [frame $w.mov]
+ tixButtonBox $ww.mov -orientation horizontal -relief flat -padx 0 -pady 0
+
+ $ww.mov add back -image [tix getimage back] -command wokReaff
+ $ww.mov add wcd -image [tix getimage wokcd] -command wokMOV:wokcd
+
+ set bck [$ww.mov subwidget back] ; tixBalloon $bck.bal ; $bck.bal bind $bck -msg "Go up"
+ set wcd [$ww.mov subwidget wcd] ; tixBalloon $wcd.bal ; $wcd.bal bind $wcd -msg "wokcd"
+
+ pack $ww.mov -expand yes -fill both -padx 6 -pady 6
+ return $ww
+}
+#
+# WOK:k3dev:iwok:WOKTclLib => fait wokcd
+# WOK:k3dev:iwok:WOKTclLib:xxx => fait wokcd WOK:k3dev:iwok:WOKTclLib et cd /...
+# Pour l'instant c'est ici que sont configures les boutons.
+#
+proc wokMOV:wokcd { {here {}} } {
+ if { $here == {} } {
+ set location [wokCWD read]
+ } else {
+ set location $here
+ }
+ set ll [llength [set lc [split $location :]]]
+ if { $ll != 5 } {
+ catch { wokcd [set actloc [join $lc :]] }
+ } else {
+ catch {
+ wokcd [set actloc [join [lrange $lc 0 [expr $ll - 2]] :]]
+ cd [wokinfo -p [lindex $lc end]:. $actloc]
+ }
+ }
+
+ return
+}
+#
+# Maintenant il y : en tete de l'adresse....
+#
+proc wokMOV:Range { adr } {
+ if { "[string index $adr 0]" == ":" } {
+ return [string range $adr 1 end]
+ } else {
+ return $adr
+ }
+}
+#
+#
+#
+proc wokMOV:Alonzi { tpl wokcd } {
+
+ if { [set f [wokMOV:Range [wokinfo -f $wokcd]] ] != {} } {
+ wokNAV:Tree:Updateworkshop $tpl ${f} ^${f}
+ set loc ${f}
+ set dir ^${f}
+ } else {
+ return
+ }
+
+ if { [set s [wokMOV:Range [wokinfo -s $wokcd]] ] != {} } {
+ set S [wokinfo -n $s]
+ wokNAV:Tree:Updateworkbench $tpl ${f}:$S ^${f}^$S
+ set loc ${f}:$S
+ set dir ^${f}^$S
+ } else {
+ wokNAV:Tree:SeeMe $tpl $loc $dir
+ return
+ }
+
+ if { [set w [wokMOV:Range [wokinfo -w $wokcd]] ] != {} } {
+ set W [wokinfo -n $w]
+ wokNAV:Tree:Updatedevunit $tpl ${f}:$S:$W ^${f}^$S^$W
+ set loc ${f}:$S:$W
+ set dir ^${f}^$S^$W
+ } else {
+ wokNAV:Tree:SeeMe $tpl $loc $dir
+ return
+ }
+
+ if { [set u [wokMOV:Range [wokinfo -u $wokcd]] ] != {} } {
+ set U [wokinfo -n $u]
+ wokNAV:Tree:Updatedevunitstuff $tpl ${f}:$S:$W:$U ^${f}^$S^$W^$U
+ set loc ${f}:$S:$W:$U
+ set dir ^${f}^$S^$W^$U
+ } else {
+ wokNAV:Tree:SeeMe $tpl $loc $dir
+ return
+ }
+
+ wokNAV:Tree:SeeMe $tpl $loc $dir
+ return
+}
+;#
+;# fait find parce que ca non plus ca existe pas
+;#
+proc wokFind { location } {
+ if ![wokinfo -x $location] return
+ if {"[wokinfo -t $location]" == "devunit" } {
+ return $location
+ } elseif {"[wokinfo -t $location]" == "workbench" } {
+ set l {}
+ foreach e [w_info -l $location] {
+ set l [concat $l ${location}:$e]
+ }
+ return [concat $l $location]
+ } elseif {"[wokinfo -t $location]" == "workshop" } {
+ set l {}
+ foreach e [sinfo -w $location] {
+ set l [concat $l [wokFind ${location}:$e]]
+ }
+ return [concat $l $location]
+ } elseif {"[wokinfo -t $location]" == "factory" } {
+ set l {}
+ foreach e [finfo -s $location] {
+ set l [concat $l [wokFind ${location}:$e]]
+ }
+ return [concat $l $location]
+ }
+}
--- /dev/null
+--
+-- This file defines the location and type of a WOK sources repository.
+-- It must be placed in the directory "Adm" of the concerned workshop ,
+-- or in the directory "Adm" of the factory if you want to share the same repository between
+-- all the workshops.
+-- Note that this option is provided only for compatibility with previous version 5 of WOK.
+-- Attaching one repository per workshop is strongly recommended.
+--
+-- The following is a example. You must supply values according to your context
+--
+-- VC_ROOT is a directory name. The repository will be created in that directory.
+-- VC_TYPE is the type of the repository.
+--
+@ifnotdefined ( %VC_EDL) then
+@set %VC_EDL = "";
+
+@set %VC_ROOT = "/dev/null";
+
+@set %VC_TYPE = "SCCS";
+
+@endif;
+
--- /dev/null
+
+
+proc wcd { args } {
+ if { [llength $args] !=0 } {
+ wokcd -PSrc $args
+ } else {
+ puts stdout {Usage: wcd <unit>}
+ foreach u [w_info -l] {
+ puts $u
+ }
+ }
+ return
+
+}
+
+proc wsrc {{entity ""}} {
+ if { $entity != "" } { wokcd -Tsource $entity } {wokcd -Tsource}
+}
+
+proc wdrv {{entity ""}} {
+ if { $entity != "" } { wokcd -Tderivated $entity } {wokcd -Tderivated}
+}
+
+proc wlib {{entity ""}} {
+ if { $entity != "" } { wokcd -Tlibrary $entity } {wokcd -Tlibrary}
+}
+
+proc wbin {{entity ""}} {
+ if { $entity != "" } { wokcd -Texecutable $entity } {wokcd -Texecutable}
+}
+proc wobj {{entity ""}} {
+ if { $entity != "" } { wokcd -Tobject $entity } {wokcd -Tobject}
+}
+proc winc {{entity ""}} {
+ if { $entity != "" } { wokcd -Tpubinclude $entity } {wokcd -Tpubinclude}
+}
+proc wadm {{entity ""}} {
+ if { $entity != "" } { wokcd -Tadmfile $entity } {wokcd -Tadmfile}
+}
+
+
+proc wls { args } {
+ set f [lsearch -regexp $args {-[pniCtexscfOrd]} ]
+ if { $f != -1 } {
+ set ft [lindex [split [lindex $args $f] -] 1]
+ set lx {}
+ set len [string length $ft]
+ foreach cc [ucreate -P] {
+ set SLONG([lindex $cc 0]) [lindex $cc 1]
+ }
+
+ for {set i 0} {$i < $len} {incr i 1} {
+ set x [string index $ft $i]
+ if [info exists SLONG($x)] {
+ lappend lx $SLONG($x)
+ }
+ }
+
+ foreach ud [lsort [w_info -a]] {
+ if { [lsearch $lx [lindex $ud 0]] != -1 } {
+ puts [lindex $ud 1]
+ }
+ }
+ } else {
+ set l [lsearch -regexp $args {-l}]
+ if { $l == -1 } {
+ set retargs $args
+ set act {w_info -l}
+ } else {
+ set retargs [lreplace $args $l $l]
+ set act {w_info -a}
+ }
+ foreach ff [lsort [eval $act $retargs]] {
+ puts $ff
+ }
+ }
+}
+
+
+
--- /dev/null
+#
+# Interface ClearCase.
+#
+proc wokIntegre:BASE:ftos { file vrs } {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:stof { file vrs } {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:IsElm { file } {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:InitFile { infile vrs cmt Sfile {fileid stdout} } {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:ReInitFile { Sfile vrs cmt infile {fileid stdout} } {
+ return {}
+}
+#;
+#
+#;<
+proc wokIntegre:BASE:UpdateFile { Sfile vrs cmt infile {fileid stdout} } {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:DeleteFile { infile {fileid stdout} } {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:GetFile { Sfile invrs {fileid stdout} } {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:List { Bname vrs } {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:EOF { {fileid stdout} } {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:Execute { VERBOSE command {fileid stdout} } {
+ return {}
+}
+;#;>
+;#
+;#;<
+proc wokIntegre:BASE:diff { sfile v1 v2 } {
+ return {}
+}
+;#;>
+;#
+;#;<
+proc wokIntegre:BASE:cat { sfile {v last} } {
+ return {}
+}
+;#;>
+;#
+;#;<
+proc wokIntegre:BASE:vrs { sfile } {
+ return {}
+}
+;#;>
+;#
+;#;<
+proc wokIntegre:BASE:check { sfile } {
+ return {}
+}
+;#;>
+;#
+;#;<
+proc wokIntegre:BASE:tree { infile fils} {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:Version:Check { shop ver } {
+ return {}
+}
--- /dev/null
+#
+# Interface NOBASE
+#
+proc wokIntegre:BASE:ftos { file vrs } {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:stof { file vrs } {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:IsElm { file } {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:InitFile { infile vrs cmt Sfile {fileid stdout} } {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:ReInitFile { Sfile vrs cmt infile {fileid stdout} } {
+ return {}
+}
+#;
+#
+#;<
+proc wokIntegre:BASE:UpdateFile { Sfile vrs cmt infile {fileid stdout} } {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:DeleteFile { infile {fileid stdout} } {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:GetFile { Sfile invrs {fileid stdout} } {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:List { fshop Bname vrs } {
+ set Bname [lindex [split $Bname .] 0]
+ foreach wb [sinfo -w $fshop] {
+ if [expr { ( [llength [w_info -A ${fshop}:${wb}]] > 1 ) ? 0 : 1 }] {
+ set root $wb
+ break
+ }
+ }
+ set listfile {}
+ if [wokinfo -x ${fshop}:${root}:${Bname}] {
+ set listfile [wokUtils:FILES:ls [wokinfo -p source:. ${fshop}:${root}:${Bname}]]
+ }
+ return $listfile
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:EOF { {fileid stdout} } {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:BASE:Execute { VERBOSE command {fileid stdout} } {
+ return {}
+}
+;#;>
+;#
+;#;<
+proc wokIntegre:BASE:diff { sfile v1 v2 } {
+ return {}
+}
+;#;>
+;#
+;#;<
+proc wokIntegre:BASE:cat { sfile {v last} } {
+ return {}
+}
+;#;>
+;#
+;#;<
+proc wokIntegre:BASE:vrs { sfile } {
+ return {}
+}
+;#;>
+;#
+;#;<
+proc wokIntegre:BASE:check { sfile } {
+ return {}
+}
+;#;>
+;#
+;#;<
+proc wokIntegre:BASE:tree { infile fils} {
+ return {}
+}
+#;>
+#
+#;<
+proc wokIntegre:Version:Check { shop ver } {
+ return {}
+}
--- /dev/null
+#
+# Interface RCS.
+#
+#;>
+# retourne le nom du fichier de travail
+# si vrs = x numero de lignee (appele par InitFile et Cie)
+# prefixe le nom avec x
+# si vrs = x.y version exacte (appele par FillRef et FillUSer au moment de wget)
+# prefixe le nom avec x. C' est le nom du fichier de travail contenant la version x.y
+# si vrs last:x derniere version enregistree de la lignee x (appele par wget)
+# prefixe le nom avec x
+#;<
+proc wokIntegre:BASE:ftos { file vrs } {
+ if { [string first : $vrs] == -1 } {
+ set l [lindex [split $vrs .] 0]
+ return ${l},${file},v
+ } else {
+ return [lindex [split $vrs :] 1],${file},v
+ }
+}
+#;>
+# retourne le nom du fichier a partir du nom du fichier de travail (basename)
+#;<
+proc wokIntegre:BASE:stof { file vrs } {
+ return [lindex [split $file ,] 1]
+}
+
+#;>
+# retourne 1 si file est un element d'une base
+#;<
+proc wokIntegre:BASE:IsElm { file } {
+ return [regexp {(.*),v$} $file all f]
+}
+#;>
+# Ecrit dans fileid la sequence d'init d'un fichier RCS.
+# Le directory courant est une base temporaire
+# infile: Full path du fichier a enregistrer
+# vrs : version
+# cmt : commentaire
+# Sfile : Full path du Sfile (base) qui sera cree
+#;<
+proc wokIntegre:BASE:InitFile { infile vrs cmt Sfile {fileid stdout} } {
+ ;#puts stderr "Appel a InitFile [file tail $infile] vrs = $vrs "
+ set bna [file tail $infile]
+ set bnas [file tail $Sfile]
+ set pfx ${vrs},${bna}
+ puts $fileid [format "echo Init for file %s" $bna ]
+ puts $fileid [format "echo Init > /tmp/%s" $bna.desc]
+ puts $fileid [format "rcs -q -i -U -t/tmp/%s %s" $bna.desc $pfx]
+ puts $fileid [format "cp -p %s ./%s" $infile $pfx]
+ puts $fileid [format "ci -u -f -r%s -m%s %s %s" $vrs $cmt $pfx $bnas]
+ puts $fileid [format "rm -f /tmp/%s " $bna.desc]
+ return
+}
+#;>
+# Ecrit dans fileid la sequence d'init d'un fichier deja existant dans la base.
+# Pour RCS la sequence est la meme que UpdateFile.
+#;<
+proc wokIntegre:BASE:ReInitFile { Sfile vrs cmt infile {fileid stdout} } {
+ ;#puts stderr "Appel a UpdateFile [file tail $Sfile] vrs = $vrs "
+ set bna [file tail $infile]
+ set bnas [file tail $Sfile]
+ set pfx ${vrs},${bna}
+ puts $fileid [format "echo Updating file %s" [file tail $infile]]
+ puts $fileid [format "cp %s ." $Sfile]
+ puts $fileid [format "co ./%s" $bnas]
+ puts $fileid [format "cp -p %s ./%s" $infile $pfx]
+ puts $fileid [format "ci -f -m%s %s %s" $cmt $pfx $bnas]
+ return
+}
+#;
+# Ecrit dans fileid la sequence d'update d'un fichier deja existant dans la base
+# Le repertoire courant est une base temporaire.
+# Note: ci a detruit le fichier d'entree.
+#;<
+proc wokIntegre:BASE:UpdateFile { Sfile vrs cmt infile {fileid stdout} } {
+ ;#puts stderr "Appel a UpdateFile [file tail $Sfile] vrs = $vrs "
+ set bna [file tail $infile]
+ set bnas [file tail $Sfile]
+ set pfx ${vrs},${bna}
+ puts $fileid [format "echo Updating file %s" [file tail $infile]]
+ puts $fileid [format "cp %s ." $Sfile]
+ puts $fileid [format "co ./%s" $bnas]
+ puts $fileid [format "cp -p %s ./%s" $infile $pfx]
+ puts $fileid [format "ci -f -m%s %s %s" $cmt $pfx $bnas]
+ return
+}
+#;>
+# Ecrit dans fileid la sequence correspondante a un fichier qui disparait (-)
+#;<
+proc wokIntegre:BASE:DeleteFile { infile {fileid stdout} } {
+ puts $fileid [format "echo Deleted file %s" $infile]
+ return
+}
+#;>
+# Ecrit dans fileid la sequence pour recuperer un fichier (sans edit.)
+#
+# Si invrs = num => recup de la version num ( version exacte )
+# Si invrs = last:num => derniere version dans la lignee num
+# Si invrs = last => derniere version enregistree
+#;<
+proc wokIntegre:BASE:GetFile { Sfile invrs {fileid stdout} } {
+ ;#puts "GET: invrs = $invrs ----- Sfile = $Sfile "
+ puts $fileid [format "echo Checkout file %s" $Sfile]
+ set lx [split [file tail $Sfile] ,]
+ set wfil [lindex $lx 0],[lindex $lx 1]
+ set file [lindex $lx 1]
+ if { [regexp {(.*):(.*)} $invrs ignore key vrs] } {
+ if { [string compare $key last] == 0 } {
+ puts $fileid [format "co -u %s" $Sfile]
+ } else {
+ msgprint -c WOKVC -e "Getfile bad version syntax $invrs"
+ }
+ } else {
+ if { [string compare $invrs last] == 0 } {
+ puts $fileid [format "co -u %s" $Sfile]
+ } else {
+ puts $fileid [format "co -u -r%s %s" $invrs $Sfile]
+ }
+ }
+ puts $fileid [format "mv $wfil $file"]
+ puts $fileid [format "chmod 644 $file"]
+ return
+}
+;#/home/wb/kl/KERNEL/SCCS//BASES/TSTPACK.p/4,f_UGSuppliers.c,v --> 4,f_UGSuppliers.c
+;#revision 4.4 (unlocked)
+;#done
+
+#;>
+# retourne la liste des sfile dans une base
+#;<
+proc wokIntegre:BASE:List { fshop Bname vrs } {
+ set diradm [glob -nocomplain [wokIntegre:BASE:GetRootName $fshop]/${Bname}.?]
+ if [file exists $diradm] {
+ set l {}
+ foreach Sfile [readdir $diradm] {
+ set x [split $Sfile ,]
+ if { [lindex $x 0] == $vrs } {
+ lappend l [lindex $x 1]
+ }
+ }
+ return $l
+ } else {
+ return {}
+ }
+}
+
+#;>
+# Ecrit dans fileid la fin d'un envoi. Permet a BASE:Execute de retourner un status
+#;<
+proc wokIntegre:BASE:EOF { {fileid stdout} } {
+ puts $fileid "echo Successfull completion"
+ puts $fileid "exit 0"
+ return
+}
+#;>
+# Execute les commandes RCS command dans un Bourne Shell
+# 1. Ecrit sur fileid quand certains pattern sont reconnus.
+# Retourne 1 si tout est OK. (Pattern De BASE::EOF bien recu)
+# debugger:
+# exp_internal 1 : patterns sur stderr ( ca suffit en general)
+# exp_internal -f file 0 : stdout et patterns dans file
+# exp_internal -f file 1 : stdout et patterns dans file + pattern sur stderr
+#;<
+proc wokIntegre:BASE:Execute { VERBOSE command {fileid stdout} } {
+ spawn -noecho sh $command
+ set LOCID $spawn_id
+ log_user 0
+ exp_internal $VERBOSE
+ set return_status 0
+ set timeout 84
+ expect {
+
+ -i $LOCID -indices -re "^Updating file (\[^\r]*)\r\n(\[^\r]*)\r\n(\[^\r]*)\r\n(\[^\r]*)\r\n(\[^\r]*)\r\n(\[^\r]*)\r\n(\[^\r]*)\r\n" {
+ if { $expect_out(4,string) == "done" && $expect_out(4,string) == "done" } {
+ set file $expect_out(1,string)
+ if [regexp {new revision: (.*);.*} $expect_out(6,string) all ver] {
+ set straff [format " Modified : %s %s" $file $ver]
+ msgprint -c WOKVC -i $straff
+ puts $fileid $straff
+ }
+ exp_continue
+ } else {
+ puts stderr $expect_out(buffer)
+ close
+ return $return_status
+ }
+ }
+
+ -i $LOCID -indices -re "^Checkout file (\[^\r]*)\r\n(\[^\r]*)\r\n(\[^\r]*)\r\n(\[^\r]*)\r\n" {
+ if { $expect_out(4,string) == "done" } {
+ set vrs [lindex [split $expect_out(3,string)] 1]
+ set nam [lindex [split [file tail $expect_out(1,string)] ,] 1 ]
+ msgprint -c WOKVC -i "Checking out file $nam ( $vrs )"
+ exp_continue
+ } else {
+ puts stderr $expect_out(buffer)
+ close
+ return $return_status
+ }
+ }
+
+
+ -i $LOCID -indices -re "^Init for file (\[^\r]*)\r\n(\[^\r]*)\r\n(\[^\r]*)\r\n(\[^\r]*)\r\n" {
+ if { $expect_out(4,string) == "done" } {
+ set file $expect_out(1,string)
+ regsub {initial revision: } $expect_out(3,string) "" ver
+ set straff [format " Added : %s %s" $file $ver]
+ puts $fileid $straff
+ msgprint -c WOKVC -i $straff
+ exp_continue
+ } else {
+ puts stderr $expect_out(buffer)
+ close
+ return $return_status
+ }
+ }
+
+
+ -i $LOCID -indices -re "^Processing unit : (\[^\r]*)\r\n" {
+ set ud $expect_out(1,string)
+ puts $fileid [format "\n %s (Updated) : \n----" $ud]
+ msgprint -c WOKVC -i [format " %s (Updated) : \n----" $ud]
+ exp_continue
+ }
+
+
+ -i $LOCID -indices -re "^Deleted file (\[^\r]*)\r\n" {
+ set file $expect_out(1,string)
+ set straff [format " Deleted : %s x.x" $file]
+ puts $fileid $straff
+ msgprint -c WOKVC -i $straff
+ exp_continue
+ }
+
+
+ -i $LOCID "Successfull completion\r\n" {
+ set return_status 1
+ exp_continue
+ }
+
+ -i $LOCID eof {
+ if { $VERBOSE } {
+ puts stdout "Received eof"
+ }
+ return $return_status
+ }
+
+ -i $LOCID timeout {
+ msgprint -c WOKVC -e "Timeout excedeed ($timeout) from spawned process."
+ }
+
+ }
+ return $return_status
+}
+;#
+;# (((((((((((((((pour le desktop: ici on fait exec et c'est une catastroffe )))))))))))))))
+;#;>
+;# retourne une string contenant le diff de Sfile dans les versions v1 et v2
+;#;<
+proc wokIntegre:BASE:diff { sfile v1 v2 } {
+ return [exec rcsdiff -r$v1 -r$v2 -q $sfile]
+}
+;#;>
+;# retourne une string contenant le contenu de la version v de sfile.
+;#;<
+proc wokIntegre:BASE:cat { sfile {v last} } {
+ if { $v == "last" } {
+ return [exec co -p -q $sfile]
+ } else {
+ return [exec co -p$v -q $sfile]
+ }
+}
+;#;>
+;# retourne une string contenant le nom de la derniere version de sfile.
+;#;<
+proc wokIntegre:BASE:vrs { sfile } {
+ return [lindex [lindex [split [exec rlog -h $sfile] \n] 3] 1]
+}
+;#;>
+;# Check for corruption
+;#;<
+proc wokIntegre:BASE:check { sfile } {
+ return
+}
+;#;>
+;# fabrique de quoi afficher l'arbre des versions.
+;#;<
+proc wokIntegre:BASE:tree { infile fils} {
+ upvar $fils FILS
+ set sep ----------------------------
+ set lst [split [exec rlog $infile] \n]
+ set i 1
+ set ll [llength $lst]
+ set listlab {}
+ while { $i < $ll } {
+ set x [lindex $lst $i]
+ if { "$x" == "$sep" } {
+ incr i
+ lappend listlab [lindex [split [lindex $lst $i]] 1]
+ incr i
+ set itm [lindex $lst $i]
+ incr i
+ set cmt [lindex $lst $i]
+ }
+ incr i
+ }
+
+ set i 0
+ foreach e $listlab {
+ set w {}
+ lappend w [list $e [expr $i + 1]]
+ set FILS($i) $w
+ incr i
+ }
+
+ set lab [lindex [lindex $listlab 0] 0]
+ return [list $lab 1]
+}
+#
+# ((((((((((((((((VERSION))))))))))))))))
+#
+#;>
+# Verifie que l'on peu plugger shop avec le numero ver retourne ver si OK
+#;<
+proc wokIntegre:Version:Check { fshop ver } {
+ set f [wokIntegre:Version:GetTableName $fshop 1]
+ set l [wokUtils:FILES:FileToList $f]
+ set str [wokinfo -n [wokinfo -s $fshop]]
+ foreach e $l {
+ if { [lindex $e 0] == $str } {
+ if { [lindex $e 1] != $ver } {
+ msgprint -c WOKVC -e "The shop $str is already registered with number [lindex $e 1]"
+ return {}
+ } else {
+ return $ver
+ }
+ }
+ }
+
+ foreach e $l {
+ set n [lindex $e 1]
+ if {$ver == $n } {
+ msgprint -c WOKVC -e "The version $ver is already assigned to the shop [lindex $e 0]"
+ return {}
+ }
+ }
+ return $ver
+}
--- /dev/null
+#
+# Interface SCCS avec historique unique pour tout l'atelier. (Mode WOK-5-x)
+#
+#;>
+# retourne le nom du fichier de travail (basename)
+#;<
+proc wokIntegre:BASE:ftos { file vrs } {
+ return s.$file
+}
+#;>
+# retourne le nom du fichier a partir du nom du fichier de travail (basename)
+#;<
+proc wokIntegre:BASE:stof { file vrs } {
+ if [regexp {^s\.(.*)$} $file all f] {
+ return $f
+ } else {
+ return $file
+ }
+}
+#;>
+# retourne 1 si
+#;<
+proc wokIntegre:BASE:IsElm { file } {
+ return [regexp {^s\.(.*)$} $file all f]
+}
+#;>
+# Ecrit dans fileid la sequence d'init d'un fichier SCCS.
+# infile: Full path du fichier a enregistrer
+# vrs : version
+# cmt : commentaire
+# Sfile : Full path du Sfile (base) qui sera cree
+#;<
+proc wokIntegre:BASE:InitFile { infile vrs cmt Sfile {fileid stdout} } {
+ ;#puts stderr "Appel a InitFile [file tail $infile] vrs = $vrs "
+ puts $fileid [format "admin -i%s -r%s -y%s %s 2> /dev/null" $infile $vrs $cmt $Sfile]
+ puts $fileid [format "echo Init for file %s `prs -d:I: %s`" [file tail $infile] $Sfile]
+ return
+}
+#;>
+# Ecrit dans fileid la sequence d'init d'un fichier deja existant dans la base (new version)
+#;<
+proc wokIntegre:BASE:ReInitFile { Sfile vrs cmt infile {fileid stdout} } {
+ ;#puts stderr "Appel a ReInitFile [file tail $Sfile] vrs = $vrs "
+ set bnas [file tail $Sfile]
+ regsub {^s[.]} $bnas "" bna
+ puts $fileid [format "echo Updating file %s" [file tail $infile]]
+ puts $fileid [format "cp %s ." $Sfile]
+ puts $fileid [format "get -e -r%s ./%s" $vrs $bnas]
+ puts $fileid [format "rm -f ./%s" $bna]
+ puts $fileid [format "cp -p %s ." $infile]
+ puts $fileid [format "delta -s -y%s ./%s" $cmt $bnas]
+ return
+}
+#;
+# Ecrit dans fileid la sequence d'update d'un fichier deja existant dans la base
+#;<
+proc wokIntegre:BASE:UpdateFile { Sfile vrs cmt infile {fileid stdout} } {
+ ;#puts stderr "Appel a UpdateFile [file tail $Sfile] vrs = $vrs "
+ set bnas [file tail $Sfile]
+ regsub {^s[.]} $bnas "" bna
+ puts $fileid [format "echo Updating file %s" [file tail $infile]]
+ puts $fileid [format "cp %s ." $Sfile]
+ puts $fileid [format "v=`prs -r%s -d:I: %s`" $vrs $Sfile]
+ puts $fileid [format "get -e -r\$v ./%s" $bnas]
+ puts $fileid [format "rm -f ./%s" $bna]
+ puts $fileid [format "cp -p %s ." $infile]
+ puts $fileid [format "delta -s -y%s ./%s" $cmt $bnas]
+ return
+}
+#;>
+# Ecrit dans fileid la sequence correspondante a un fichier qui disparait (-)
+#;<
+proc wokIntegre:BASE:DeleteFile { infile {fileid stdout} } {
+ puts $fileid [format "echo Deleted file %s" $infile]
+ return
+}
+#;>
+# Ecrit dans fileid la sequence pour recuperer un fichier (sans edit.)
+#
+# Si invrs = num => recup de la version num ( version exacte )
+# Si invrs = last:num => derniere version dans la lignee num
+# Si invrs = last => derniere version enregistree
+#;<
+proc wokIntegre:BASE:GetFile { Sfile invrs {fileid stdout} } {
+ puts $fileid [format "echo Checkout file %s" $Sfile]
+ if { [regexp {(.*):(.*)} $invrs ignore key vrs] } {
+ if { [string compare $key last] == 0 } {
+ puts $fileid [format "v=`prs -r%s -d:I: %s`" $vrs $Sfile]
+ puts $fileid [format "sccs get -s -r\$v %s" $Sfile]
+ } else {
+ msgprint -c WOKVC -e "Getfile bad version syntax $invrs"
+ }
+ } else {
+ if { [string compare $invrs last] == 0 } {
+ puts $fileid [format "sccs get -s %s" $Sfile]
+ } else {
+ puts $fileid [format "sccs get -s -r%s %s" $invrs $Sfile]
+ }
+ }
+ return
+}
+#;>
+# retourne la liste des sfile dans une base
+#;<
+proc wokIntegre:BASE:List { fshop Bname vrs } {
+ set diradm [glob -nocomplain [wokIntegre:BASE:GetRootName $fshop]/${Bname}.?]
+ if [file exists $diradm] {
+ set l {}
+ foreach Sfile [lsort [readdir $diradm]] {
+ set s [string range $Sfile 0 1]
+ if { $s == "s." } {
+ lappend l [string range $Sfile 2 end]
+ }
+ }
+ return $l
+ } else {
+ return {}
+ }
+}
+#;>
+# Ecrit dans fileid la fin d'un envoi. Permet a BASE:Execute de retourner un status
+#;<
+proc wokIntegre:BASE:EOF { {fileid stdout} } {
+ puts $fileid "echo Successfull completion"
+ puts $fileid "exit 0"
+ return
+}
+#;>
+# Execute les commandes SCCS command dans un Bourne Shell
+# 1. Ecrit sur fileid quand certains pattern sont reconnus.
+# Retourne 1 si tout est OK. (Pattern De BASE::EOF bien recu)
+# debugger:
+# exp_internal 1 : patterns sur stderr ( ca suffit en general)
+# exp_internal -f file 0 : stdout et patterns dans file
+# exp_internal -f file 1 : stdout et patterns dans file + pattern sur stderr
+#;<
+proc wokIntegre:BASE:Execute { VERBOSE command {fileid stdout} } {
+ spawn -noecho sh $command
+ set LOCID $spawn_id
+ log_user 0
+ exp_internal $VERBOSE
+ set return_status 0
+ set timeout 84
+ expect {
+
+ -i $LOCID -indices -re "^Updating file (\[^\r]*)\r\n(\[^\r]*)\r\n(\[^\r]*)\r\n(\[^\r]*)\r\n" {
+ set file $expect_out(1,string)
+ regsub {new delta } $expect_out(3,string) "" ver
+ set straff [format " Modified : %s %s" $file $ver]
+ msgprint -c WOKVC -i $straff
+ puts $fileid $straff
+ exp_continue
+ }
+
+ -i $LOCID -indices -re "^Checkout file (\[^\r]*)\r\n" {
+ if { $VERBOSE } {
+ msgprint -c WOKVC -i "Checking out from file $expect_out(1,string)"
+ }
+ exp_continue
+ }
+
+
+ -i $LOCID -indices -re "^Init for file (\[^\r]*) (\[^\r]*)\r\n" {
+ set file $expect_out(1,string)
+ set ver $expect_out(2,string)
+ set straff [format " Added : %s %s" $file $ver]
+ puts $fileid $straff
+ msgprint -c WOKVC -i $straff
+ exp_continue
+ }
+
+
+ -i $LOCID -indices -re "^Processing unit : (\[^\r]*)\r\n" {
+ set ud $expect_out(1,string)
+ puts $fileid [format "\n %s (Updated) : \n----" $ud]
+ msgprint -c WOKVC -i [format " %s (Updated) : \n----" $ud]
+ exp_continue
+ }
+
+
+ -i $LOCID -indices -re "^Deleted file (\[^\r]*)\r\n" {
+ set file $expect_out(1,string)
+ set straff [format " Deleted : %s x.x" $file]
+ puts $fileid $straff
+ msgprint -c WOKVC -i $straff
+ exp_continue
+ }
+
+
+ -i $LOCID -re "ERROR(\[^\r]*)\r\n" {
+ msgprint -c WOKVC -e $expect_out(buffer)
+ return 0
+ }
+
+ -i $LOCID "Successfull completion\r\n" {
+ set return_status 1
+ exp_continue
+ }
+
+ -i $LOCID eof {
+ if { $VERBOSE } {
+ puts stdout "Received eof"
+ }
+ return $return_status
+ }
+
+ -i $LOCID timeout {
+ msgprint -c WOKVC -e "Timeout excedeed ($timeout) from spawned process."
+ }
+
+ }
+ return $return_status
+}
+;#
+;# (((((((((((((((pour le desktop: ici on fait exec et c'est une catastroffe )))))))))))))))
+;#;>
+;# retourne une string contenant le diff de Sfile dans les versions v1 et v2
+;#;<
+proc wokIntegre:BASE:diff { sfile v1 v2 } {
+ return [exec sccsdiff -p $sfile -r$v1 -r$v2]
+}
+;#;>
+;# retourne une string contenant le contenu de la version v de sfile.
+;#;<
+proc wokIntegre:BASE:cat { sfile {v last} } {
+ if { $v == "last" } {
+ return [exec sccs get -s -p $sfile]
+ } else {
+ return [exec sccs get -s -p -r$v $sfile]
+ }
+}
+;#;>
+;# retourne une string contenant le nom de la derniere version de sfile.
+;#;<
+proc wokIntegre:BASE:vrs { sfile } {
+ return [exec prs -d:I: $sfile]
+}
+;#;>
+;# Check for corruption
+;#;<
+proc wokIntegre:BASE:check { sfile } {
+ catch { exec admin -h $sfile } status
+ return $status
+}
+;#;>
+;# fabrique de quoi afficher l'arbre des versions.
+;#;<
+proc wokIntegre:BASE:tree { infile fils} {
+ upvar $fils FILS
+ set l [split [exec sccs prs $infile] \n]
+ set len [llength $l]
+ for {set i 0} {$i < $len} {incr i 1} {
+ set s [lindex $l $i]
+ if { $s != {} } {
+ if [regexp {^D } $s] {
+ set p [lindex $s 6]
+ set next [lindex $s 5]
+ set lab [lindex $s 1]
+ set cmt [lindex $l [expr $i+3]]
+ if [info exists FILS($p)] {
+ set w $FILS($p)
+ } else {
+ set w {}
+ }
+ set data [list $lab $cmt]
+ lappend w [list $data $next]
+ set FILS($p) $w
+ }
+ }
+ }
+ return [list $data $next]
+}
+#
+# ((((((((((((((((VERSION))))))))))))))))
+#
+#;>
+# Verifie que l'on peu plugger shop avec le numero ver retourne ver si OK
+#;<
+proc wokIntegre:Version:Check { fshop ver } {
+ set f [wokIntegre:Version:GetTableName $fshop 1]
+ set l [wokUtils:FILES:FileToList $f]
+ set str [wokinfo -n [wokinfo -s $fshop]]
+ foreach e $l {
+ if { [lindex $e 0] == $str } {
+ if { [lindex $e 1] != $ver } {
+ msgprint -c WOKVC -e "The shop $str is already registered with number [lindex $e 1]"
+ return {}
+ } else {
+ return $ver
+ }
+ }
+ }
+ set mx 0
+ foreach e $l {
+ set n [lindex $e 1]
+ set mx [expr ( $mx > $n ) ? $mx : $n]
+ }
+ foreach e $l {
+ set n [lindex $e 1]
+ if {$ver < $n } {
+ msgprint -c WOKVC -e "Bad version number. Should be strictly greater than $mx "
+ return {}
+ }
+ if {$ver == $n } {
+ msgprint -c WOKVC -e "The version $ver is already assigned to the shop [lindex $e 0]"
+ return {}
+ }
+ }
+ return $ver
+}
--- /dev/null
+
+auto_load wok_cd_proc
+auto_load wok_exit_proc
+auto_load wok_source_proc
+auto_load wok_setenv_proc
+auto_load wokemacs
+
+if { [info commands tcl_exit_proc] == "" } {
+ rename exit tcl_exit_proc
+ rename wok_exit_proc exit
+}
+
+set tcl_prompt1 {if {[info commands wokcd] != ""} then {puts -nonewline stdout "[wokcd]> "} else {puts -nonewline stdout "tclsh> "}}
+
+global WOK_GLOBALS;
+
+set WOK_GLOBALS(setenv_proc,term) 1
+set WOK_GLOBALS(setenv_proc,emacs) 1
+set WOK_GLOBALS(setenv_proc,tcl) 0
+
+set WOK_GLOBALS(cd_proc,term) 1
+set WOK_GLOBALS(cd_proc,emacs) 1
+set WOK_GLOBALS(cd_proc,tcl) 1
+
+set WOK_GLOBALS(source_proc,term) 1
+set WOK_GLOBALS(source_proc,emacs) 1
+set WOK_GLOBALS(source_proc,tcl) 1
+
+set WOK_GLOBALS(wokinterp,tclcommands) "Winfo|finfo|pinfo|screate|sinfo|srm|ucreate|uinfo|umake|urm|w_info|wcreate|wokcd|wokclose|wokinfo|wokparam|wokprofile|wokenv|wrm|wmove|msclear|wprepare|wstore|wintegre|upack|iwok|wsrc|wdrv|wls|wcd|cd"
--- /dev/null
+/* XPM */
+static char * abstract_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"16 16 4 1 -1 -1",
+/* colors */
+" s topShadowColor m white c #bdbdbdbdbdbd",
+". s iconGray6 m black c #636363636363",
+"X s bottomShadowColor m black c #636363636363",
+"o s iconColor2 m white c white",
+/* pixels */
+" ",
+" ..............X",
+" ......oo......X",
+" ......oo......X",
+" .....o..o.....X",
+" .....o..o.....X",
+" .....o..o.....X",
+" ....o....o....X",
+" ....o....o....X",
+" ...oooooooo...X",
+" ...o......o...X",
+" ...o......o...X",
+" ..o........o..X",
+" ..o........o..X",
+" ..............X",
+" XXXXXXXXXXXXXXX"};
--- /dev/null
+/* XPM */
+static char * continued_xpm[] = {
+/* width height ncolors chars_per_pixel */
+"20 22 5 1",
+/* colors */
+" s None c None",
+". c black",
+"X c slate grey",
+"o c white",
+"O c dark slate grey",
+/* pixels */
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" .. .. .. ",
+" .XX. .XX. .XX. ",
+".XooX. .XooX. .XooX.",
+".XoXX. .XoXX. .XoXX.",
+".XXXX. .XXXX. .XXXX.",
+"O.XX.O O.XX.O O.XX.O",
+" O..O O..O O..O ",
+" OO OO OO ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" "};
--- /dev/null
+/* XPM */
+static char * dirup_xpm[] = {
+/* width height ncolors chars_per_pixel */
+"20 22 5 1",
+/* colors */
+" s None c None",
+". c black",
+"X c wheat",
+"o c sienna",
+"O c dark slate grey",
+/* pixels */
+" ",
+" ",
+" ",
+" ",
+" ........ ",
+" .XXXXXXXX. ",
+".XXXXXXXXXX...... ",
+".oXXXXXXXXoXXXXXX. ",
+".XooooooooXXXXXXXo. ",
+".XXXXXXXXXXXX.XXXoO.",
+".XXXXXXXXXXX...XXoO.",
+".XXXXXXXXXX.....XoO.",
+".XXXXXXXXXXXX.XXXoO.",
+".XXXXXXXXXXXX.XXXoO.",
+".XX.XXX.XXXXX.XXXoO.",
+".X...X...X...XXXXoO.",
+".XX.XXX.XXXXXXXXXoO.",
+".XXXXXXXXXXXXXXXXoO.",
+".XXXXXXXXXXXXXXXXoO.",
+" .oooooooooooooooOO.",
+" .OOOOOOOOOOOOOOO.O",
+" ...............O "};
--- /dev/null
+/* XPM */
+static char * browser_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"32 32 12 1 0 0",
+/* colors */
+" s iconGray4 m white c #949494949494",
+". s iconGray2 m white c #bdbdbdbdbdbd",
+"X s iconColor1 m black c black",
+"o c #FFFF63634747",
+"O c #B2B222222222",
+"+ s iconColor2 m white c white",
+"@ c #BEBEBEBEBEBE",
+"# s iconColor6 m white c yellow",
+"$ c #A0A02020F0F0",
+"% c #EEEE8282EEEE",
+"& c #1E1E9090FFFF",
+"* c #3232CDCD3232",
+/* pixels */
+" ...........X ",
+" .oOoOoOoOoOX ",
+" .OoOoOoOoOoX ",
+" .oOoOoOoOoOX ",
+" .OoOoOoOoOoX ",
+" .oOoOXXXXXXX ",
+" .......OoOoX ",
+" .oOoOoOoOoOX ",
+" .OoOoOoOoOoX ",
+" .oOoOoOoOoOX ",
+" .OoOoOoOoOoX ",
+" .XXXXXXXXXXX ",
+" ",
+" +++ +++ + ",
+" ..... + + + + .....X ",
+" .@#@#X + + + + .$%$%X ",
+" .#@#@X + + + + .%$%$X ",
+" .@#@#X + + + + .$%$%X ",
+" .#@#@X +++ +++ +++ .%$%$X ",
+" .@#@#X .$%$%X ",
+" .#@#@X.....X...........X.%$%$X ",
+" .@#@#@#@#@#X.&*&*&*&*&*X.$%$%X ",
+" .#@#@#@#@#@X.*&*&*&*&*&X.%$%$X ",
+" .@#@#@#@#@#X.&*&*&*&*&*X.$%$%X ",
+" .#@#@#@#@#@X.*&*&*&*&*&X.%$%$X ",
+" .@#@#XXXXXXX.&*&*XXXXXXX.$%$%X ",
+" .#@#@X.......*&*&X.......%$%$X ",
+" .@#@#X.&*&*&*&*&*X.$%$%$%$%$%X ",
+" .#@#@X.*&*&*&*&*&X.%$%$%$%$%$X ",
+" .@#@#X.&*&*&*&*&*X.$%$%$%$%$%X ",
+" .#@#@X.*&*&*&*&*&X.%$%$%$%$%$X ",
+" .XXXXX.XXXXXXXXXXX.XXXXXXXXXXX "};
--- /dev/null
+#define textrect0_width 16
+#define textrect0_height 16
+#define textrect0_x_hot -1
+#define textrect0_y_hot -1
+static char textrect0_bits[] = {
+ 0xfe, 0x7f, 0x02, 0x40, 0x02, 0x40, 0xc2, 0x4f, 0x02, 0x40, 0xf2, 0x4f,
+ 0x02, 0x40, 0xf2, 0x4f, 0x02, 0x40, 0xf2, 0x4f, 0x02, 0x40, 0xf2, 0x4f,
+ 0x02, 0x40, 0xf2, 0x43, 0x02, 0x40, 0xfe, 0x7f};
--- /dev/null
+#define search_width 16
+#define search_height 16
+static char search_bits[] = {
+ 0x00, 0x00, 0xfc, 0x7f, 0x02, 0x00, 0xfc, 0x1f, 0x00, 0x20, 0xf0, 0x1f,
+ 0x08, 0x00, 0xf0, 0x07, 0x00, 0x08, 0x80, 0x07, 0x80, 0x00, 0xf0, 0x07,
+ 0xe0, 0x03, 0xc0, 0x01, 0x80, 0x00, 0x00, 0x00};
--- /dev/null
+#define clock_width 16
+#define clock_height 16
+static char clock_bits[] = {
+ 0xc0,0x03,0x2c,0x04,0xec,0x07,0xc8,0x03,0xe8,0x0f,0x18,0x14,0x04,0x2a,0x04,
+ 0x2b,0x82,0x51,0xc2,0x50,0xc2,0x50,0x82,0x51,0x04,0x29,0x04,0x38,0x1e,0x7e,
+ 0xe6,0x6f};
--- /dev/null
+#define txt_modify_width 16
+#define txt_modify_height 16
+static char txt_modify_bits[] = {
+ 0x06, 0x00, 0x09, 0x00, 0x09, 0x00, 0x0f, 0x00, 0x09, 0x00, 0xc9, 0x01,
+ 0x40, 0x02, 0x40, 0x02, 0xc0, 0x01, 0x40, 0x02, 0x40, 0xe2, 0xc0, 0x91,
+ 0x00, 0x10, 0x00, 0x10, 0x00, 0x90, 0x00, 0xe0};
--- /dev/null
+/* XPM */
+static char * caution_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"40 44 7 1 0 0",
+/* colors */
+" s none m none c none",
+". s iconColor1 m black c black",
+"X c #DCDCDCDCDCDC",
+"o s iconColor3 m black c red",
+"O c #707080809090",
+"+ s iconColor2 m white c white",
+"@ c #2E2E8B8B5757",
+/* pixels */
+" ",
+" ",
+" ",
+" ..... ",
+" ..X.X.. ",
+" ..XXXXX... ",
+" ..XXXXXXXX.. ",
+" .XXXXXXXXXX.. ",
+" ..XXXXXXXXX... ",
+" .XXXXXXXXXX..... ",
+" ..XXXXXXXXXXXXX.. ",
+" ..XXXXXXXXXX..... ",
+" .XXXXXXXXX....... ",
+" ..XXXXXXXX...o..X. ",
+" ....XXXXX..oo..XX. ",
+" ...XX...X......XX.. ",
+" ..X.....X.XX.XXX.X.. ",
+" .X...o..X.X...X.XX.. ",
+" ....oo.X...XX....XX.. ",
+" ......XX...XX....X.. ",
+" .......X.XXXX....O. ",
+" .XX.X.XXXXXX...X.. ",
+" .XXX..XXXX.....X.. . ",
+" .XXX..XX...+...X. .... ",
+" ..........+.+...X.....X... ",
+" ..XX.....+.+.....X...XXXX.. ",
+" ..XXX.....+...+..X.XXXXXXX.. ",
+" ..XXXX.X.....++..X.OOXOXXXX.. ",
+" ..XOXX.X...++XOXXXOXXOXOXO..@. ",
+" ..XOOX.X....XOXXX......XO.... ",
+" ..X...X..X.XXXX........... ",
+" .......XXXXXX...@@@@@@@..O ",
+" ..@@@.@@@..X.X..@@@@@@@..OOOOO ",
+" .@@@@@@@@@.X...@@@@@@@..OOOOO ",
+" ..@@@@@...XOX.@@@@@@..OOOOO ",
+" ..@@@...XX.@@@@@..OOOOO ",
+" OOO...XXXX..@@@..OOOOO ",
+" OOOOO..XXXX..@..OOOOO ",
+" OOO..XOXXX...OOOOO ",
+" O..XOXX..OOOOO ",
+" ..XXOX.OOOO ",
+" .....OOO ",
+" ....O ",
+" "};
--- /dev/null
+/* XPM */
+static char *DocsLeftArrowSmall_xpm[] = {
+/* width height ncolors chars_per_pixel */
+"15 15 15 1",
+/* colors */
+"` c #77868F",
+"a c #556067",
+"b c #CFD4D7",
+"c c #B5BDC2",
+"d c #8C98A0",
+"e c #7E8C95",
+"f c #606C74",
+"g c #4F5A60",
+"h c #6C7A83",
+"i c #A7B0B6",
+"j c #C2C9CD",
+"k c #99A4AB",
+"l c #EBEDEE",
+"m c #AEB7BC",
+"n c #DDE1E3",
+/* pixels */
+"llllllllllnlllf",
+"lbimbbcmbnjjjch",
+"lkcicjjbjbfbbn`",
+"ljjmjjmcegfjbbd",
+"ljbjccdaafhjbjd",
+"lcjijaahhd`cjc`",
+"lmjfaaaede`jjjf",
+"lbbhfh`ededcjjf",
+"lcccchheddejjjd",
+"lkkjbbke`khmcjf",
+"ljmnjbbmdddmmni",
+"lijcimjkbj`bmbf",
+"ljbjcjbmckjnjih",
+"ljbjcjbmckjnjih",
+"ffddkiiefhkifdi"
+};
--- /dev/null
+/* XPM */
+static char * ccl_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 21 1 0 0",
+/* colors */
+" s none m none c none",
+". c #999980805555",
+"X c #66668080AAAA",
+"o c #CCCCBFBFAAAA",
+"O s iconColor1 m black c black",
+"+ s iconColor2 m white c white",
+"@ c #333340405555",
+"# c #333360605555",
+"$ c #FFFFDFDFFFFF",
+"% c #FFFFFFFFAAAA",
+"& c #CCCC20200000",
+"* c #CCCC40400000",
+"= c #999920205555",
+"- c #CCCC80805555",
+"; c #CCCC9F9F5555",
+": c #CCCC80800000",
+"? c #333360600000",
+"> c #333380805555",
+", c #000040405555",
+"< c #33339F9F5555",
+"1 c #00008080AAAA",
+/* pixels */
+" ",
+" ",
+" ",
+" .XoO.O ",
+" oO++O XO ",
+" .OOXoo+O oO ",
+" XO++O O+O OO ",
+" OooXO .O ",
+" OXOo @ ",
+" o.O #$% & ",
+" XO #+%+O+*= ",
+" Oo &$%O%$%%O$& ",
+" #+O-O=%+%+%O%OO ",
+" @#+%$O-O=%+%$%OO ",
+" # O+%+O+%O;OOOOO ",
+" O=%%%$%O%O%%:O?>>O ",
+" OO=%+%+%O%+&O#,#><O ",
+" OOO=%$OOO@#@>><>O ",
+" O#@OOO@#@#><>OO ",
+" OO?@#@O@#@?>>>OX.X ",
+" O<1<>#,#><1<OXXX ",
+" .XO><>>><OOX.X ",
+" XXXOO<><OXXX ",
+" .X.XOX.X ",
+" XXXX ",
+" X "};
--- /dev/null
+/* XPM */
+static char * ccl_open_xpm[] = {
+"24 26 21 1",
+" c #FFFFFFFF0000",
+". c #999980805555",
+"X c #66668080AAAA",
+"o c #CCCCBFBFAAAA",
+"O c #000000000000",
+"+ c #FFFFFFFFFFFF",
+"@ c #333340405555",
+"# c #333360605555",
+"$ c #FFFFDFDFFFFF",
+"% c #FFFFFFFFAAAA",
+"& c #CCCC20200000",
+"* c #CCCC40400000",
+"= c #999920205555",
+"- c #CCCC80805555",
+"; c #CCCC9F9F5555",
+": c #CCCC80800000",
+"? c #333360600000",
+"> c #333380805555",
+", c #000040405555",
+"< c #33339F9F5555",
+"1 c #00008080AAAA",
+" ",
+" ",
+" ",
+" .XoO.O ",
+" oO++O XO ",
+" .OOXoo+O oO ",
+" XO++O O+O OO ",
+" OooXO .O ",
+" OXOo @ ",
+" o.O #$%+& ",
+" XO #+%+O+*= ",
+" Oo &$%O%$%%O$& ",
+" #+O-O=%+%+%O%OO ",
+" @#+%$O-O=%+%$%OO ",
+" #+O+%+O+%O;OOOOO ",
+" O=%%%$%O%O%%:O?>>O ",
+" OO=%+%+%O%+&O#,#><O ",
+" OOO=%$OOO@#@>><>O ",
+" O#@OOO@#@#><>OO ",
+" OO?@#@O@#@?>>>OX.X ",
+" O<1<>#,#><1<OXXX ",
+" .XO><>>><OOX.X ",
+" XXXOO<><OXXX ",
+" .X.XOX.X ",
+" XXXX ",
+" X "};
--- /dev/null
+/* XPM */
+static char *tiny_gray_xpm[] = {
+/* width height ncolors chars_per_pixel */
+"14 14 6 1",
+/* colors */
+" c black",
+". c grey",
+"X c dark slate grey",
+"o c white",
+"O c slate grey",
+"+ c None",
+/* pixels */
+"++++++++++++++",
+"+++++ +++++",
+"++++ OOOO ++++",
+"+++ Oo.OOX +++",
+"++ O.o.OOXX ++",
+"++ OOOOOXXX ++",
+"++ OOOOOXX ++",
+"++ OOOOXXX ++",
+"++ OOXXXX ++",
+"+++ XXXX X +++",
+"++++ X ++++",
+"+++++ +++++",
+"++++++++++++++",
+"++++++++++++++"
+};
--- /dev/null
+/* XPM */
+static char *DocsRightArrowSmall_xpm[] = {
+/* width height ncolors chars_per_pixel */
+"15 15 14 1",
+/* colors */
+"` c #77868F",
+"a c #718089",
+"b c #505B61",
+"c c #A8B1B7",
+"d c #ECEEEF",
+"e c #C3C9CD",
+"f c #86939B",
+"g c #CAD0D3",
+"h c #606C74",
+"i c #939FA6",
+"j c #D8DCDF",
+"k c #99A4AB",
+"l c #5B676E",
+"m c #AEB7BC",
+/* pixels */
+"ddddddddddjdddh",
+"dgmcjgjejdmcega",
+"dmeicemgjdejee`",
+"dcm`blmgegjegdf",
+"dgjilahageeggef",
+"degih```aimeem`",
+"deeih`ai``hkegh",
+"dmgchaafi``meeh",
+"djgmhafffiemggi",
+"dikia`afegkeemh",
+"dmkcafgemjemmjc",
+"dmmckegkgggemjh",
+"dejmcegkgmejeea",
+"djgggggemcgjgma",
+"hhiikccfhakchfc"
+};
--- /dev/null
+/* XPM */
+static char * client_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 11 1 0 0",
+/* colors */
+" s none m none c none",
+". s iconColor1 m black c black",
+"X c #FFFF9F9F0000",
+"o c #FFFFBFBF0000",
+"O s iconColor3 m black c red",
+"+ s iconColor2 m white c white",
+"@ c #33339F9F5555",
+"# c #333380805555",
+"$ c #00008080AAAA",
+"% c #66668080AAAA",
+"& c #999980805555",
+/* pixels */
+" ",
+" . ",
+" .X. ",
+" .XXX. ",
+" ..oX. ",
+" . XX... ",
+" OOO...O. ",
+" .OOOOOOO. ",
+" . .OO..OOOO. ",
+" ...XX.OOOXXX.O.X. ",
+" ..+XXoX...XX...... ",
+" .OOOO.X.XXXXX.O...O. ",
+" .OOOOOO.O..oOOOOOOO. ",
+" .O...OOOO++.O..OOOO. ",
+" ...oX+.O..OO.XX.O. ",
+" .XX..XXXXXX.XX@##. ",
+" .oXo..X.XoXoX.$@#@. ",
+" .X.OOOO.O..X@###@#. ",
+" .O#oX.OOO@#@#@#.. ",
+" ...XX#.O.#@###.%&% ",
+" .oX..@$@#@$@.%%% ",
+" .XX.@###@..%&% ",
+" .X...@#@.%%% ",
+" &%&%.%&% ",
+" %%%% ",
+" % "};
--- /dev/null
+/* XPM */
+static char * client_open_xpm[] = {
+"24 26 11 1",
+" c #FFFFFFFF0000",
+". c #000000000000",
+"X c #FFFF9F9F0000",
+"o c #FFFFBFBF0000",
+"O c #FFFF00000000",
+"+ c #FFFFFFFFFFFF",
+"@ c #33339F9F5555",
+"# c #333380805555",
+"$ c #00008080AAAA",
+"% c #66668080AAAA",
+"& c #999980805555",
+" ",
+" . ",
+" .X. ",
+" .XXX. ",
+" ..oX. ",
+" . XX... ",
+" OOO...O. ",
+" .OOOOOOO. ",
+" . .OO..OOOO. ",
+" ...XX.OOOXXX.O.X. ",
+" ..+XXoX...XX...... ",
+" .OOOO.X.XXXXX.O...O. ",
+" .OOOOOO.O..oOOOOOOO. ",
+" .O...OOOO++.O..OOOO. ",
+" ...oX+.O..OO.XX.O. ",
+" .XX..XXXXXX.XX@##. ",
+" .oXo..X.XoXoX.$@#@. ",
+" .X.OOOO.O..X@###@#. ",
+" .O#oX.OOO@#@#@#.. ",
+" ...XX#.O.#@###.%&% ",
+" .oX..@$@#@$@.%%% ",
+" .XX.@###@..%&% ",
+" .X...@#@.%%% ",
+" &%&%.%&% ",
+" %%%% ",
+" % "};
--- /dev/null
+/* XPM */
+static char * create_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"32 32 8 1 0 0",
+/* colors */
+" s iconGray4 m white c #949494949494",
+". c #BEBEBEBEBEBE",
+"X s iconColor1 m black c black",
+"o c #A0A052522D2D",
+"O s iconColor2 m white c white",
+"+ c #000000008080",
+"@ s iconColor6 m white c yellow",
+"# c #707080809090",
+/* pixels */
+" ",
+" . ",
+" . ",
+" . . ",
+" . . . . ",
+" . . . . ",
+" . . . . . ",
+" . . ",
+" . XXXXXXXXXXX ",
+" . XoooooooooX ",
+" . XXXXXXXXX ",
+" XO++XOOOX ",
+" . XO++XOOOX ",
+" XX XOOXOOOOX ",
+" X X+++XOOOX ",
+" X XO++XOOOX ",
+" XXXXXXXXXXO++XOOXXXX ",
+" X@o@o@o@@XXXXXXX@@@@X ",
+" XX X@o@o@o@@XoooooX@@@@X ",
+" X@X XXXXXXXXXXXXXXXXXXX@X ",
+" XXX X###################X ",
+" X@XXXXXXXXXXXXXXXXXXXXoo#X ",
+" X@X@@@@@@@@@@@@@@@@@@@Xo#X ",
+" X@XXXXXXXXXXXXXXXXXXXXoo#X ",
+" XXX X#oooooooooooooooooo#X ",
+" X@X X##################X ",
+" XX XXXXXXXXXXXXXXXXXX ",
+" ",
+" ",
+" ",
+" ",
+" "};
--- /dev/null
+/* XPM */
+static char * danger_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"32 32 7 1 0 0",
+/* colors */
+" s none m none c none",
+". c #2F2F4F4F4F4F",
+"X s iconColor1 m black c black",
+"o s iconColor2 m white c white",
+"O c #707080809090",
+"+ c #DCDCDCDCDCDC",
+"@ c #BEBEBEBEBEBE",
+/* pixels */
+" ",
+" ",
+" ",
+" ",
+" .XXX .XXX ",
+" .X X. ",
+" . XX ",
+" XXXXXX XXXXXXX ",
+" XooooOX Xoooo+OX ",
+" X+oooo+OXX+oooo++X ",
+" XXooooo+@XXoooooo+XX ",
+" X+ooXXo+@OXooXXoo+OX ",
+" X+ooXXo@@OXooXXo+@OX ",
+" XX+oo++@OXX++oo+@@XX ",
+" XO++@@O.XXO@++@@OX ",
+" XXOO.XX XXXOOXXX ",
+" XXX XXXX ",
+" ",
+" XXXXXXXXXXXXXXXX ",
+" XXXooo.ooo.ooo.oooXX ",
+" XXo.o@@.+@@.o+@.o@@.oX ",
+" X.o...............O.@.X ",
+" X...oo+.ooo.ooo.o...O.X ",
+" X.o.o++.++@.o+@.o+o...X ",
+" X.o.o@@.+@XXXXO.o@@.+.X ",
+" X.o.o@OXXX XXX@@.+.X ",
+" XX.o@XX XO.XX ",
+" XXX XX ",
+" ",
+" ",
+" ",
+" "};
--- /dev/null
+/* XPM */
+static char * delete_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"32 32 6 1 0 0",
+/* colors */
+" s iconGray4 m white c #949494949494",
+". s iconColor1 m black c black",
+"X s iconColor6 m white c yellow",
+"o s iconColor3 m black c red",
+"O c #BEBEBEBEBEBE",
+"+ s iconColor2 m white c white",
+/* pixels */
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" .. X o ",
+" . . o ",
+" . . Xo ",
+" . o.X o ",
+" . oX . o ",
+" . oXX. o ",
+" . o o . ",
+" . o . ",
+" . o ",
+" . ",
+" .......................... ",
+" .O.oooo.X+.ooooooo.X+.oooo. ",
+" .O.oooo.+X.ooooooo.+X.oooo. ",
+" ..........+X.........+X..... ",
+" .O.O.oooo.X+.ooooooo.X+.oooo. ",
+" .O.O.oooo.+X.ooooooo.+X.oooo. ",
+" .........X+.........+X...... ",
+" .O.oooo.+X.ooooooo.X+.oooo. ",
+" .O.oooo.X+.ooooooo.+X.oooo. ",
+" ......................... ",
+" ",
+" ",
+" ",
+" ",
+" "};
--- /dev/null
+/* XPM */
+static char * delivery_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 33 1 0 0",
+/* colors */
+" s none m none c none",
+". s iconColor1 m black c black",
+"X c #99992020FFFF",
+"o c #CCCC2020AAAA",
+"O c #FFFFBFBF0000",
+"+ c #FFFF9F9F0000",
+"@ c #6666BFBFFFFF",
+"# c #FFFFDFDF0000",
+"$ c #CCCCDFDFFFFF",
+"% c #3333DFDF0000",
+"& c #333340405555",
+"* c #9999FFFFAAAA",
+"= s iconColor3 m black c red",
+"- c #9999DFDFFFFF",
+"; c #333360605555",
+": c #3333BFBF5555",
+"? c #999920205555",
+"> c #00008080FFFF",
+", c #66668080AAAA",
+"< c #999980805555",
+"1 c #333380805555",
+"2 c #CCCC20200000",
+"3 c #33339F9FFFFF",
+"4 c #33339F9F5555",
+"5 c #000040405555",
+"6 c #FFFFDFDFAAAA",
+"7 c #333360600000",
+"8 c #3333BFBF0000",
+"9 c #3333DFDF5555",
+"0 c #CCCC9F9F5555",
+"q c #CCCC80805555",
+"w c #CCCC80800000",
+"e c #00008080AAAA",
+/* pixels */
+" ",
+" ",
+" . ",
+" ..Xo.. ",
+" ..O+X@#$. ",
+" .%&*&=&-&;. ",
+" ;&;:;**?;>;&. ",
+" ;,<&1,%:2&3&;. ",
+" 145;$,:;$;$;&. ",
+" 41;&6,6&6&6&;.; ",
+" &4&;$;$;$;$;&;: ",
+" 7&1&6&2&3&8:+ ",
+" 54&;:;&%:9+O+ ",
+" ;14,%&%:%:+++ ",
+" &014+O+++O++: ",
+" 7qwq++++++++%11. ",
+" 50q0+O+O+O+%:414. ",
+" ;qwq%:++++%&;141. ",
+" &4q4:%:9:;141.. ",
+" ..7111%:8&7111.,<, ",
+" .4e;&4:;&4e4.,,, ",
+" <,.141114..,<, ",
+" ,,,..414.,,, ",
+" <,<,.,<, ",
+" ,,,, ",
+" , "};
--- /dev/null
+/* XPM */
+static char * delivery_open_xpm[] = {
+"24 26 33 1",
+" c #FFFFFFFF0000",
+". c #000000000000",
+"X c #99992020FFFF",
+"o c #CCCC2020AAAA",
+"O c #FFFFBFBF0000",
+"+ c #FFFF9F9F0000",
+"@ c #6666BFBFFFFF",
+"# c #FFFFDFDF0000",
+"$ c #CCCCDFDFFFFF",
+"% c #3333DFDF0000",
+"& c #333340405555",
+"* c #9999FFFFAAAA",
+"= c #FFFF00000000",
+"- c #9999DFDFFFFF",
+"; c #333360605555",
+": c #3333BFBF5555",
+"? c #999920205555",
+"> c #00008080FFFF",
+", c #66668080AAAA",
+"< c #999980805555",
+"1 c #333380805555",
+"2 c #CCCC20200000",
+"3 c #33339F9FFFFF",
+"4 c #33339F9F5555",
+"5 c #000040405555",
+"6 c #FFFFDFDFAAAA",
+"7 c #333360600000",
+"8 c #3333BFBF0000",
+"9 c #3333DFDF5555",
+"0 c #CCCC9F9F5555",
+"q c #CCCC80805555",
+"w c #CCCC80800000",
+"e c #00008080AAAA",
+" ",
+" ",
+" . ",
+" ..Xo.. ",
+" ..O+X@#$. ",
+" .%&*&=&-&;. ",
+" ;&;:;**?;>;&. ",
+" ;,<&1,%:2&3&;. ",
+" 145;$,:;$;$;&. ",
+" 41;&6,6&6&6&;.; ",
+" &4&;$;$;$;$;&;: ",
+" 7&1&6&2&3&8:+ ",
+" 54&;:;&%:9+O+ ",
+" ;14,%&%:%:+++ ",
+" &014+O+++O++: ",
+" 7qwq++++++++%11. ",
+" 50q0+O+O+O+%:414. ",
+" ;qwq%:++++%&;141. ",
+" &4q4:%:9:;141.. ",
+" ..7111%:8&7111.,<, ",
+" .4e;&4:;&4e4.,,, ",
+" <,.141114..,<, ",
+" ,,,..414.,,, ",
+" <,<,.,<, ",
+" ,,,, ",
+" , "};
--- /dev/null
+# tri topologik. retourne une liste
+# Exemple wokUtils:EASY:tsort { {a h} {b g} {c f} {c h} {d i} }
+# => { d a b c i g f h }
+#wokUtils:EASY:tsort { listofpairs }
+
+proc ClientTree {w fromud location meter} {
+ global ClientTree_arrayofud ClientTree_arrayofimpl ClientTree_Stop ClientTree_FileName
+ set ClientTree_Stop 0
+
+ if {[winfo exist $w]} {
+ destroy $w
+ }
+
+ if {[info exist ClientTree_arrayofud]} {
+ unset ClientTree_arrayofud
+ }
+
+ if {[info exist ClientTree_arrayofimpl]} {
+ unset ClientTree_arrayofimpl
+ }
+
+ set ClientTree_arrayofud(__uu) 0
+ set ClientTree_arrayofimpl(__uu) 0
+
+ tixTree $w
+ set hlist [$w subwidget hlist]
+
+ $hlist config -indicator 1 -selectmode single -separator "-" -width 30 -drawbranch 1 -indent 30
+
+ tixForm $w -left 0 -right -0 -top 0 -bottom -0
+ tixBusy $w on
+ wokPROP:Meter $meter 1000 0
+ update
+ [wokPROP:LabClt] configure -text "Hit Escape to stop..."
+ bind $hlist <Escape> {
+ global ClientTree_Stop
+ set ClientTree_Stop 1
+ [wokPROP:LabClt] configure -text "Interrupted..."
+ update
+ }
+ focus $hlist
+
+ ClientTree_GetDependence $w $location $fromud $ClientTree_FileName $meter
+ $w autosetmode
+
+ tixBusy $w off
+ [wokPROP:LabClt] configure -text "Ready..."
+ update
+
+ return $ClientTree_arrayofud(__uu)
+}
+
+proc ClientTree_GetDependence {wtree location fromud targetinclude meter} {
+ global ClientTree_arrayofud ClientTree_Stop
+
+ set usetinclude 1
+ set w [$wtree subwidget hlist]
+ set lstud [w_info -l $location]
+ set progress 0
+ set maxrange [llength $lstud]
+
+ if {$targetinclude == ""} {
+ set usetinclude 0
+ }
+
+ foreach ud $lstud {
+ update
+ set ifile ""
+ set lstofimpl {}
+ set ifile [woklocate -p ${ud}:stadmfile:${ud}_obj_comp.Dep $location]
+
+ if {$ClientTree_Stop} return
+
+ if {$ifile != ""} {
+ set lstinc {}
+ set vcxx ""
+ set vhxx ""
+ set vsource ""
+ for_file allud $ifile {
+ if {$ClientTree_Stop} return
+ ## we search for string like this:
+ ## + Storage:object:Storage_BaseDriver.o Storage:source:Storage_BaseDriver.cxx
+ ##
+ if {[string index $allud 0] == "+"} {
+ ## we shoot these kinds of strings:
+ ## + Storage:stadmfile:Storage_obj_comp.In Storage:admfile:Storage_src.Out
+ ## + * Storage:dbadmfile:Storage_xcpp_header.Out
+ ##
+ if {[string first "admfile:" $allud] < 0} {
+ ## we look for a source file including our package
+ ##
+ if {$vsource != "" && $lstinc != {}} {
+ lappend lstofimpl $vsource $lstinc
+ if {[$w info exist $ud] == 0} {
+ $w add $ud -text $ud
+ $w see $ud
+ }
+ set i 0
+ set nomsrc ""
+ regexp {([^:]*):([^:]*):([^:]*)} $vsource all av avv nomsrc
+ $w add $ud-$vsource -text $nomsrc
+ $w hide entry $ud-$vsource
+ foreach u $lstinc {
+ incr i
+ $w add $ud-$vsource-$i -text $u
+ $w hide entry $ud-$vsource-$i
+ if {$ClientTree_Stop} return
+ }
+ update
+ if {$ClientTree_Stop} return
+ }
+ scan $allud "%s %s %s" vs vo vsource
+ set lstinc {}
+ }
+ } else {
+ update
+ if {$ClientTree_Stop} return
+ scan $allud "- * %s" vcxx
+ if {[string first :${fromud}_${ud}_ $vcxx] >= 0} {
+ scan $vcxx "$ud:pubinclude:%s" vhxx
+ if {$usetinclude} {
+ if {$vhxx == $targetinclude} {
+ lappend lstinc $vhxx
+ }
+ } else {
+ lappend lstinc $vhxx
+ }
+ } elseif {[string first :${fromud}_${ud}. $vcxx] >= 0} {
+ scan $vcxx "$fromud:pubinclude:%s" vhxx
+ if {$usetinclude} {
+ if {$vhxx == $targetinclude} {
+ lappend lstinc $vhxx
+ }
+ } else {
+ lappend lstinc $vhxx
+ }
+ } elseif {[string first :${fromud}. $vcxx] >= 0} {
+ scan $vcxx "$fromud:pubinclude:%s" vhxx
+ if {$usetinclude} {
+ if {$vhxx == $targetinclude} {
+ lappend lstinc $vhxx
+ }
+ } else {
+ lappend lstinc $vhxx
+ }
+ } elseif {[string first :${fromud}_ $vcxx] >= 0} {
+ scan $vcxx "$fromud:pubinclude:%s" vhxx
+ if {$usetinclude} {
+ if {$vhxx == $targetinclude} {
+ lappend lstinc $vhxx
+ }
+ } else {
+ lappend lstinc $vhxx
+ }
+ } elseif {[string first Handle_${fromud}_ $vcxx] >= 0} {
+ scan $vcxx "$fromud:pubinclude:%s" vhxx
+ if {$usetinclude} {
+ if {$vhxx == $targetinclude} {
+ lappend lstinc $vhxx
+ }
+ } else {
+ lappend lstinc $vhxx
+ }
+ }
+ }
+ }
+ ## we look for a source file including our package
+ ##
+ if {$vsource != "" && $lstinc != {}} {
+ lappend lstofimpl $vsource $lstinc
+ if {[$w info exist $ud] == 0} {
+ $w add $ud -text $ud
+ $w see $ud
+ }
+ set i 0
+ set nomsrc ""
+ regexp {([^:]*):([^:]*):([^:]*)} $vsource all av avv nomsrc
+ $w add $ud-$vsource -text $nomsrc
+ $w hide entry $ud-$vsource
+ foreach u $lstinc {
+ incr i
+ $w add $ud-$vsource-$i -text $u
+ $w hide entry $ud-$vsource-$i
+ if {$ClientTree_Stop} return
+ }
+ update
+ if {$ClientTree_Stop} return
+ }
+ }
+ set ClientTree_arrayofud($ud) $lstofimpl
+ set progress [wokPROP:Meter $meter $maxrange $progress]
+ }
+}
--- /dev/null
+/* XPM */
+static char * documentation_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 25 1 0 0",
+/* colors */
+" s none m none c none",
+". s iconColor1 m black c black",
+"X c #FFFFFFFFAAAA",
+"o c #333360605555",
+"O c #CCCC80805555",
+"+ c #FFFFDFDFAAAA",
+"@ c #333340405555",
+"# c #66668080AAAA",
+"$ c #CCCCDFDFFFFF",
+"% c #FFFFDFDFFFFF",
+"& s iconColor2 m white c white",
+"* c #CCCCDFDFAAAA",
+"= c #33339F9FFFFF",
+"- c #999920205555",
+"; c #CCCC20200000",
+": c #00008080FFFF",
+"? c #CCCC40400000",
+"> c #999920200000",
+", c #CCCC80800000",
+"< c #FFFF80800000",
+"1 c #CCCC9F9F5555",
+"2 c #999940405555",
+"3 c #999960600000",
+"4 c #CCCC60600000",
+"5 c #999980805555",
+/* pixels */
+" ",
+" ",
+" ",
+" .X ",
+" X. ",
+" oOX. +++. ",
+" . o@X#X +..++$ ",
+" XXOX@o%X.&&+++. ",
+" .&X#o&X&+..$+*+.= ",
+" . X-;&X%X&X...++++.: ",
+" X.?-.&X&X&X.......= ",
+" X%;OXO;>;.XXX%.. .. ",
+" .&X.?-;.X&X&X. ",
+" X..-;-.&X.X&. ",
+" X&...&X&X... ",
+" .%XX.%X.,O<O,. ",
+" X.X&X&.O1O1O1. ",
+" ..X%X..O,O,O,O. ",
+" .123...OO1OOO.. ",
+" ..<O,O4..O<O,O.#5# ",
+" .1O1O1O1O1O1.### ",
+" 5#.O,O,O,..#5# ",
+" ###..OO1.### ",
+" 5#5#.#5# ",
+" #### ",
+" # "};
--- /dev/null
+/* XPM */
+static char * documentation_open_xpm[] = {
+"24 26 25 1",
+" c #FFFFFFFF0000",
+". c #000000000000",
+"X c #FFFFFFFFAAAA",
+"o c #FFFFFFFFFFFF",
+"O c #333360605555",
+"+ c #CCCC80805555",
+"@ c #FFFFDFDFAAAA",
+"# c #333340405555",
+"$ c #66668080AAAA",
+"% c #CCCCDFDFFFFF",
+"& c #FFFFDFDFFFFF",
+"* c #CCCCDFDFAAAA",
+"= c #33339F9FFFFF",
+"- c #999920205555",
+"; c #CCCC20200000",
+": c #00008080FFFF",
+"? c #CCCC40400000",
+"> c #999920200000",
+", c #CCCC80800000",
+"< c #FFFF80800000",
+"1 c #CCCC9F9F5555",
+"2 c #999940405555",
+"3 c #999960600000",
+"4 c #CCCC60600000",
+"5 c #999980805555",
+" ",
+" ",
+" ",
+" .X ",
+" oX. ",
+" oO+X. @@@. ",
+" .oO#X$Xo@..@@% ",
+" XX+X#O&X.oo@@@. ",
+" o.oX$OoXo@..%@*@.= ",
+" .oX-;oX&XoX...@@@@.: ",
+" oX.?-.oXoXoX.......= ",
+" X&;+X+;>;.XXX&.. .. ",
+" .oX.?-;.XoXoX. ",
+" X..-;-.oX.Xo. ",
+" Xo...oXoX... ",
+" .&XX.&X.,+<+,. ",
+" X.XoXo.+1+1+1. ",
+" ..X&X..+,+,+,+. ",
+" .123...++1+++.. ",
+" ..<+,+4..+<+,+.$5$ ",
+" .1+1+1+1+1+1.$$$ ",
+" 5$.+,+,+,..$5$ ",
+" $$$..++1.$$$ ",
+" 5$5$.$5$ ",
+" $$$$ ",
+" $ "};
--- /dev/null
+/* XPM */
+static char * engine_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 22 1 0 0",
+/* colors */
+" s none m none c none",
+". c #CCCCBFBFAAAA",
+"X c #9999BFBFFFFF",
+"o c #66668080AAAA",
+"O c #CCCCDFDFFFFF",
+"+ c #999980805555",
+"@ c #333340405555",
+"# c #333360605555",
+"$ c #333360600000",
+"% c #FFFFDFDFAAAA",
+"& s iconColor1 m black c black",
+"* c #999920205555",
+"= c #CCCC40400000",
+"- c #999920200000",
+"; c #CCCC20200000",
+": s iconColor2 m white c white",
+"? c #CCCCBFBFFFFF",
+"> c #000040405555",
+", c #CCCC80800000",
+"< c #CCCC80805555",
+"1 c #CCCC9F9F5555",
+"2 c #FFFF80800000",
+/* pixels */
+" ",
+" ",
+" .XoX.X.XOO ",
+" ..+@..#@$o#o%o ",
+" Xo@#X.X#XoX.OO ",
+" ..#.%.+@#.+& ",
+" o.@.o.X.X&&&*= ",
+" +@+..&&*&-&*;- ",
+" &&X.&;&=*&*&*& ",
+" &&...&&;.;.;& ",
+" =*.X.X&&.*.*& ",
+" -;*;&.&&.;*;- ",
+" &*&@=*&*=&;&=*; ",
+" &*;*;*;&;*;&;&&& ",
+" =O#*&&;*=&;*=oo& ",
+" $::?;&&&&-&&+&+o$ ",
+" >O:#*&&=*;&oo&&o>& ",
+" &&&*,&&&&&+o&&&<&& ",
+" &&&&&&&&&&&&o&1&o ",
+" &&&&@&&#&+&&&2&+o+ ",
+" &&&&&&&&&&&1&&ooo ",
+" o+@&&,<,<&o+o ",
+" oooo@<<1<&&oo ",
+" +o+o&&+o+ ",
+" ooo ",
+" + "};
--- /dev/null
+/* XPM */
+static char * engine_open_xpm[] = {
+"24 26 22 1",
+" c #FFFFFFFF0000",
+". c #CCCCBFBFAAAA",
+"X c #9999BFBFFFFF",
+"o c #66668080AAAA",
+"O c #CCCCDFDFFFFF",
+"+ c #999980805555",
+"@ c #333340405555",
+"# c #333360605555",
+"$ c #333360600000",
+"% c #FFFFDFDFAAAA",
+"& c #000000000000",
+"* c #999920205555",
+"= c #CCCC40400000",
+"- c #999920200000",
+"; c #CCCC20200000",
+": c #FFFFFFFFFFFF",
+"? c #CCCCBFBFFFFF",
+"> c #000040405555",
+", c #CCCC80800000",
+"< c #CCCC80805555",
+"1 c #CCCC9F9F5555",
+"2 c #FFFF80800000",
+" ",
+" ",
+" .XoX.X.XOO ",
+" ..+@..#@$o#o%o ",
+" Xo@#X.X#XoX.OO ",
+" ..#.%.+@#.+& ",
+" o.@.o.X.X&&&*= ",
+" +@+..&&*&-&*;- ",
+" &&X.&;&=*&*&*& ",
+" &&...&&;.;.;& ",
+" =*.X.X&&.*.*& ",
+" -;*;&.&&.;*;- ",
+" &*&@=*&*=&;&=*; ",
+" &*;*;*;&;*;&;&&& ",
+" =O#*&&;*=&;*=oo& ",
+" $::?;&&&&-&&+&+o$ ",
+" >O:#*&&=*;&oo&&o>& ",
+" &&&*,&&&&&+o&&&<&& ",
+" &&&&&&&&&&&&o&1&o ",
+" &&&&@&&#&+&&&2&+o+ ",
+" &&&&&&&&&&&1&&ooo ",
+" o+@&&,<,<&o+o ",
+" oooo@<<1<&&oo ",
+" +o+o&&+o+ ",
+" ooo ",
+" + "};
--- /dev/null
+/* XPM */
+static char * envir60_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 22 1 0 0",
+/* colors */
+" s none m none c none",
+". c #AAAAAAAAAAAA",
+"X c #3E3E3E3E3E3E",
+"o c #515151515151",
+"O c #2F2F2F2F2F2F",
+"+ c cyan",
+"@ c #777777777777",
+"# c cyan",
+"$ c #7D7D7D7D7D7D",
+"% s iconColor1 m black c black",
+"& c blue",
+"* c blue",
+"= c blue",
+"- c green",
+"; c cyan",
+": c #838383838383",
+"? s iconGray2 m white c #bdbdbdbdbdbd",
+"> c red",
+", c #646464646464",
+"< c #767676767676",
+"1 c #484848484848",
+"2 c #5E5E5E5E5E5E",
+/* pixels */
+" ",
+" ",
+" ",
+" ..X ",
+" .oO+ ",
+" .X+@+# .Xo ",
+" $#+#+#%.o&*& ",
+" $+@+%%.o=-=- ",
+" $#+.oO*&*&*& ",
+" ;+#:=*&-=*&- ",
+" ;#+$*&*&*& & ",
+" ;+@:=-=%%. - ",
+" ;#+;*%?Xo> & ",
+" ;+#;%.X>>> - ",
+" ;#%.o>>>>> ",
+" ;%$>>>>>>> , ",
+" ;%$>>>>>>> ,< ",
+" ;%$>>>>>>> <, ",
+" oX;%;>>>>>%, ",
+" 1Xo%%;>>>>%,%$:$ ",
+" <2oXo%;>%%<%$$$ ",
+" :$%,<X%%<%%$:$ ",
+" $$$%%<%<%$$$ ",
+" :$:$%$:$ ",
+" $$$$ ",
+" $ "};
--- /dev/null
+/* XPM */
+static char * envir60_open_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 22 1 0 0",
+/* colors */
+" s iconColor6 m white c yellow",
+". c #AAAAAAAAAAAA",
+"X c #3E3E3E3E3E3E",
+"o c #515151515151",
+"O c #2F2F2F2F2F2F",
+"+ c cyan",
+"@ c #777777777777",
+"# c cyan",
+"$ c #7D7D7D7D7D7D",
+"% s iconColor1 m black c black",
+"& c blue",
+"* c blue",
+"= c blue",
+"- c green",
+"; c cyan",
+": c #838383838383",
+"? s iconGray2 m white c #bdbdbdbdbdbd",
+"> c #1C1C1C1C1C1C",
+", c #646464646464",
+"< c #767676767676",
+"1 c #484848484848",
+"2 c #5E5E5E5E5E5E",
+/* pixels */
+" ",
+" ",
+" ",
+" ..X ",
+" .oO+ ",
+" .X+@+# .Xo ",
+" $#+#+#%.o&*& ",
+" $+@+%%.o=-=- ",
+" $#+.oO*&*&*& ",
+" ;+#:=*&-=*&- ",
+" ;#+$*&*&*& & ",
+" ;+@:=-=%%. - ",
+" ;#+;*%?Xo> & ",
+" ;+#;%.X>>> - ",
+" ;#%.o>>>>> ",
+" ;%$>>>>>>> , ",
+" ;%$>>>>>>> ,< ",
+" ;%$>>>>>>> <, ",
+" oX;%;>>>>>%, ",
+" 1Xo%%;>>>>%,%$:$ ",
+" <2oXo%;>%%<%$$$ ",
+" :$%,<X%%<%%$:$ ",
+" $$$%%<%<%$$$ ",
+" :$:$%$:$ ",
+" $$$$ ",
+" $ "};
--- /dev/null
+/* XPM */
+static char * executable_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 21 1 0 0",
+/* colors */
+" s none m none c none",
+". c #333360605555",
+"X c #999940405555",
+"o c #999960600000",
+"O c #999960605555",
+"+ c #333340405555",
+"@ c #CCCC60600000",
+"# c #333360600000",
+"$ c #000040405555",
+"% c #FFFFDFDFAAAA",
+"& s iconColor1 m black c black",
+"* c #66668080AAAA",
+"= c #CCCC9F9FAAAA",
+"- c #999980805555",
+"; c #CCCCDFDFFFFF",
+": c #CCCCBFBFAAAA",
+"? c #CCCCDFDFAAAA",
+"> c #CCCCBFBFFFFF",
+", c #CCCC40400000",
+"< c #CCCC20200000",
+"1 c #999920205555",
+/* pixels */
+" ",
+" ",
+" .XoOo+ ",
+" +@+@+#X@X@ ",
+" o$O+oXOOoX ",
+" .X%+.X.%%%% ",
+" &+.+oX%%%+.+**& ",
+" *.=#X@%%+&*-;%* ",
+" **+:$:+.&*;?;;;?;& ",
+" &-*-+-+.*%;%;%;%;%& ",
+" &+***+.*;;%;;;%;;;& ",
+" &#&&+-*%>%;%>%;%>%& ",
+" +.$.+.$.;?;;;?;;;?;& ",
+" .+.+.+&+%;%;%;%;%;%& ",
+" &+.+;&.;;;%;;;%;;& ",
+" &#&&+#+%>%;%>%;%& ",
+" &$.&.$.;?;;;?;&&,& ",
+" &+&+.+%;%;%&.+<1& ",
+" &.&.+.;;;&+.1&& ",
+" &&#+.&#+%&&+<1&*-* ",
+" &,1.+.$.+.1<&*** ",
+" -*&1<1.+<&&*-* ",
+" ***&&<1,&*** ",
+" -*-*&*-* ",
+" **** ",
+" * "};
--- /dev/null
+/* XPM */
+static char * executable_open_xpm[] = {
+"24 26 21 1",
+" c #FFFFFFFF0000",
+". c #333360605555",
+"X c #999940405555",
+"o c #999960600000",
+"O c #999960605555",
+"+ c #333340405555",
+"@ c #CCCC60600000",
+"# c #333360600000",
+"$ c #000040405555",
+"% c #FFFFDFDFAAAA",
+"& c #000000000000",
+"* c #66668080AAAA",
+"= c #CCCC9F9FAAAA",
+"- c #999980805555",
+"; c #CCCCDFDFFFFF",
+": c #CCCCBFBFAAAA",
+"? c #CCCCDFDFAAAA",
+"> c #CCCCBFBFFFFF",
+", c #CCCC40400000",
+"< c #CCCC20200000",
+"1 c #999920205555",
+" ",
+" ",
+" .XoOo+ ",
+" +@+@+#X@X@ ",
+" o$O+oXOOoX ",
+" .X%+.X.%%%% ",
+" &+.+oX%%%+.+**& ",
+" *.=#X@%%+&*-;%* ",
+" **+:$:+.&*;?;;;?;& ",
+" &-*-+-+.*%;%;%;%;%& ",
+" &+***+.*;;%;;;%;;;& ",
+" &#&&+-*%>%;%>%;%>%& ",
+" +.$.+.$.;?;;;?;;;?;& ",
+" .+.+.+&+%;%;%;%;%;%& ",
+" &+.+;&.;;;%;;;%;;& ",
+" &#&&+#+%>%;%>%;%& ",
+" &$.&.$.;?;;;?;&&,& ",
+" &+&+.+%;%;%&.+<1& ",
+" &.&.+.;;;&+.1&& ",
+" &&#+.&#+%&&+<1&*-* ",
+" &,1.+.$.+.1<&*** ",
+" -*&1<1.+<&&*-* ",
+" ***&&<1,&*** ",
+" -*-*&*-* ",
+" **** ",
+" * "};
--- /dev/null
+/* XPM */
+static char * home3_xpm[] = {
+/* width height ncolors chars_per_pixel */
+"32 32 13 1",
+/* colors */
+" c none m none c none",
+". c slate grey",
+"X c black",
+"o c sienna",
+"O c orange",
+"+ c red",
+"@ c tan",
+"# c wheat",
+"$ c lime green",
+"% c sky blue",
+"& c dodger blue",
+"* c sea green",
+"= c peru",
+/* pixels */
+" ",
+" . .. .. ",
+" .. . . . ",
+" . ",
+" . ",
+" XXX ",
+" XoX ",
+" XXXXXoXXXXXXXXXXXX ",
+" XOOOXXOOO+OOOO+OOX ",
+" XXOO+O+OO+OOOO+OOO+X ",
+" X@X+OOO+OOOO+OOOO+OX ",
+" X@@XOO+OOOO+OOOO+OOOOX ",
+" XX@XX+OOO+OO+O+OO+O+OX ",
+" XoX@XOOO+OOOOOO+OOOOOOX ",
+" X#oXXXXXXXXXXXXXXXXXXXX ",
+" X##oXoooooooooooooooo#X ",
+" X#X#X#################X ",
+" X#X#X##XX###XX###ooo##X ",
+" X#X#X#X%&X#X%&X#o###o#X ",
+" X#X#X#X%&X#X%&X##XXX##X ",
+" *X###X#X&&X#X&&X#X===X#X* ",
+" *$X###X#XXXX#XXXX#X===X#X$*$ ",
+" $$$X###X###########X===X#X$$*$ ",
+"$*$*X#*#X###########XX==X#X**$*$",
+"$$$$$X*#X##*#####*##X===X#X$$*$*",
+"**$*$$*#X#*###*#*###X===X#X*$$*$",
+"$$$*$*$XX#*#*#*#*#*#XXXXX#X$*$*$",
+"*$*$$**$XX*X*X*X*X*XX@@@XXX*$$$*",
+" *$$$**$*$*$**$$*$*$$@@@@$$$$*$ ",
+" **$$$$*$**$$$*$*$$$*@@@@*$** ",
+" $$*$$$$**$*$*$**$@@@ ",
+" "};
--- /dev/null
+/* XPM */
+static char * factory_open_xpm[] = {
+"28 28 12 1",
+" c #FFFFFFFF0000",
+". c #000000000000",
+"X c #99998080AAAA",
+"o c #99999F9FAAAA",
+"O c #FFFFFFFFFFFF",
+"+ c #FFFF00000000",
+"@ c #CCCCBFBFAAAA",
+"# c #9999BFBFFFFF",
+"$ c #00000000FFFF",
+"% c #CCCC9F9FAAAA",
+"& c #FFFF0000FFFF",
+"* c #0000FFFF0000",
+" .... ",
+" .X... ",
+" .........oo......... ",
+" .O+++++++++...++++++++. ",
+"..O.++++++++++++++++++++ ",
+"OO...+++...+++...+++...+ ",
+".O..+...+++...+++...+++.. ",
+"@....+++...+++...+++...++ ",
+"#@.OO.+++++++++++++++++++. ",
+"@.@.O.++++++++++++++++++++. ",
+"#$.@...++++++++++++++++++++ ",
+"@$.%@...+++...+++...+++...+ ",
+"#..@.@......................",
+"@@@@$.@@@@@@@@@@@@@@@@@@@@@.",
+"#@#@$.#@#@..#@#.#@#..@#..@#.",
+"@@@%..@%@@$$.@.$.@.$.@.$.@@.",
+"#@.@#@#@#@...@...@...@...@#.",
+"@.@@.@@@@@...@...@...@...@@.",
+"#$.@&.#@#.#@#@.@#@.@#@#@#@#.",
+"@$.%@.@%@.@%@@.%. ..@@.%@@@.",
+"#..@#@#@#@#@#@#@. .#@#@#@#.",
+".@..*.@@.@@@@@@.@@.@@@@@@@@.",
+" .#.*.#@#$...$.@#@.@#.......",
+" ...*.@%@$...$.%@.*.@.......",
+" .*.#@#$...$.@.**.........",
+" ..@@@......@..*..@@@@@@.",
+" .#@#......@.**..@#.#@#.",
+" .%.@@.@@@%.......%@@.."};
--- /dev/null
+/* XPM */
+static char * file_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"20 22 5 1 0 0",
+/* colors */
+" c #2F2F4F4F4F4F",
+". s iconGray4 m white c #949494949494",
+"X s iconColor2 m white c white",
+"o s iconColor1 m black c black",
+"O c #707080809090",
+/* pixels */
+" .......",
+" XXXXXXXXXX X ......",
+" XXXXXXXXXX XX .....",
+" XXXXXXXXXX XXX ....",
+" XXXXXXXXXX XXXX ...",
+" XXXXXXXXXXo o o o..",
+" XXXXXXXXXXooooooo..",
+" XXXXXXXXXXXXOOOOo..",
+" XXXXXXXXXXXXXOOOo..",
+" XXXXXXXXXXXXXXXOo..",
+" XXXXXXXXXXXXXXXOo..",
+" XXXXXXXXXXXXXXXOo..",
+" XXXXXXXXXXXXXXXOo..",
+" XXXXXXXXXXXXXXXOo..",
+" XXXXXXXXXXXXXXXOo..",
+" XXXXXXXXXXXXXXXOo..",
+" XXXXXXXXXXXXXXXOo..",
+" XXXXXXXXXXXXXXXOo..",
+" XXXXXXXXXXXXXXXOo..",
+" XXXXXXXXXXXXXXXOo..",
+" OOOOOOOOOOOOOO o..",
+"..oooooooooooooooo.."};
--- /dev/null
+/* XPM */
+static char * frontal_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 29 1 0 0",
+/* colors */
+" s none m none c none",
+". s iconColor1 m black c black",
+"X c #333360605555",
+"o c #333340405555",
+"O c #333360600000",
+"+ c #66668080AAAA",
+"@ c #999980805555",
+"# c #000040405555",
+"$ c #CCCCDFDFFFFF",
+"% c #CCCCBFBFAAAA",
+"& c #FFFFDFDFAAAA",
+"* c #CCCCDFDFAAAA",
+"= c #FFFFBFBF0000",
+"- c #FFFF9F9F0000",
+"; s iconColor3 m black c red",
+": c #3333DFDF0000",
+"? c #3333BFBF5555",
+"> c #CCCCBFBFFFFF",
+", c #3333BFBF0000",
+"< c #33339F9FFFFF",
+"1 c #00008080FFFF",
+"2 c #00009F9FFFFF",
+"3 c #999940405555",
+"4 c #CCCC60600000",
+"5 c #CCCC80805555",
+"6 c #999960600000",
+"7 c #CCCC9F9F5555",
+"8 c #999960605555",
+"9 c #CCCC80800000",
+/* pixels */
+" ",
+" ",
+" .....XoXo ",
+" .....OoXoOoX+@+ ",
+" .....oX#XoX#X++++ ",
+" .....oXoXoXoX+@+@o@+ ",
+" ...XoXoXoX+++++X$%++ ",
+" ...oXoOo@+@+@+O$&%@+ ",
+" ......+++++X$*$=$%++ ",
+" ......@+X$&$---$&%@+ ",
+" ......+X$$$=--;:?%++ ",
+" ......@o&>-;;;:?,%@+ ",
+" ......+X;;;$?:$;$%++ ",
+" ......@o&;&$:$&;;%@+ ",
+" ......+X$$$<1$$&.+++ ",
+" ......@o<1<$&>.+@+. ",
+" ......+X2*$$..+++.. ",
+" ....@o&$.+@+.345. ",
+" ....+..+++.65.. ",
+" ..4...@+@+@.45.+@+ ",
+" .758..++.637.+++ ",
+" @+.593.39..+@+ ",
+" +++..587.+++ ",
+" @+@+.+@+ ",
+" ++++ ",
+" + "};
--- /dev/null
+/* XPM */
+static char * frontal_open_xpm[] = {
+"24 26 29 1",
+" c #FFFFFFFF0000",
+". c #000000000000",
+"X c #333360605555",
+"o c #333340405555",
+"O c #333360600000",
+"+ c #66668080AAAA",
+"@ c #999980805555",
+"# c #000040405555",
+"$ c #CCCCDFDFFFFF",
+"% c #CCCCBFBFAAAA",
+"& c #FFFFDFDFAAAA",
+"* c #CCCCDFDFAAAA",
+"= c #FFFFBFBF0000",
+"- c #FFFF9F9F0000",
+"; c #FFFF00000000",
+": c #3333DFDF0000",
+"? c #3333BFBF5555",
+"> c #CCCCBFBFFFFF",
+", c #3333BFBF0000",
+"< c #33339F9FFFFF",
+"1 c #00008080FFFF",
+"2 c #00009F9FFFFF",
+"3 c #999940405555",
+"4 c #CCCC60600000",
+"5 c #CCCC80805555",
+"6 c #999960600000",
+"7 c #CCCC9F9F5555",
+"8 c #999960605555",
+"9 c #CCCC80800000",
+" ",
+" ",
+" .....XoXo ",
+" .....OoXoOoX+@+ ",
+" .....oX#XoX#X++++ ",
+" .....oXoXoXoX+@+@o@+ ",
+" ...XoXoXoX+++++X$%++ ",
+" ...oXoOo@+@+@+O$&%@+ ",
+" ......+++++X$*$=$%++ ",
+" ......@+X$&$---$&%@+ ",
+" ......+X$$$=--;:?%++ ",
+" ......@o&>-;;;:?,%@+ ",
+" ......+X;;;$?:$;$%++ ",
+" ......@o&;&$:$&;;%@+ ",
+" ......+X$$$<1$$&.+++ ",
+" ......@o<1<$&>.+@+. ",
+" ......+X2*$$..+++.. ",
+" ....@o&$.+@+.345. ",
+" ....+..+++.65.. ",
+" ..4...@+@+@.45.+@+ ",
+" .758..++.637.+++ ",
+" @+.593.39..+@+ ",
+" +++..587.+++ ",
+" @+@+.+@+ ",
+" ++++ ",
+" + "};
--- /dev/null
+/* XPM */
+static char * textfile_xpm[] = {
+"12 12 3 1",
+" s None c None",
+". c black",
+"X c #FFFFFFFFF3CE",
+" ........ ",
+" .XXXXXX. ",
+" .XXXXXX... ",
+" .XX...XXX. ",
+" .XXX....X. ",
+" .X.XX...X. ",
+" .X..XX..X. ",
+" .X...XX.X. ",
+" .X....XXX. ",
+" .X......X. ",
+" .XXXXXXXX. ",
+" .......... "};
--- /dev/null
+/* XPM */
+static char * idl_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 17 1 0 0",
+/* colors */
+" s none m none c none",
+". s iconColor3 m black c red",
+"X s iconColor1 m black c black",
+"o c #FFFFDFDFAAAA",
+"O c #CCCCDFDFFFFF",
+"+ c #FFFF9F9F0000",
+"@ c #CCCCBFBFFFFF",
+"# s iconColor2 m white c white",
+"$ c #CCCCDFDFAAAA",
+"% c #FFFFBFBF0000",
+"& c #333380805555",
+"* c #333340405555",
+"= c #000040405555",
+"- c #333360605555",
+"; c #33339F9F5555",
+": c #00008080AAAA",
+"? c #333360600000",
+/* pixels */
+" ",
+" ",
+" ",
+" .X ",
+" X..X ",
+" .....X ",
+" X....XX oX ",
+" X...X XOX ",
+" X....X XOX ",
+" XXX..X X XXX+ ",
+" X..X XOX XOXX+X ",
+" X..XoOX@XXoX##X+++ ",
+" X..XX#X$OXOX#X+%+X ",
+" X..XX##OXXoXX+++X ",
+" XOX.XO###XXX+++%X+ ",
+" XXoOo@oX&X++++X*XX ",
+" XXX$OOX%+%XX=-&X ",
+" o..X++++X*-*-&;X ",
+" XOX..++%X-*;&;&X* ",
+" X@X.X+XX-*;&&&X*-* ",
+" X;:%X-=-&;:X*-= ",
+" -*X&-&&&;X-*- ",
+" *-*X&;&;X-*- ",
+" *?*-X?*- ",
+" -*-= ",
+" * "};
--- /dev/null
+/* XPM */
+static char * idl_open_xpm[] = {
+"24 26 26 1",
+" c #FFFFFFFF0000",
+". c #000000000000",
+"X c #FFFF00000000",
+"o c #33338080FFFF",
+"O c #33339F9FFFFF",
+"+ c #00008080FFFF",
+"@ c #00009F9FFFFF",
+"# c #CCCCBFBFAAAA",
+"$ c #9999BFBFFFFF",
+"% c #FFFFBFBF0000",
+"& c #FFFF9F9F0000",
+"* c #3333BFBF5555",
+"= c #3333DFDF0000",
+"- c #3333BFBF0000",
+"; c #66668080AAAA",
+": c #333360605555",
+"? c #CCCC80805555",
+"> c #FFFF80800000",
+", c #CCCC9F9F5555",
+"< c #999940405555",
+"1 c #CCCC60600000",
+"2 c #999960600000",
+"3 c #999960605555",
+"4 c #333340405555",
+"5 c #CCCC80800000",
+"6 c #999980805555",
+" ",
+" ",
+" ",
+" .XX. .oO. ",
+" .XXXX.. .+O@O. ",
+" .XXXXX#X.oO+OoO. ",
+" .XXX$#$X.O+O$O+. ",
+" ....XXX#.+OoO##.. ",
+" ..XX.%&..O@#.%$ ",
+" .*=*...&##&&&&&&# ",
+" ..*=*.&.&&$..#$#& ",
+" ....-*=.&+O..#.. ",
+" ...*=*.@#+O.. ",
+" .*##.+Oo##.;. ",
+" .X....+O$.XXXXX. ",
+" .XXXXXXX:?>XXXXXXX ",
+" .XXXXXX#?,<..XXX$#. ",
+" .XXXXXX#1<2..XXX##. ",
+" .XXXXX.<232.XXX. ",
+" .4..#..?5<1<5.#.6; ",
+" .,<,.,?,?,?,.;;; ",
+" 6;.?5?5?5..;6; ",
+" ;;;..??,.;;; ",
+" 6;6;.;6; ",
+" ;;;; ",
+" ; "};
--- /dev/null
+/* XPM */
+static char * interface_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 10 1 0 0",
+/* colors */
+" s none m none c none",
+". s iconColor1 m black c black",
+"X c #FFFF9F9F0000",
+"o s iconColor3 m black c red",
+"O c #FFFFBFBF0000",
+"+ c #66668080AAAA",
+"@ c #33339F9F5555",
+"# c #333380805555",
+"$ c #999980805555",
+"% c #00008080AAAA",
+/* pixels */
+" ",
+" . ",
+" ..X.o. ",
+" .XXXX.oo. ",
+" .XOXO.ooo ",
+" . ..XXX.ooooo+ ",
+" ...XXOX.oooo... ",
+" ..XXXX.ooo..X.o. ",
+" .XOX.oooo.OXOX.oo. ",
+" .XX.oooo.XXX..ooo. ",
+" .X.oo..XXX.ooooo. ",
+" ..XXXX.oooo... ",
+" .OXO..ooo.XOX.oo. ",
+" .XXX.oooo.XXXX.oo. ",
+" .XX.oooo.XXO..ooo. ",
+" ..o.XXXX.oooo.o. ",
+" ..OXOX.oooo...@. ",
+" .XXX..ooo.@###@#. ",
+" .XO.oooo.#@#@#.. ",
+" .XX.oooo.#@###.+$+ ",
+" .@..o.%@#@%@.+++ ",
+" $+.#@###@..+$+ ",
+" +++..@#@.+++ ",
+" $+$+.+$+ ",
+" ++++ ",
+" + "};
--- /dev/null
+/* XPM */
+static char * interface_open_xpm[] = {
+"24 26 10 1",
+" c #FFFFFFFF0000",
+". c #000000000000",
+"X c #FFFF9F9F0000",
+"o c #FFFF00000000",
+"O c #FFFFBFBF0000",
+"+ c #66668080AAAA",
+"@ c #33339F9F5555",
+"# c #333380805555",
+"$ c #999980805555",
+"% c #00008080AAAA",
+" ",
+" . ",
+" ..X.o. ",
+" .XXXX.oo. ",
+" .XOXO.ooo ",
+" . ..XXX.ooooo+ ",
+" ...XXOX.oooo... ",
+" ..XXXX.ooo..X.o. ",
+" .XOX.oooo.OXOX.oo. ",
+" .XX.oooo.XXX..ooo. ",
+" .X.oo..XXX.ooooo. ",
+" ..XXXX.oooo... ",
+" .OXO..ooo.XOX.oo. ",
+" .XXX.oooo.XXXX.oo. ",
+" .XX.oooo.XXO..ooo. ",
+" ..o.XXXX.oooo.o. ",
+" ..OXOX.oooo...@. ",
+" .XXX..ooo.@###@#. ",
+" .XO.oooo.#@#@#.. ",
+" .XX.oooo.#@###.+$+ ",
+" .@..o.%@#@%@.+++ ",
+" $+.#@###@..+$+ ",
+" +++..@#@.+++ ",
+" $+$+.+$+ ",
+" ++++ ",
+" + "};
--- /dev/null
+/* XPM */
+static char * journal_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"32 32 8 1 0 0",
+/* colors */
+" s iconGray4 m white c #949494949494",
+". s iconColor1 m black c black",
+"X c #F5F5DEDEB3B3",
+"o s iconColor5 m black c blue",
+"O c #2F2F4F4F4F4F",
+"+ s iconColor3 m black c red",
+"@ c #BEBEBEBEBEBE",
+"# c #707080809090",
+/* pixels */
+" ",
+" ",
+" .............................. ",
+" .XXXXXXXXXXXXXXXXXXXXXXXXXXXX. ",
+" .XooooXXXXXXXXX..XXXXXXXooooX.O",
+" .XXXXXX.X.X.X.X.XXX.X..XXXXXX.O",
+" .X++++XX..XX.XX..X..X..X++++X.O",
+" .X++++XXXXXXXXXXXXXXXX.X++++X.O",
+" .XXXXXXXXXXXXXXXXXXXXXXXXXXXX.O",
+" ..............................O",
+" .XXXXXXXXXXXXXXXXXXXXXXXXXXXX.O",
+" .XX...X.XX.X....X...@X@..@X.X.O",
+" .XX.#XXXOOXXX.XXX.XX.X.XX.X.X.O",
+" .XX.XXXXOOXXX.XXX.X.XX....XXX.O",
+" .XX...X.XX.XX.XXX.XX.X.XX.X.X.O",
+" .XXXXXXXXXXXXXXXXXXXXXXXXXXXX.O",
+" ..............................O",
+" .XXXXXXXXXXXXXXXXXXXXXXXXXXXX.O",
+" .X.X.X.XXO..........OX.X..X.X.O",
+" .X..X...X.@O@@@@@@@@.XX.X..XX.O",
+" .XXXXXXXX............XXXXXXXX.O",
+" .X.#O...X.##########.X.#..#OX.O",
+" .XXXXXXXX.##########.XXXXXXXX.O",
+" .X#.O.#.X.##########.X#.O..#X.O",
+" .XXXXXXXX.##########.XXXXXXXX.O",
+" .X.##..OX.##########.X.#.#..X.O",
+" .XXXXXXXXO..........OXXXXXXXX.O",
+" .X.O.#..XXXXXXXXXXXXXXO.#...X.O",
+" .XXXXXXXXXX.#O..#..XXXXXXXXXX.O",
+" .XXXXXXXXXXXXXXXXXXXXXXXXXXXX.O",
+" .............................O",
+" OOOOOOOOOOOOOOOOOOOOOOOOOOOOO"};
--- /dev/null
+/* XPM */
+static char * nocdlpack_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 18 1 0 0",
+/* colors */
+" s none m none c none",
+". c #66668080AAAA",
+"X c #333340405555",
+"o c #999980805555",
+"O c #333360600000",
+"+ c #333360605555",
+"@ s iconColor1 m black c black",
+"# c #9999BFBFFFFF",
+"$ c #CCCCBFBFAAAA",
+"% c #CCCC80805555",
+"& c #CCCC9F9F5555",
+"* s iconColor3 m black c red",
+"= c #CCCC80800000",
+"- c #FFFF80800000",
+"; c #999940405555",
+": c #999960600000",
+"? c #CCCC60600000",
+"> c #999960605555",
+/* pixels */
+" ",
+" ",
+" ..X ",
+" XoXO ",
+" +X@@ ",
+" oX ",
+" +X+#+ ",
+" OX$.$$ ",
+" #.%&*+ ",
+" $$*%=X ",
+" #*%%%$ ",
+" $X=%@$ ",
+" #@@$.$ ",
+" $$$$o$@ ",
+" #.#$.$%%@ ",
+" $@$$@$@%-%=@ ",
+" #$#$#.X+%&%&@ ",
+" @;$.$@o@=%=%=%@ ",
+" @:;+@$X@%&%%%@@ ",
+" @@?;?@O@@%-%=%@.o. ",
+" @&%&>@%&%&%&@... ",
+" o.@%=%=%=@@.o. ",
+" ...@@%%&@... ",
+" o.o.@.o. ",
+" .... ",
+" . "};
--- /dev/null
+/* XPM */
+static char * nocdlpack_open_xpm[] = {
+"24 26 18 1",
+" c #FFFFFFFF0000",
+". c #66668080AAAA",
+"X c #333340405555",
+"o c #999980805555",
+"O c #333360600000",
+"+ c #333360605555",
+"@ c #000000000000",
+"# c #9999BFBFFFFF",
+"$ c #CCCCBFBFAAAA",
+"% c #CCCC80805555",
+"& c #CCCC9F9F5555",
+"* c #FFFF00000000",
+"= c #CCCC80800000",
+"- c #FFFF80800000",
+"; c #999940405555",
+": c #999960600000",
+"? c #CCCC60600000",
+"> c #999960605555",
+" ",
+" ",
+" ..X ",
+" XoXO ",
+" +X@@ ",
+" oX ",
+" +X+#+ ",
+" OX$.$$ ",
+" #.%&*+ ",
+" $$*%=X ",
+" #*%%%$ ",
+" $X=%@$ ",
+" #@@$.$ ",
+" $$$$o$@ ",
+" #.#$.$%%@ ",
+" $@$$@$@%-%=@ ",
+" #$#$#.X+%&%&@ ",
+" @;$.$@o@=%=%=%@ ",
+" @:;+@$X@%&%%%@@ ",
+" @@?;?@O@@%-%=%@.o. ",
+" @&%&>@%&%&%&@... ",
+" o.@%=%=%=@@.o. ",
+" ...@@%%&@... ",
+" o.o.@.o. ",
+" .... ",
+" . "};
--- /dev/null
+/* XPM */
+static char * layout_xpm[] = {
+/* width height ncolors chars_per_pixel */
+"20 22 9 1",
+/* colors */
+" c dark slate grey",
+". s None c None",
+"X c white",
+"o c gold",
+"O c sky blue",
+"+ c black",
+"@ c sienna",
+"# c slate grey",
+"$ c tomato",
+/* pixels */
+" .......",
+" XXXXXXXXXX X ......",
+" XXXXXXXXXX XX .....",
+" XX XX XXX ....",
+" XX ooOOOXX XXXX ...",
+" XX oOOOOXX+ + + +..",
+" XX OOOOOXX+++++++..",
+" XX @@@@@XXXX####+..",
+" XX @@@@@XXXXX###+..",
+" XXXXXXXXXXXXXXX#+..",
+" XXXXXXXXXXXXXXX#+..",
+" XX++++++++++XXX#+..",
+" XXXXXXXXXXXXXXX#+..",
+" XX++++++++++XXX#+..",
+" XXXXXXXXXXXXXXX#+..",
+" XXXX$X++++++XXX#+..",
+" XXXXXXXXXXXXXXX#+..",
+" XXXX$X++++++XXX#+..",
+" XXXXXXXXXXXXXXX#+..",
+" XXXXXXXXXXXXXXX#+..",
+" ############## +..",
+"..++++++++++++++++.."};
--- /dev/null
+/* XPM */
+static char * package_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 24 1 0 0",
+/* colors */
+" s none m none c none",
+". s iconColor1 m black c black",
+"X c #CCCC80805555",
+"o c #CCCC9F9F5555",
+"O c #CCCCBFBFAAAA",
+"+ c #CCCC20200000",
+"@ c #66668080AAAA",
+"# c #CCCC80800000",
+"$ c #9999BFBFFFFF",
+"% c #999980805555",
+"& c #999920205555",
+"* c #CCCC40400000",
+"= c #999960600000",
+"- c #999940405555",
+"; c #CCCC60600000",
+": c #999920200000",
+"? c #999960605555",
+"> c #33339F9F5555",
+", c #333380805555",
+"< c #333360600000",
+"1 c #000040405555",
+"2 c #333360605555",
+"3 c #333340405555",
+"4 c #00008080AAAA",
+/* pixels */
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ....Xo.. ",
+" ..X.O+@#X# ",
+" .$......oX ",
+" .%.#&..+&.X# ",
+" oX.Xo.*&+&*.oX ",
+" ..X#.#&+&+&.X# ",
+" =-=.oX+&*&+.oX ",
+" -;-.X#&+:+&.X#. ",
+" ??=.oX*&+&*.oX>. ",
+" -;-.X#&+&+&.,>,. ",
+" .=-=.oX+&*.>,.. ",
+" ..<-;-.X#&+.,,.@%@ ",
+" .>123..o.>4>.@@@ ",
+" %@.,>32,>..@%@ ",
+" @@@..>,>.@@@ ",
+" %@%@.@%@ ",
+" @@@@ ",
+" @ "};
--- /dev/null
+/* XPM */
+static char * package_open_xpm[] = {
+"24 26 24 1",
+" c #FFFFFFFF0000",
+". c #000000000000",
+"X c #CCCC80805555",
+"o c #CCCC9F9F5555",
+"O c #CCCCBFBFAAAA",
+"+ c #CCCC20200000",
+"@ c #66668080AAAA",
+"# c #CCCC80800000",
+"$ c #9999BFBFFFFF",
+"% c #999980805555",
+"& c #999920205555",
+"* c #CCCC40400000",
+"= c #999960600000",
+"- c #999940405555",
+"; c #CCCC60600000",
+": c #999920200000",
+"? c #999960605555",
+"> c #33339F9F5555",
+", c #333380805555",
+"< c #333360600000",
+"1 c #000040405555",
+"2 c #333360605555",
+"3 c #333340405555",
+"4 c #00008080AAAA",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ....Xo.. ",
+" ..X.O+@#X# ",
+" .$......oX ",
+" .%.#&..+&.X# ",
+" oX.Xo.*&+&*.oX ",
+" ..X#.#&+&+&.X# ",
+" =-=.oX+&*&+.oX ",
+" -;-.X#&+:+&.X#. ",
+" ??=.oX*&+&*.oX>. ",
+" -;-.X#&+&+&.,>,. ",
+" .=-=.oX+&*.>,.. ",
+" ..<-;-.X#&+.,,.@%@ ",
+" .>123..o.>4>.@@@ ",
+" %@.,>32,>..@%@ ",
+" @@@..>,>.@@@ ",
+" %@%@.@%@ ",
+" @@@@ ",
+" @ "};
--- /dev/null
+/* XPM */
+static char * config_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"32 32 9 1 0 0",
+/* colors */
+" s iconGray4 m white c #949494949494",
+". s iconColor1 m black c black",
+"X c #707080809090",
+"o s iconColor2 m white c white",
+"O c #BEBEBEBEBEBE",
+"+ c #FFFFFAFACDCD",
+"@ c #2F2F4F4F4F4F",
+"# s iconColor5 m black c blue",
+"$ c #F5F5DEDEB3B3",
+/* pixels */
+" .......... ",
+" ...XXXXXXXX... ",
+" ..XXXXoXXooOXXXX.. ",
+" .oXXXXXoXXXOoXXXXXo. ",
+" .XOoXXXXoXX++XXXXXXoX. ",
+" .XXXOoXXXoXXoooXXXXoX@@. ",
+" .XXXXXXXXXXXXXXXXXX@o@@@@. ",
+" .oXXXXXXXXX######@@@@@@@@@.. ",
+" .XooXXXXX##########@@@@@@@@. ",
+" .XXXOoXXX###OOOOOO###@@@@@@@+. ",
+" .XXXXXXX##OO......OO##@@@@@+X. ",
+"..XXXXXX##O.........O##.@@@+X@..",
+".XXXXXXX##O..........O##.@@@@@@.",
+".XXXXXX##O...........O##..@@@@@.",
+".XOoOXX##O...$...$...O##...XoX@.",
+".XoXoXX##O....$..$...O##....@o@.",
+".XOooXX##O....$$$$$....#....oX@.",
+".XXXoXX##O.....$$$$$.$......@o@.",
+".XXXoXX@##O....$$.$$.$.....XoX@.",
+".XXXXXX@###O....$.$$$$$.....@@@.",
+"..XXXXX@@###OO.....$$$$....@@@..",
+" .XooX@@@@####OOOO.$$.$$...@@@. ",
+" .oOXX@@@@@#######..$..$..@++@. ",
+" .XXX@@@@@@.#####.....$..@@@. ",
+" ..X@@@@@@@@............@@@.. ",
+" .X@@@o@@@@@.XoX......@@@@. ",
+" .@@oX@@@@@@o......@+@@@. ",
+" .oX@@@@@@@ooX@@@@@X+@.. ",
+" ..@@@@@@@o@o@@@@@@+. ",
+" ..@@@@@@XoX@@@@@.. ",
+" ...@@@@@@@@... ",
+" .......... "};
--- /dev/null
+/* XPM */
+static char * parcel_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 16 1 0 0",
+/* colors */
+" s none m none c none",
+". c #CCCCDFDFFFFF",
+"X c #FFFFDFDFAAAA",
+"o c #CCCCDFDFAAAA",
+"O s iconColor1 m black c black",
+"+ c #333340405555",
+"@ c #333360605555",
+"# c #CCCCBFBFFFFF",
+"$ c #333360600000",
+"% s iconColor7 m white c cyan",
+"& c #000040405555",
+"* c #66668080AAAA",
+"= c #33339F9F5555",
+"- c #333380805555",
+"; c #999980805555",
+": c #00008080AAAA",
+/* pixels */
+" ",
+" ",
+" ",
+" .X ",
+" ...o ",
+" X.X.X.X ",
+" ..X...X.O+@ ",
+" X#X.X#X.O+$% ",
+" ..o...OO@+@%@ ",
+" @+O.XO@+@+@%@+ ",
+" +@+OO@+@+@%@+% ",
+" $+@+$+@+$%@+%+ ",
+" &@+@&@+@%@+%&@ ",
+" @+@+@+@%@+%+@+ ",
+" +@+@+@%@+%+@+@ ",
+" $+@+$%@*%+@+$+ ",
+" &@+@%@*%&*+@&@ = ",
+" @+@+@+%+@+@+O-=- ",
+" +@+@+%+@+@O=- ",
+" $+@+%+@+$O--O*;* ",
+" =:OO@&@O=:=O*** ",
+" ;*O-=-O-=OO*;* ",
+" ***OO=-=O*** ",
+" ;*;*O*;* ",
+" **** ",
+" * "};
--- /dev/null
+/* XPM */
+static char * parcel_open_xpm[] = {
+"24 26 20 1",
+" c #FFFFFFFF0000",
+". c #333340405555",
+"X c #333360605555",
+"o c #333380805555",
+"O c #33339F9F5555",
+"+ c #333360600000",
+"@ c #3333DFDF0000",
+"# c #00008080AAAA",
+"$ c #3333BFBF5555",
+"% c #3333DFDF5555",
+"& c #3333BFBF0000",
+"* c #FFFF9F9F0000",
+"= c #000040405555",
+"- c #FFFFBFBF0000",
+"; c #CCCC9F9F5555",
+": c #CCCC80805555",
+"? c #CCCC80800000",
+"> c #000000000000",
+", c #66668080AAAA",
+"< c #999980805555",
+" ",
+" ",
+" ",
+" ",
+" ",
+" .XoX ",
+" XoOoOoO. ",
+" +oooOoo.@ ",
+" X.O#OoO#X$@$ ",
+" X.OoooX$@$@$X ",
+" .O.OoO$%$@$X$ ",
+" +ooo@$&$@.&$* ",
+" =O.O$%.@$%*-* ",
+" XoOo@.@$@$*** ",
+" .;oO*-***-**$ ",
+" +:?:********@oo> ",
+" =;:;*-*-*-*@$OoO> ",
+" Xo?:@$****@.XoOo> ",
+" .OoO$@$%$XoOo>> ",
+" >>+ooo@$&.+ooo>,<, ",
+" >O#X.O$X.O#O>,,, ",
+" <,>oOoooO>>,<, ",
+" ,,,>>OoO>,,, ",
+" <,<,>,<, ",
+" ,,,, ",
+" , "};
--- /dev/null
+/* XPM */
+static char * patch_xpm[] = {
+/* width height ncolors chars_per_pixel */
+"20 22 7 1",
+/* colors */
+" c dark slate grey",
+". s None c None",
+"X c white",
+"o c black",
+"O c slate grey",
+"+ c firebrick",
+"@ c tomato",
+/* pixels */
+" .......",
+" XXXXXXXXXX X ......",
+" XXXXXXXXXX XX .....",
+" XXXXXXXXXX XXX ....",
+" XXXXXXXXXX XXXX ...",
+" XXXXXXXXXXo o o o..",
+" XXXXXXXXXXooooooo..",
+" XXXXXXXXXXXXOOOOo..",
+" XXXX+X+X+XXXXOOOo..",
+" XX+@+@+@+@+XXXXOo..",
+" XX@@@@@@@@@XXXXOo..",
+" X++@@@@@@@++XXXOo..",
+" XX@@@@@@@@@XXXXOo..",
+" X++@@@@@@@++XXXOo..",
+" XX@@@@@@@@@XXXXOo..",
+" X++@@@@@@@++XXXOo..",
+" XX@@@@@@@@@XXXXOo..",
+" XX+@+@+@+@+XXXXOo..",
+" XXXX+X+X+XXXXXXOo..",
+" XXXXXXXXXXXXXXXOo..",
+" OOOOOOOOOOOOOO o..",
+"..oooooooooooooooo.."};
--- /dev/null
+/* XPM */
+static char * patches_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"32 32 12 1 0 0",
+/* colors */
+" s background m black c #949494949494",
+". c #1E1E9090FFFF",
+"X c #FFFFFAFACDCD",
+"o c #BEBEBEBEBEBE",
+"O c #707080809090",
+"+ s iconColor5 m black c blue",
+"@ c #000000008080",
+"# c #2F2F4F4F4F4F",
+"$ s iconColor1 m black c black",
+"% s iconColor2 m white c white",
+"& c #F5F5DEDEB3B3",
+"* s iconColor3 m black c red",
+/* pixels */
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+" ",
+".....XXXoXXXXXO.. ",
+".++++XOoXO@@@O#+++ ",
+".++++XoXOo@@@O#+++$ ",
+".++++oXOoX@@@O#+++$ ",
+".++++%OoXO@@@O#+++$ ",
+".++++XoXOO@@@O#+++$ ",
+".++++oXOOOOOOO#+++$ ",
+".++++#########@+++$$$$$$ ",
+".+++++++++++++++++$&&&&&$ ",
+".+$$$$$$$$$$$$$$$+$&&&&&&$ ",
+".+$%%%%%%%%%%%%%$+$$&&&&&&$ ",
+".+$%%%%%**%%%%%%$+$$$&&&&&&$ ",
+".+$%%%%%**%%%%%%$+$$$&&&&&&&$$$ ",
+".+$%%%%%**%%%%%%$$$$&&&&&&&&&$$ ",
+".+$%%********%%$&&&&&&&&&&&&&$$ ",
+".+$%%********%%$&&&&&&&&&&&&&$$ ",
+".+$%%%%%**%%%%%$&&&&&&&&&&&&&$$ ",
+".+$%%%%%**%%%%%%$$$$$$$$$$$&&$$ ",
+".+$%%%%%**%%%%%%$+$ $$$$ ",
+".+$%%%%%%%%%%%%%$+$ $$ ",
+"+$$$$$$$$$$$$$$$$$$ ",
+" ",
+" ",
+" ",
+" "};
--- /dev/null
+/* XPM */
+static char * clover_green_xpm[] = {
+/* width height ncolors chars_per_pixel */
+"20 16 3 1",
+/* colors */
+" s None c None",
+". c green",
+"X c sea green",
+/* pixels */
+" ",
+" ",
+" ",
+" ... ",
+" ....X ",
+" ...XX ",
+" .. XXX .. ",
+" ...X X ...X ",
+" ...XX.....X ",
+" X.XX . X.XX ",
+" XX ... XX ",
+" ....X ",
+" X..XX ",
+" XXX ",
+" ",
+" "};
--- /dev/null
+/* XPM */
+static char * persistent_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"16 16 4 1 -1 -1",
+/* colors */
+" s topShadowColor m white c #bdbdbdbdbdbd",
+". s iconGray6 m black c #636363636363",
+"X s bottomShadowColor m black c #636363636363",
+"o s iconColor2 m white c white",
+/* pixels */
+" ",
+" ..............X",
+" ..............X",
+" ..oooooo......X",
+" ..o.....o.....X",
+" ..o.....o.....X",
+" ..o.....o.....X",
+" ..o.....o.....X",
+" ..oooooo......X",
+" ..o...........X",
+" ..o...........X",
+" ..o...........X",
+" ..o...........X",
+" ..............X",
+" ..............X",
+" XXXXXXXXXXXXXXX"};
--- /dev/null
+proc pinstallUsage {} {
+ puts stderr { usage : pinstall parcelname }
+}
+
+proc pinstall {args} {
+
+ set tblreq(-h) {}
+ set param {}
+
+ if { [wokUtils:EASY:GETOPT param table tblreq pinstallUsage $args] == -1 } return
+
+ if { [info exists table(-h)] } {
+ pinstallUsage
+ return
+ }
+
+ set ULNAME [lindex $param 0]
+ if { $ULNAME == {} } {
+ pinstallUsage
+ return
+ }
+
+ set thefact [Sinfo -f]
+ set theware [finfo -W $thefact]
+ puts "Installing $ULNAME from Warehouse ${thefact}:${theware}"
+ wokcd ${thefact}:${theware}
+ wokcd $ULNAME
+ set theullibdir [wokparam -e WOKEntity_libdir ${thefact}:${theware}:${ULNAME}]
+ cd $theullibdir
+ foreach atempld [glob *.ldt] {
+ source $atempld
+ set goodlen [expr [clength $atempld] - 2]
+ set aldfile [crange $atempld 0 $goodlen]
+ set ldfileid [open $aldfile w]
+ puts $ldfileid [WOKDeliv_Makeld $thefact]
+ if {![catch {set esvers [wokparam -e %ENV_EngineStarterVersion]}]} {
+ puts $ldfileid $esvers
+ }
+ close $ldfileid
+ }
+}
--- /dev/null
+/* XPM */
+static char * pqueue_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"32 32 12 1 0 0",
+/* colors */
+" s background m black c #949494949494",
+". s iconColor5 m black c blue",
+"X c #000000008080",
+"o c #2F2F4F4F4F4F",
+"O c #BEBEBEBEBEBE",
+"+ s iconColor2 m white c white",
+"@ c #707080809090",
+"# s iconColor3 m black c red",
+"$ s iconColor1 m black c black",
+"% c #FFFFFAFACDCD",
+"& c #A0A052522D2D",
+"* c #FFFFA5A50000",
+/* pixels */
+" . . . . . ",
+" ..X ..X ..X ..X ..X ",
+" o...XX..XX..XX..XX..X ",
+" oOO...XX..XX..XX..XX..X ",
+" oOXOO...XX..XX..XX..XX..X ",
+" oOOOXO..+.XXO.XXO.XXO.XXO.X ",
+" ..OOOO..+++.X@O.X@O.X@O.X@O.X ",
+"....OO..+++++.X@O.X@O.X@O.X@O.X ",
+" X.....+##+++X@OOX@OOX@OOX@OOX ",
+" X...++##++X@OOX@OOX@OOX@OOX ",
+" X.++++++X@OOX@OOX@OOX@OOX ",
+" X.++++X@OOX@OOX@OOX@OOX ",
+" X.++XXOOXXOOXXOOXXOOX ",
+" X.X $.X $.X $.X $.X ",
+" X X X X X ",
+"$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$",
+" @%%%OOOOOOOO@@@@oooooooo$$$$$$ ",
+" $$$$$$$$$$$$$$$$$$$$$$$$$$$$ ",
+" &**&*&*& &*& ",
+" &*&*&*& &*& ",
+" &*&*&**& &*& ",
+" &&**&***& &&&*& ",
+" &***&***&&*&&*& ",
+" &&**&****&*&*& ",
+" &&*******&**& ",
+" &&******&*& ",
+" &&******& ",
+" &****& ",
+" &****& ",
+" o$$$$$$$ ",
+" o$$$$$$$ ",
+" o$$$$$$$ "};
--- /dev/null
+/* XPM */
+static char * prepare_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"32 32 12 1 0 0",
+/* colors */
+" s iconGray4 m white c #949494949494",
+". s iconColor1 m black c black",
+"X c #FFFFFAFACDCD",
+"o c #D2D2B4B48C8C",
+"O c #2F2F4F4F4F4F",
+"+ c #707080809090",
+"@ c #BEBEBEBEBEBE",
+"# c #DCDCDCDCDCDC",
+"$ s iconColor2 m white c white",
+"% c #A0A052522D2D",
+"& c #1E1E9090FFFF",
+"* c #8787CECEEBEB",
+/* pixels */
+" ",
+" ........ ",
+" .XXXXXX.. ",
+" .XXXXXX.o. ",
+" .XXXXXX.oo. ",
+" .XXXXXX.ooo. ",
+" .XXXXXX...... ",
+" .XXXXXXXoooo. ",
+" .OXOXOXOXOXO. ",
+" +@@#$$$$$#@@++OO. ",
+" O++@@##$#@@+++OO... ",
+" .++@@##$#@@+++OO... ",
+" .OO++@@@++OO..... ",
+" ++@@#$#@@++OO.. ",
+" ++@@#$#@@++OO..+ ",
+" ++@@#$#@@++OO..O.... ",
+" ++@@#$#@@++OO... . ",
+" ++@@#$#@@++OO.. . ",
+" +@@#$$$$$#@@++OO. . %% ",
+" O++@@##$#@@++OOO... ..%% ",
+" .OOOOOOOOOOOOOOO... .. ",
+" ................. ",
+" .+.+..O.++++. ",
+" .&&&&&&&&&&&. ",
+" .***O*OO@++*. ",
+" .***********. ",
+" .***+*O+OO**. ",
+" .***********. ",
+" .*****O*OO+*. ",
+" .***********. ",
+" ............. ",
+" "};
--- /dev/null
+/* XPM */
+static char * private_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"16 16 5 1 0 0",
+/* colors */
+" s topShadowColor m white c #bdbdbdbdbdbd",
+". s iconGray6 m black c #636363636363",
+"X s bottomShadowColor m black c #636363636363",
+"o s iconColor2 m white c white",
+"O s iconColor3 m black c red",
+/* pixels */
+" ",
+" ..............X",
+" .....ooooo....X",
+" ....oOOOOOo...X",
+" ...oOOOOOOOo..X",
+" ..oOOOOOOOOOo.X",
+" .oOOOOOOOOOOOoX",
+" .oOoooooooooOoX",
+" .oOoooooooooOoX",
+" .oOoooooooooOoX",
+" .oOOOOOOOOOOOoX",
+" ..oOOOOOOOOOo.X",
+" ...oOOOOOOOo..X",
+" ....oOOOOOo...X",
+" .....ooooo....X",
+" XXXXXXXXXXXXXXX"};
--- /dev/null
+proc ptypefile_usage { } {
+ puts stderr \
+ {
+ Usage: ptypefile -[hwt] [-S ao1,sil,sun,hp,wnt] <Parcelname>
+
+ Context:
+ The command must be runned from a workbnech belonging to a workshop which contains
+ the given parcel in its ParcelList
+
+ ptypefile -h displays this text
+
+ ptypefile -w <Parcelname>
+ displays on the standard output the non kept type files.
+
+ ptypefile <Parcelname>
+ generates a type file in the adm directory of the parcel for ALL UNIX PLATFORMS
+
+ ptypefile -S ao1,sil <ParcelName>
+ generates a type file in the adm directory of the parcel ONLY for the given platforms
+
+ ptypefile -S wnt <ParcelName>
+ generates a type file in the adm directory of the parcel ONLY for wnt platform
+
+ ptypefile -t <Parcelname>
+ generates a type file in the adm directory where the package libraries contained in a toolkit
+ are removed from the type file.
+
+ 3 files are generated:
+ parcel.typ contains pairs of file type, relative path which will be taken into account
+ during packaging.
+ parcel.unktyp file warns the UNKNOWN types i.e. not taken into account
+ parcel.notyp warns all the files that will be removed while packaging the parcel for Quantum
+ }
+}
+proc ptypefile { args } {
+ ;# Options
+ ;#
+ set tblreq(-h) {}
+ set tblreq(-w) {}
+ set tblreq(-t) {}
+ set tblreq(-S) value_required:list
+ ;# Parameters
+ ;#
+ set param {}
+ if {[wokUtils:EASY:GETOPT param table tblreq ptypefile_usage $args] == -1 } return
+ ;#
+ if { [info exists table(-h)] } {
+ ptypefile_usage
+ return
+ }
+ set warn 0
+ if { [info exists table(-w)] } {
+ set warn 1
+ }
+ if { [info exists table(-t)] } {
+ set tkpriority 1
+ msgprint -w "SORRY NOT YET IMPLEMENTED ...."
+ return
+ }
+ set statlist { ao1 hp sil sun }
+ if { [info exists table(-S)] } {
+ set statlist $table(-S)
+ }
+ set parc [lindex $param 0]
+ if { $parc == "" } {
+ ptypefile_usage
+ return
+ }
+ set parcname [wokinfo -n $parc]
+ # sauvons la plateforme en cours
+ set curstation [wokparam -v %Station]
+ ;# sauvons
+ catch {exec cp "[wokparam -v %${parcname}_Adm]/${parcname}.typ" "[wokparam -v %${parcname}_Adm]/${parcname}.typ-sav"}
+ set typfile [open "[wokparam -v %${parcname}_Adm]/$parcname.typ" w+]
+ set notypfile [open "[wokparam -v %${parcname}_Adm]/$parcname.notyp" w+]
+ set unktypfile [open "[wokparam -v %${parcname}_Adm]/$parcname.unktyp" w+]
+ # Traitons d'abord les fichiers non plateformes dependants
+ # les uds de l'ul
+ ;# catch {
+ foreach ud [ pinfo -l $parc] {
+ set lstwokfilecom "[uinfo -Fi $parc:$ud ] [uinfo -Fb $parc:$ud ] "
+ puts " UD $ud "
+ foreach wokfile $lstwokfilecom {
+ switch -exact [lindex $wokfile 0] {
+ EXTERNLIB -
+ admfile -
+ ccldrv -
+ dbadmfile -
+ demofile -
+ derivated -
+ dummy -
+ infofile -
+ intdat -
+ object -
+ pubinclude -
+ source -
+ srcinc -
+ stadmfile -
+ sttmpdir -
+ testobject {typnotkept $warn $wokfile $notypfile }
+ cclcfg -
+ cclrun -
+ corelisp -
+ dbunit -
+ 'default' -
+ engdatfile -
+ engine -
+ englisp -
+ englispfile -
+ executable -
+ icon -
+ iconfd -
+ loginfile -
+ motifdefault -
+ msentity -
+ msgfile -
+ shapefile -
+ shellcfg -
+ shellscript -
+ template -
+ testexec { typkept $wokfile $parcname $ud $typfile }
+ datafile { typdatafile $warn $wokfile $parcname $ud $typfile $notypfile }
+ default { typunknown $wokfile $unktypfile}
+ }
+ }
+ foreach worksta $statlist {
+ wokprofile -S $worksta
+ set lstwokfilesta [uinfo -Fs $parc:$ud ]
+ foreach wokfile $lstwokfilesta {
+ switch -exact [lindex $wokfile 0] {
+ EXTERNLIB -
+ admfile -
+ ccldrv -
+ dbadmfile -
+ demofile -
+ derivated -
+ dummy -
+ infofile -
+ intdat -
+ object -
+ pubinclude -
+ source -
+ srcinc -
+ stadmfile -
+ sttmpdir -
+ testobject { typnotkept $warn $wokfile $notypfile }
+ cclcfg -
+ cclrun -
+ corelisp -
+ dbunit -
+ 'default' -
+ engdatfile -
+ engine -
+ englisp -
+ englispfile -
+ executable -
+ icon -
+ iconfd -
+ motifdefault -
+ msentity -
+ msgfile -
+ shapefile -
+ shellcfg -
+ shellscript -
+ template -
+ testexec { typkept $wokfile $parcname $ud $typfile }
+ library { typlibrary $warn $wokfile $parcname $ud $typfile $notypfile }
+ datafile { typdatafile $warn $wokfile $parcname $ud $typfile $notypfile }
+ loginfile { typloginfile $warn $wokfile $parcname $ud $typfile $notypfile }
+ default { typunknown $wokfile $unktypfile }
+ }
+ }
+ }
+ }
+ ;# }
+ close $typfile
+ close $unktypfile
+ close $notypfile
+ ;# on remet la station
+ wokprofile -S $curstation
+}
+;#
+proc typkept { wokfile parcname ud typfile } {
+ puts $typfile "[lindex $wokfile 0] [string range [wokinfo -p [lindex $wokfile 0]:[lindex $wokfile 1] ${parcname}:${ud}] [expr [string length [wokparam -v %${parcname}_Home]] + 1] end]"
+}
+proc typnotkept { warn wokfile notypfile } {
+ if { $warn } { msgprint -w "TYPE $wokfile NOT KEPT" }
+ puts $notypfile "TYPE $wokfile NOT KEPT"
+}
+proc typunknown { wokfile unktypfile } {
+ msgprint -e "TYPE $wokfile UNKNOWN "
+ puts $unktypfile "TYPE $wokfile UNKNOWN"
+}
+
+proc typlibrary { warn wokfile parcname ud typfile notypfile } {
+ ;# rajouter pktklist et tkpriority apres
+ if {[file extension [lindex $wokfile 1]] == ".Z"} {
+ typnotkept $warn $wokfile $notypfile
+ } else {
+ typkept $wokfile $parcname $ud $typfile
+ }
+}
+proc typdatafile { warn wokfile parcname ud typfile notypfile} {
+ if {[file extension [lindex $wokfile 1]] == ".ilm"} {
+ typnotkept $warn $wokfile $notypfile
+ } else {
+ typkept $wokfile $parcname $ud $typfile
+ }
+}
+proc typloginfile { warn wokfile parcname ud typfile notypfile } {
+ if {[file extension [lindex $wokfile 1]] == ".edl"} {
+ typnotkept $warn $wokfile $notypfile
+ } else {
+ typkept $wokfile $parcname $ud $typfile
+ }
+}
+
--- /dev/null
+/* XPM */
+static char * queue_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"19 19 6 1 0 0",
+/* colors */
+" s none m none c none",
+". s iconColor1 m black c black",
+"X c #33339F9F5555",
+"o c #333380805555",
+"O c #00008080AAAA",
+"+ s iconColor2 m white c white",
+/* pixels */
+" ",
+" .... ",
+" .XoX........ ",
+" .ooXoooXoooXo.",
+" .oXOXoXOXoXOX.",
+" ..XoooXoooXooo.",
+" .XoXoXoXoXoXoX.",
+" .oooXoooXoooXo.",
+" .XoXOXoXOXoXO..",
+" .ooXoooXoooXoo..",
+" .oXoXoXoXoXoXo..",
+" ..oooXoooXooo.. ",
+" .........OXo... ",
+" ++++++++....... ",
+" ......++++++.. ",
+" +++++......... ",
+" ....++++++++.. ",
+" +++........+. ",
+" +++++++++. "};
--- /dev/null
+/* XPM */
+static char * reposit_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"19 19 5 1 0 0",
+/* colors */
+" s none m none c none",
+". s iconColor1 m black c black",
+"X c #66668080AAAA",
+"o c #999980805555",
+"O s iconColor2 m white c white",
+/* pixels */
+" ",
+" ..XoXoXoXoXoXoX.. ",
+" .XXXXXXXXXXXXXXX. ",
+" ................. ",
+" ..XXXXXXXXXXXXX.. ",
+" ..XoXoXoXoXoXoX.. ",
+" ..XXXX.OOOOXXXX.. ",
+" ..XoXo.OOOOoXoX.. ",
+" ..XXXXXXXXXXXXX.. ",
+" ..XoXo.....oXoX.. ",
+" ..XXXXXXXXXXXXX.. ",
+" ..XoXoXo.oXoXoX.. ",
+" ..XXXXXXXXXXXXX.. ",
+" ................. ",
+" .XXXXXXXXXXXXXXX. ",
+" ..XoXoXoXoXoXoX.. ",
+" ..XXXXXXXXXXXXX.. ",
+" ..XoXo.....oXoX.. ",
+" "};
--- /dev/null
+/* XPM */
+static char * resource_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 26 1 0 0",
+/* colors */
+" s none m none c none",
+". s iconColor1 m black c black",
+"X s iconColor3 m black c red",
+"o c #33338080FFFF",
+"O c #33339F9FFFFF",
+"+ c #00008080FFFF",
+"@ c #00009F9FFFFF",
+"# c #CCCCBFBFAAAA",
+"$ c #9999BFBFFFFF",
+"% c #FFFFBFBF0000",
+"& c #FFFF9F9F0000",
+"* c #3333BFBF5555",
+"= c #3333DFDF0000",
+"- c #3333BFBF0000",
+"; c #66668080AAAA",
+": c #333360605555",
+"? c #CCCC80805555",
+"> c #FFFF80800000",
+", c #CCCC9F9F5555",
+"< c #999940405555",
+"1 c #CCCC60600000",
+"2 c #999960600000",
+"3 c #999960605555",
+"4 c #333340405555",
+"5 c #CCCC80800000",
+"6 c #999980805555",
+/* pixels */
+" ",
+" ",
+" ",
+" .XX. .oO. ",
+" .XXXX.. .+O@O. ",
+" .XXXXX#X.oO+OoO. ",
+" .XXX$#$X.O+O$O+. ",
+" ....XXX#.+OoO##.. ",
+" ..XX.%&..O@#.%$ ",
+" .*=*...&##&&&&&&# ",
+" ..*=*.&.&&$..#$#& ",
+" ....-*=.&+O..#.. ",
+" ...*=*.@#+O.. ",
+" .*##.+Oo##.;. ",
+" .X....+O$.XXXXX. ",
+" .XXXXXXX:?>XXXXXXX ",
+" .XXXXXX#?,<..XXX$#. ",
+" .XXXXXX#1<2..XXX##. ",
+" .XXXXX.<232.XXX. ",
+" .4..#..?5<1<5.#.6; ",
+" .,<,.,?,?,?,.;;; ",
+" 6;.?5?5?5..;6; ",
+" ;;;..??,.;;; ",
+" 6;6;.;6; ",
+" ;;;; ",
+" ; "};
--- /dev/null
+/* XPM */
+static char * resource_open_xpm[] = {
+"24 26 26 1",
+" c #FFFFFFFF0000",
+". c #000000000000",
+"X c #FFFF00000000",
+"o c #33338080FFFF",
+"O c #33339F9FFFFF",
+"+ c #00008080FFFF",
+"@ c #00009F9FFFFF",
+"# c #CCCCBFBFAAAA",
+"$ c #9999BFBFFFFF",
+"% c #FFFFBFBF0000",
+"& c #FFFF9F9F0000",
+"* c #3333BFBF5555",
+"= c #3333DFDF0000",
+"- c #3333BFBF0000",
+"; c #66668080AAAA",
+": c #333360605555",
+"? c #CCCC80805555",
+"> c #FFFF80800000",
+", c #CCCC9F9F5555",
+"< c #999940405555",
+"1 c #CCCC60600000",
+"2 c #999960600000",
+"3 c #999960605555",
+"4 c #333340405555",
+"5 c #CCCC80800000",
+"6 c #999980805555",
+" ",
+" ",
+" ",
+" .XX. .oO. ",
+" .XXXX.. .+O@O. ",
+" .XXXXX#X.oO+OoO. ",
+" .XXX$#$X.O+O$O+. ",
+" ....XXX#.+OoO##.. ",
+" ..XX.%&..O@#.%$ ",
+" .*=*...&##&&&&&&# ",
+" ..*=*.&.&&$..#$#& ",
+" ....-*=.&+O..#.. ",
+" ...*=*.@#+O.. ",
+" .*##.+Oo##.;. ",
+" .X....+O$.XXXXX. ",
+" .XXXXXXX:?>XXXXXXX ",
+" .XXXXXX#?,<..XXX$#. ",
+" .XXXXXX#1<2..XXX##. ",
+" .XXXXX.<232.XXX. ",
+" .4..#..?5<1<5.#.6; ",
+" .,<,.,?,?,?,.;;; ",
+" 6;.?5?5?5..;6; ",
+" ;;;..??,.;;; ",
+" 6;6;.;6; ",
+" ;;;; ",
+" ; "};
--- /dev/null
+/* XPM */
+static char *cycle_xpm[] = {
+/* width height ncolors chars_per_pixel */
+"32 32 4 1",
+/* colors */
+"` c black",
+"a c red",
+"b c white",
+"c c blue",
+/* pixels */
+"bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb",
+"bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb",
+"bbbbbbbbbbbb````````bbbbbbbbbbbb",
+"bbbbbbbbb```aaaaaaaa```bbbbbbbbb",
+"bbbbbbbb`aaaaaaaaaaaaaa`bbbbbbbb",
+"bbbbbb``aaaaaaaaaaaaaaaa``bbbbbb",
+"b```b`aaaaaaaaaaaaaaaaaaaa`bbbbb",
+"b`aa`aaaaaaaaaaaaaaaaaaaaaa`bbbb",
+"b`aaa`aaaaaaaaaaaaaaaaaaaaaa`bbb",
+"b`aaaaaaaaaaa``````aaaaaaaaa`bbb",
+"b`baaaaaaaa``bbbbbb``aaaaaaaa`bb",
+"b`baaaaaa``bbbbbbbbbb`aaaaaaa`bb",
+"b`baaaaaaaa`bbbbbbbbb`aaaaaaaa`b",
+"b`baaaaaaaaa`bbbbbbbbb`aaaaaaa`b",
+"b`cbaaaaaaa`bbbbbbbbbb`aaabbaa`b",
+"b`cbaaaab`bbbbbbbbbbbb`abbccba`b",
+"b`ccaabbc`bbbbbbbbbbb`bbccccba`b",
+"b`ccbbccc`bbbbbbbbbb`cccccccba`b",
+"b`ccccccc`bbbbbbbbb`cccccccccb`b",
+"b`cccccccc`bbbbbbbbb`ccccccccb`b",
+"bb`ccccccc`bbbbbbbbbb``ccccccc`b",
+"bb`cccccccc``bbbbbb``ccccccccc`b",
+"bbb`ccccccccc``````cccccccc`cc`b",
+"bbb`cccccccccccccccccccccccc`c`b",
+"bbbb`cccccccccccccccccccccc`b``b",
+"bbbbb`cccccccccccccccccccc`bbbbb",
+"bbbbbb``cccccccccccccccc``bbbbbb",
+"bbbbbbbb`cccccccccccccc``bbbbbbb",
+"bbbbbbbbb```cccccccc````bbbbbbbb",
+"bbbbbbbbbbbb````````bbbbbbbbbbbb",
+"bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb",
+"bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
+};
--- /dev/null
+
+
+
+proc scheck { } {
+
+
+ set errorCount 0
+ set warnCount 0
+
+ set shop [wokinfo -s]
+ set warehouse "[wokinfo -f]:[finfo -W]"
+
+ msgprint -c "scheck" -i "Checking BAG installation"
+
+ set parcellist [Winfo -p $warehouse]
+ set parcelconfig [sinfo -p $shop]
+
+
+ msgprint -c "scheck" -i "++ Checking for parcel aggregates"
+
+ foreach parcel $parcellist {
+
+ set parcelfile [wokinfo -p admfile:$parcel.edl $warehouse]
+
+ if { [file exists $parcelfile ] } {
+
+ set phome [wokparam -e %${parcel}_Home]
+
+ if { [file exists $phome] } {
+
+ if { ! [info exists phomes($phome)] } {
+ set phomes($phome) $parcel
+ } else {
+ lappend phomes($phome) $parcel
+ }
+ set delivery [pinfo -d ${warehouse}:$parcel]
+ set allrequisites($parcel) [wokparam -e %${delivery}_AllRequisites ${warehouse}:$parcel]
+ } else {
+ msgprint -c "scheck" -e "Wrong parcel declaration for $parcel ($phome does not exist)"
+ incr errorCount
+ }
+ } else {
+ msgprint -c "scheck" -e "No definition file for $parcel ($parcelfile does not exists)"
+ incr errorCount
+ }
+
+ }
+
+ set noagg 1
+ foreach aggregate [array names phomes] {
+ if { [llength $phomes($aggregate) ] > 1 } {
+ msgprint -c "scheck" -i "+++ Found aggregate : $aggregate containing $phomes($aggregate)"
+ set agregates($aggregate) $phomes($aggregate)
+ set noagg 0
+ }
+ }
+ if $noagg {
+ msgprint -c "scheck" -i "+++ No aggregate parcels found"
+ }
+ msgprint -c "scheck" -i "++"
+ msgprint -c "scheck" -i "++ Checking $shop configuration"
+ msgprint -c "scheck" -i "++"
+
+ set conflicts ""
+
+ msgprint -c "scheck" -i "+++ Checking $shop agregates usage"
+ msgprint -c "scheck" -i "+++"
+
+ foreach parcel $parcelconfig {
+ foreach agregate [array names agregates] {
+ if { [lsearch -exact $agregates($agregate) $parcel] >= 0 } {
+ if [info exists usedagregates($agregate)] {
+ lappend usedagregates($agregate) $parcel
+ } else {
+ set usedagregates($agregate) $parcel
+ }
+ }
+ }
+ }
+
+ foreach used [array names usedagregates] {
+ msgprint -c "scheck" -i "++++ $used for $usedagregates($used)"
+ }
+
+ msgprint -c "scheck" -i "+++"
+ msgprint -c "scheck" -i "+++ Checking used parcels requisites"
+ msgprint -c "scheck" -i "+++"
+
+ foreach parcel $parcelconfig {
+
+ foreach requisite [lindex $allrequisites($parcel) 0] {
+ if { [lsearch -exact $parcelconfig $requisite] == -1 } {
+ msgprint -c "scheck" -e "$requisite used for $parcel is not in $shop configuration"
+ incr errorCount
+ }
+ }
+ }
+
+ msgprint -c "scheck" -i "+++"
+ msgprint -c "scheck" -i "+++ Checking accurate agregates usage"
+ msgprint -c "scheck" -i "+++"
+
+ foreach parcel $parcelconfig {
+ foreach agregate [array names agregates] {
+ if { [lsearch -exact $agregates($agregate) $parcel] >= 0 } {
+ foreach aggparcel $agregates($agregate) {
+ if { [lsearch -exact $parcelconfig $aggparcel] == -1 } {
+ if { [lsearch -exact $conflicts $aggparcel] == -1 } {
+ lappend conflicts $aggparcel
+ msgprint -c "scheck" -e "$aggparcel (in $agregate) should be in configuration of workshop $shop"
+ incr errorCount
+ }
+ }
+ }
+ }
+ }
+ }
+
+
+ msgprint -c "scheck" -i "+++"
+ msgprint -c "scheck" -i "+++ Checking accurate configuration namings"
+ msgprint -c "scheck" -i "+++"
+
+ foreach parcel $parcelconfig {
+ scan $parcel "%\[^-\]-%s" name extension
+ lappend configs($extension) $name
+ }
+
+
+ if { [llength [array names configs]] > 1 } {
+
+ msgprint -c "scheck" -w "More than one configuration extensions are currently in use :"
+
+ foreach extension [array names configs] {
+ msgprint -c "scheck" -w " $extension used for parcels : $configs($extension)"
+ incr warnCount
+ }
+
+ } else {
+ msgprint -c "scheck" -i "++++ $extension is the current and only configuration used"
+ }
+
+ if { $errorCount || $warnCount } {
+ msgprint -c "scheck" -e "$errorCount errors and $warnCount warnings were found in $shop installation and configuration"
+ msgprint -c "scheck" -e "Please remedy"
+ } else {
+ msgprint -c "scheck" -i "No installation or configuration errors was found"
+ }
+}
--- /dev/null
+/* XPM */
+static char * schema_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 11 1 0 0",
+/* colors */
+" s none m none c none",
+". s iconColor1 m black c black",
+"X c #FFFFDFDF0000",
+"o c #FFFFBFBF0000",
+"O s iconColor3 m black c red",
+"+ s iconColor2 m white c white",
+"@ c #33339F9F5555",
+"# c #333380805555",
+"$ c #00008080AAAA",
+"% c #66668080AAAA",
+"& c #999980805555",
+/* pixels */
+" ",
+" . ",
+" .XX. ",
+" .oXoX ",
+" XX.XX. ",
+" Xo.O.o ",
+" .XX.OOXX. ",
+" .XoOOOoX. ",
+" .XXOOO.XX. ",
+" oX.OOO+.oX ",
+" XX.OOO++.X. ",
+" .o.+OOO+++Xo. ",
+" .X.+OO.+++.XX ",
+" .o.+OO.+.++oX. ",
+" .XX++.O.@#@..XX ",
+" .Xo++..@###.oXo ",
+" XX...#@$...XXX.. ",
+" oX.##@OO.XoX.@#. ",
+" .XX@#@.O.X..#.. ",
+" ...oX#..X.X.##.%&% ",
+" .@XX.XXXX.$@.%%% ",
+" &%XoXo..@..%&% ",
+" %%XXX.#@.%%% ",
+" &%&%.%&% ",
+" %%%% ",
+" % "};
--- /dev/null
+/* XPM */
+static char * schema_open_xpm[] = {
+"24 26 11 1",
+" c #FFFFFFFF0000",
+". c #000000000000",
+"X c #FFFFDFDF0000",
+"o c #FFFFBFBF0000",
+"O c #FFFF00000000",
+"+ c #FFFFFFFFFFFF",
+"@ c #33339F9F5555",
+"# c #333380805555",
+"$ c #00008080AAAA",
+"% c #66668080AAAA",
+"& c #999980805555",
+" ",
+" . ",
+" .XX. ",
+" .oXoX ",
+" XX.XX. ",
+" Xo.O.o ",
+" .XX.OOXX. ",
+" .XoOOOoX. ",
+" .XXOOO.XX. ",
+" oX.OOO+.oX ",
+" XX.OOO++.X. ",
+" .o.+OOO+++Xo. ",
+" .X.+OO.+++.XX ",
+" .o.+OO.+.++oX. ",
+" .XX++.O.@#@..XX ",
+" .Xo++..@###.oXo ",
+" XX...#@$...XXX.. ",
+" oX.##@OO.XoX.@#. ",
+" .XX@#@.O.X..#.. ",
+" ...oX#..X.X.##.%&% ",
+" .@XX.XXXX.$@.%%% ",
+" &%XoXo..@..%&% ",
+" %%XXX.#@.%%% ",
+" &%&%.%&% ",
+" %%%% ",
+" % "};
--- /dev/null
+/* XPM */
+static char * small_xpm[] = {
+"19 19 14 1",
+" c #9999BFBFFFFF",
+". c #CCCCBFBFAAAA",
+"X c #000000000000",
+"o c #66668080AAAA",
+"O c #00000000FFFF",
+"+ c #CCCCDFDFAAAA",
+"@ c #CCCCDFDFFFFF",
+"# c #FFFFDFDFAAAA",
+"$ c #FFFFFFFFFFFF",
+"% c #33338080FFFF",
+"& c #9999DFDFFFFF",
+"* c #6666BFBFFFFF",
+"= c #9999DFDFAAAA",
+"- c #999980805555",
+" . . . . . . . . . ",
+"...................",
+" . . . . . . . . . ",
+".............XXXXXX",
+" . . . . . XXXXXXX ",
+".......XXXXXXX.....",
+" . . XXXXXXXoooooo ",
+"....XXXXXXOOOOOOOO.",
+" .XXXXO+@XXXXXXXXX ",
+"...O#XXXXXXXXXXXXXX",
+" . O@XXXXXXXXXXXXXX",
+"..OXX.XXXXX$X%X$$@X",
+" OX.XX@$X&*X*&X$$XX",
+"..XXX.$$$*= &*$$$XX",
+" X X $X$$$*&*$$$XX ",
+"..XX$o-o-o-o-o-o-..",
+" .X.X. . . . . . . ",
+"...................",
+" . . . . . . . . . "};
--- /dev/null
+/* XPM */
+static char * see_closed_xpm[] = {
+"19 19 15 1",
+" c #000000005555",
+". c #9999BFBFFFFF",
+"X c #CCCCBFBFAAAA",
+"o c #000000000000",
+"O c #999980805555",
+"+ c #66668080AAAA",
+"@ c #FFFFFFFFFFFF",
+"# c #6666BFBFFFFF",
+"$ c #9999DFDFFFFF",
+"% c #9999DFDFAAAA",
+"& c #CCCCDFDFFFFF",
+"* c #00000000FFFF",
+"= c #33338080FFFF",
+"- c #FFFFDFDFAAAA",
+"; c #CCCCDFDFAAAA",
+" ",
+" .X.X.X.X.X.X.X.X.X",
+" XXXXXXXXXXXXXXXXXX",
+" .X.X.X.X.X.X.XoXoX",
+" XXO+O+O+O+O+O+@ooX",
+" .oo@@@#$#@@@o@.o.o",
+" oo@@@#$.%#@@@XoooX",
+" oo@@o$#o#$o@&ooXo*",
+" o&@@o=o@oooooXoo*X",
+" oooooooooooooo&*.X",
+" oooooooooooooo-*XX",
+" .ooooooooo&;*ooooX",
+" X********ooooooXXX",
+" .++++++ooooooo.X.X",
+" XXXXXoooooooXXXXXX",
+" .ooooooo.X.X.X.X.X",
+" ooooooXXXXXXXXXXXX",
+" .X.X.X.X.X.X.X.X.X",
+" XXXXXXXXXXXXXXXXXX"};
--- /dev/null
+/* XPM */
+static char * server_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 21 1 0 0",
+/* colors */
+" s none m none c none",
+". s iconColor1 m black c black",
+"X c #999920200000",
+"o c #CCCC40400000",
+"O c #999920205555",
+"+ c #00008080FFFF",
+"@ s iconColor2 m white c white",
+"# c #CCCC20200000",
+"$ c #FFFFDFDF0000",
+"% c #333380805555",
+"& c #33339F9F5555",
+"* c #33339F9FFFFF",
+"= c #CCCC80805555",
+"- c #FFFF80800000",
+"; c #CCCC80800000",
+": c #CCCC9F9F5555",
+"? c #33338080FFFF",
+"> s iconColor7 m white c cyan",
+", c #999940405555",
+"< c #66668080AAAA",
+"1 c #999980805555",
+/* pixels */
+" ",
+" ",
+" ",
+" ..X ",
+" oO. . ",
+" . .+.@@.#O. ",
+" $$. . .+. ",
+" .. .%. . ",
+" ..$ .@@.$$. ",
+" .. .%.&%. . ",
+" .*.o..@.%. ",
+" . .@.@..$.#. ",
+" $$. .$.@..O. ",
+" ..$ ..#.@.#O. ",
+" ..$ .+.$.%..&.*+ ",
+" ..$ .@@.=-=;=.=;. ",
+" $$. .@..=:=:=:=:=:. ",
+" *?.%.O.+.=;>>=#=;=. ",
+" ...&.:===o,==.. ",
+" ..-%%.-=;=#,;=.<1< ",
+" .:=:=:=:=:=:.<<< ",
+" 1<.=;=;=;..<1< ",
+" <<<..==:.<<< ",
+" 1<1<.<1< ",
+" <<<< ",
+" < "};
--- /dev/null
+/* XPM */
+static char * server_open_xpm[] = {
+"24 26 26 1",
+" c #FFFFFFFF0000",
+". c #000000000000",
+"X c #FFFF00000000",
+"o c #33338080FFFF",
+"O c #33339F9FFFFF",
+"+ c #00008080FFFF",
+"@ c #00009F9FFFFF",
+"# c #CCCCBFBFAAAA",
+"$ c #9999BFBFFFFF",
+"% c #FFFFBFBF0000",
+"& c #FFFF9F9F0000",
+"* c #3333BFBF5555",
+"= c #3333DFDF0000",
+"- c #3333BFBF0000",
+"; c #66668080AAAA",
+": c #333360605555",
+"? c #CCCC80805555",
+"> c #FFFF80800000",
+", c #CCCC9F9F5555",
+"< c #999940405555",
+"1 c #CCCC60600000",
+"2 c #999960600000",
+"3 c #999960605555",
+"4 c #333340405555",
+"5 c #CCCC80800000",
+"6 c #999980805555",
+" ",
+" ",
+" ",
+" .XX. .oO. ",
+" .XXXX.. .+O@O. ",
+" .XXXXX#X.oO+OoO. ",
+" .XXX$#$X.O+O$O+. ",
+" ....XXX#.+OoO##.. ",
+" ..XX.%&..O@#.%$ ",
+" .*=*...&##&&&&&&# ",
+" ..*=*.&.&&$..#$#& ",
+" ....-*=.&+O..#.. ",
+" ...*=*.@#+O.. ",
+" .*##.+Oo##.;. ",
+" .X....+O$.XXXXX. ",
+" .XXXXXXX:?>XXXXXXX ",
+" .XXXXXX#?,<..XXX$#. ",
+" .XXXXXX#1<2..XXX##. ",
+" .XXXXX.<232.XXX. ",
+" .4..#..?5<1<5.#.6; ",
+" .,<,.,?,?,?,.;;; ",
+" 6;.?5?5?5..;6; ",
+" ;;;..??,.;;; ",
+" 6;6;.;6; ",
+" ;;;; ",
+" ; "};
--- /dev/null
+/* XPM */
+static char * b_green_xpm[] = {
+/* width height ncolors chars_per_pixel */
+"14 14 7 1",
+/* colors */
+" s None c None",
+". c black",
+"X c pale green",
+"o c lime green",
+"O c white",
+"+ c sea green",
+"@ c dark slate grey",
+/* pixels */
+" ",
+" .... ",
+" .XXXo. ",
+" .XOXoo+. ",
+" .XXOXXoo+. ",
+" .oXoXo+++. ",
+" .XoXooo+@. ",
+" .oooo+++@. ",
+" .oo+o++@@. ",
+" .++++@@. ",
+" .+@@@. ",
+" .... ",
+" ",
+" "};
--- /dev/null
+/* XPM */
+static char * storable_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"16 16 4 1 -1 -1",
+/* colors */
+" s topShadowColor m white c #bdbdbdbdbdbd",
+". s iconGray6 m black c #636363636363",
+"X s bottomShadowColor m black c #636363636363",
+"o s iconColor2 m white c white",
+/* pixels */
+" ",
+" ..............X",
+" ..............X",
+" ....ooooooo...X",
+" ...o..........X",
+" ...o..........X",
+" ...o..........X",
+" ...o..........X",
+" ....oooooo....X",
+" ..........o...X",
+" ..........o...X",
+" ..........o...X",
+" ..........o...X",
+" ...ooooooo....X",
+" ..............X",
+" XXXXXXXXXXXXXXX"};
--- /dev/null
+#
+# arrayprocs.tcl --
+#
+# Extended Tcl array procedures.
+#
+#------------------------------------------------------------------------------
+# Copyright 1992-1996 Karl Lehenbauer and Mark Diekhans.
+#
+# Permission to use, copy, modify, and distribute this software and its
+# documentation for any purpose and without fee is hereby granted, provided
+# that the above copyright notice appear in all copies. Karl Lehenbauer and
+# Mark Diekhans make no representations about the suitability of this
+# software for any purpose. It is provided "as is" without express or
+# implied warranty.
+#------------------------------------------------------------------------------
+# $Id: tclx.nt,v 1.1 1998-09-09 18:21:14 kernel Exp $
+#------------------------------------------------------------------------------
+#
+
+#@package: TclX-ArrayProcedures for_array_keys
+
+proc for_array_keys {varName arrayName codeFragment} {
+ upvar $varName enumVar $arrayName enumArray
+
+ if ![info exists enumArray] {
+ error "\"$arrayName\" isn't an array"
+ }
+
+ set code 0
+ set result {}
+ set searchId [array startsearch enumArray]
+ while {[array anymore enumArray $searchId]} {
+ set enumVar [array nextelement enumArray $searchId]
+ set code [catch {uplevel 1 $codeFragment} result]
+ if {$code != 0 && $code != 4} break
+ }
+ array donesearch enumArray $searchId
+
+ if {$code == 0 || $code == 3 || $code == 4} {
+ return $result
+ }
+ if {$code == 1} {
+ global errorCode errorInfo
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo $result
+ }
+ return -code $code $result
+}
+#
+# compat --
+#
+# This file provides commands compatible with older versions of Extended Tcl.
+#
+#------------------------------------------------------------------------------
+# Copyright 1992-1996 Karl Lehenbauer and Mark Diekhans.
+#
+# Permission to use, copy, modify, and distribute this software and its
+# documentation for any purpose and without fee is hereby granted, provided
+# that the above copyright notice appear in all copies. Karl Lehenbauer and
+# Mark Diekhans make no representations about the suitability of this
+# software for any purpose. It is provided "as is" without express or
+# implied warranty.
+#------------------------------------------------------------------------------
+# $Id: tclx.nt,v 1.1 1998-09-09 18:21:14 kernel Exp $
+#------------------------------------------------------------------------------
+#
+
+#@package: TclX-GenCompat assign_fields cexpand
+
+proc assign_fields {list args} {
+ puts stderr {**** Your program is using an obsolete TclX proc, "assign_fields".}
+ puts stderr {**** Please use the command "lassign". Compatibility support will}
+ puts stderr {**** be removed in the next release.}
+
+ proc assign_fields {list args} {
+ if [lempty $args] {
+ return
+ }
+ return [uplevel lassign [list $list] $args]
+ }
+ return [uplevel assign_fields [list $list] $args]
+}
+
+# Added TclX 7.4a
+proc cexpand str {subst -nocommands -novariables $str}
+
+#@package: TclX-ServerCompat server_open server_connect server_send \
+ server_info server_cntl
+
+# Added TclX 7.4a
+
+proc server_open args {
+ set cmd server_connect
+
+ set buffered 1
+ while {[string match -* [lindex $args 0]]} {
+ set opt [lvarpop args]
+ if [cequal $opt -buf] {
+ set buffered 1
+ } elseif [cequal $opt -nobuf] {
+ set buffered 0
+ }
+ lappend cmd $opt
+ }
+ set handle [uplevel [concat $cmd $args]]
+ if $buffered {
+ lappend handle [dup $handle]
+ }
+ return $handle
+}
+
+# Added TclX 7.5a
+
+proc server_connect args {
+ set cmd socket
+
+ set buffered 1
+ set twoids 0
+ while {[string match -* [lindex $args 0]]} {
+ switch -- [set opt [lvarpop args]] {
+ -buf {
+ set buffered 1
+ }
+ -nobuf {
+ set buffered 0
+ }
+ -myip {
+ lappend cmd -myaddr [lvarpop args]
+ }
+ -myport {
+ lappend cmd -myport [lvarpop args]
+ }
+ -twoids {
+ set twoids 1
+ }
+ default {
+ error "unknown option \"$opt\""
+ }
+ }
+ }
+ set handle [uplevel [concat $cmd $args]]
+ if !$buffered {
+ fconfigure $handle -buffering none
+ }
+ if $twoids {
+ lappend handle [dup $handle]
+ }
+ return $handle
+}
+
+proc server_send args {
+ set cmd puts
+
+ while {[string match -* [lindex $args 0]]} {
+ switch -- [set opt [lvarpop args]] {
+ {-dontroute} {
+ error "server_send if obsolete, -dontroute is not supported by the compatibility proc"
+ }
+ {-outofband} {
+ error "server_send if obsolete, -outofband is not supported by the compatibility proc"
+ }
+ }
+ lappend cmd $opt
+ }
+ uplevel [concat $cmd $args]
+ flush [lindex $args 0]
+}
+
+proc server_info args {
+ eval [concat host_info $args]
+}
+
+proc server_cntl args {
+ eval [concat fcntl $args]
+}
+
+#@package: TclX-ClockCompat fmtclock convertclock getclock
+
+# Added TclX 7.5a
+
+proc fmtclock {clockval {format {}} {zone {}}} {
+ lappend cmd clock format $clockval
+ if ![lempty $format] {
+ lappend cmd -format $format
+ }
+ if ![lempty $zone] {
+ lappend cmd -gmt 1
+ }
+ return [eval $cmd]
+}
+
+# Added TclX 7.5a
+
+proc convertclock {dateString {zone {}} {baseClock {}}} {
+ lappend cmd clock scan $dateString
+ if ![lempty $zone] {
+ lappend cmd -gmt 1
+ }
+ if ![lempty $baseClock] {
+ lappend cmd -base $baseClock
+ }
+ return [eval $cmd]
+}
+
+# Added TclX 7.5a
+
+proc getclock {} {
+ return [clock seconds]
+}
+
+#@package: TclX-FileCompat mkdir rmdir unlink frename
+
+# Added TclX 7.6.0
+
+proc mkdir args {
+ set path 0
+ if {[llength $args] > 1} {
+ lvarpop args
+ set path 1
+ }
+ foreach dir [lindex $args 0] {
+ if {((!$path) && [file isdirectory $dir]) || \
+ ([file exists $dir] && ![file isdirectory $dir])} {
+ error "creating directory \"$dir\" failed: file already exists" \
+ {} {POSIX EEXIST {file already exists}}
+ }
+ file mkdir $dir
+ }
+ return
+}
+
+# Added TclX 7.6.0
+
+proc rmdir args {
+ set nocomplain 0
+ if {[llength $args] > 1} {
+ lvarpop args
+ set nocomplain 1
+ global errorInfo errorCode
+ set saveErrorInfo $errorInfo
+ set saveErrorCode $errorCode
+ }
+ foreach dir [lindex $args 0] {
+ if $nocomplain {
+ catch {file delete $dir}
+ } else {
+ if ![file exists $dir] {
+ error "can't remove \"$dir\": no such file or directory" {} \
+ {POSIX ENOENT {no such file or directory}}
+ }
+ if ![cequal [file type $dir] directory] {
+ error "$dir: not a directory" {} \
+ {POSIX ENOTDIR {not a directory}}
+ }
+ file delete $dir
+ }
+ }
+ if $nocomplain {
+ set errorInfo $saveErrorInfo
+ set errorCode $saveErrorCode
+ }
+ return
+}
+
+# Added TclX 7.6.0
+
+proc unlink args {
+ set nocomplain 0
+ if {[llength $args] > 1} {
+ lvarpop args
+ set nocomplain 1
+ global errorInfo errorCode
+ set saveErrorInfo $errorInfo
+ set saveErrorCode $errorCode
+ }
+ foreach file [lindex $args 0] {
+ if {[file exists $file] &&[cequal [file type $file] directory]} {
+ if !$nocomplain {
+ error "$file: not owner" {} {POSIX EPERM {not owner}}
+ }
+ } elseif $nocomplain {
+ catch {file delete $file}
+ } else {
+ if ![file exists $file] {
+ error "can't remove \"$file\": no such file or directory" {} \
+ {POSIX ENOENT {no such file or directory}}
+ }
+ file delete $file
+ }
+ }
+ if $nocomplain {
+ set errorInfo $saveErrorInfo
+ set errorCode $saveErrorCode
+ }
+ return
+}
+
+# Added TclX 7.6.0
+
+proc frename {old new} {
+ if {[file isdirectory $new] && ![lempty [readdir $new]]} {
+ error "rename \"foo\" to \"baz\" failed: directory not empty" {} \
+ POSIX ENOTEMPTY {directory not empty}
+ }
+ file rename $old $new
+}
+
+#
+# convlib.tcl --
+#
+# Convert Ousterhout style tclIndex files and associated libraries to a
+# package library.
+#
+#------------------------------------------------------------------------------
+# Copyright 1992-1996 Karl Lehenbauer and Mark Diekhans.
+#
+# Permission to use, copy, modify, and distribute this software and its
+# documentation for any purpose and without fee is hereby granted, provided
+# that the above copyright notice appear in all copies. Karl Lehenbauer and
+# Mark Diekhans make no representations about the suitability of this
+# software for any purpose. It is provided "as is" without express or
+# implied warranty.
+#------------------------------------------------------------------------------
+# $Id: tclx.nt,v 1.1 1998-09-09 18:21:14 kernel Exp $
+#------------------------------------------------------------------------------
+#
+
+#@package: TclX-convertlib convert_lib
+
+#------------------------------------------------------------------------------
+# tclx:ParseTclIndex
+# Parse a tclIndex file, returning an array of file names with the list of
+# procedures in each package. This is done by sourcing the file and then
+# going through the local auto_index array that was created. Issues warnings
+# for lines that can't be converted. tclIndex should be an absolute path
+# name. Returns 1 if all lines are converted, 0 if some failed.
+#
+
+proc tclx:ParseTclIndex {tclIndex fileTblVar ignore} {
+ upvar $fileTblVar fileTbl
+ set allOK 1
+
+ # Open and validate the file.
+
+ set tclIndexFH [open $tclIndex r]
+ set hdr [gets $tclIndexFH]
+ if {!(($hdr == {# Tcl autoload index file, version 2.0}) ||
+ ($hdr == {# Tcl autoload index file, version 2.0 for [incr Tcl]}))} {
+ error "can only convert version 2.0 Tcl auto-load files"
+ }
+ set dir [file dirname $tclIndex] ;# Expected by the script.
+ eval [read $tclIndexFH]
+ close $tclIndexFH
+
+ foreach procName [array names auto_index] {
+ if ![string match "source *" $auto_index($procName)] {
+ puts stderr "WARNING: Can't convert load command for \"$procName\": $auto_index($procName)"
+ set allOK 0
+ continue
+ }
+ set filePath [lindex $auto_index($procName) 1]
+ set fileName [file tail $filePath]
+ if {[lsearch $ignore $fileName] >= 0} continue
+
+ lappend fileTbl($filePath) $procName
+ }
+ if ![info exists fileTbl] {
+ error "no entries could be converted in $tclIndex"
+ }
+ return $allOK
+}
+
+#------------------------------------------------------------------------------
+# convert_lib:
+# Convert a tclIndex library to a .tlib. ignore any files in the ignore
+# list
+
+proc convert_lib {tclIndex packageLib {ignore {}}} {
+ global tclx_library
+ source $tclx_library/buildidx.tcl
+
+ if {[file tail $tclIndex] != "tclIndex"} {
+ error "Tail file name must be `tclIndex': $tclIndex"}
+ if ![file readable $tclIndex] {
+ error "File not readable: $tclIndex"
+ }
+
+ # Expand to root relative file name.
+
+ set tclIndex [glob $tclIndex]
+ if ![string match "/*" $tclIndex] {
+ set tclIndex "[pwd]/$tclIndex"
+ }
+
+ # Parse the file.
+
+ set allOK [tclx:ParseTclIndex $tclIndex fileTbl $ignore]
+
+ # Generate the .tlib package names with contain the directory and
+ # file name, less any extensions.
+
+ if {[file extension $packageLib] != ".tlib"} {
+ append packageLib ".tlib"
+ }
+ set libFH [open $packageLib w]
+
+ foreach srcFile [array names fileTbl] {
+ set pkgName [file tail [file dirname $srcFile]]/[file tail [file root $srcFile]]
+ set srcFH [open $srcFile r]
+ puts $libFH "#@package: $pkgName $fileTbl($srcFile)\n"
+ copyfile $srcFH $libFH
+ close $srcFH
+ }
+ close $libFH
+ buildpackageindex $packageLib
+ if !$allOK {
+ error "*** Not all entries converted, but library generated"
+ }
+}
+#
+# edprocs.tcl --
+#
+# Tools for Tcl developers. Procedures to save procs to a file and to edit
+# a proc in memory.
+#------------------------------------------------------------------------------
+# Copyright 1992-1996 Karl Lehenbauer and Mark Diekhans.
+#
+# Permission to use, copy, modify, and distribute this software and its
+# documentation for any purpose and without fee is hereby granted, provided
+# that the above copyright notice appear in all copies. Karl Lehenbauer and
+# Mark Diekhans make no representations about the suitability of this
+# software for any purpose. It is provided "as is" without express or
+# implied warranty.
+#------------------------------------------------------------------------------
+# $Id: tclx.nt,v 1.1 1998-09-09 18:21:14 kernel Exp $
+#------------------------------------------------------------------------------
+#
+
+#@package: TclX-developer_utils saveprocs edprocs
+
+proc saveprocs {fileName args} {
+ set fp [open $fileName w]
+ puts $fp "# tcl procs saved on [fmtclock [getclock]]\n"
+ puts $fp [eval "showproc $args"]
+ close $fp
+}
+
+proc edprocs {args} {
+ global env
+
+ set tmpFilename /tmp/tcldev.[id process]
+
+ set fp [open $tmpFilename w]
+ puts $fp "\n# TEMP EDIT BUFFER -- YOUR CHANGES ARE FOR THIS SESSION ONLY\n"
+ puts $fp [eval "showproc $args"]
+ close $fp
+
+ if [info exists env(EDITOR)] {
+ set editor $env(EDITOR)
+ } else {
+ set editor vi
+ }
+
+ set startMtime [file mtime $tmpFilename]
+ system "$editor $tmpFilename"
+
+ if {[file mtime $tmpFilename] != $startMtime} {
+ source $tmpFilename
+ echo "Procedures were reloaded."
+ } else {
+ echo "No changes were made."
+ }
+ unlink $tmpFilename
+ return
+}
+#
+# eventloop.tcl --
+#
+# Eventloop procedure.
+#------------------------------------------------------------------------------
+# Copyright 1992-1996 Karl Lehenbauer and Mark Diekhans.
+#
+# Permission to use, copy, modify, and distribute this software and its
+# documentation for any purpose and without fee is hereby granted, provided
+# that the above copyright notice appear in all copies. Karl Lehenbauer and
+# Mark Diekhans make no representations about the suitability of this
+# software for any purpose. It is provided "as is" without express or
+# implied warranty.
+#------------------------------------------------------------------------------
+# $Id: tclx.nt,v 1.1 1998-09-09 18:21:14 kernel Exp $
+#------------------------------------------------------------------------------
+#
+
+#@package: TclX-events mainloop
+
+proc mainloop {} {
+ global tcl_interactive
+
+ if {[info exists tcl_interactive] && $tcl_interactive} {
+ commandloop -async -interactive on -endcommand exit
+ }
+ set loopVar 0
+ catch {vwait loopVar}
+ exit
+}
+#
+# forfile.tcl --
+#
+# Proc to execute code on every line of a file.
+#------------------------------------------------------------------------------
+# Copyright 1992-1996 Karl Lehenbauer and Mark Diekhans.
+#
+# Permission to use, copy, modify, and distribute this software and its
+# documentation for any purpose and without fee is hereby granted, provided
+# that the above copyright notice appear in all copies. Karl Lehenbauer and
+# Mark Diekhans make no representations about the suitability of this
+# software for any purpose. It is provided "as is" without express or
+# implied warranty.
+#------------------------------------------------------------------------------
+# $Id: tclx.nt,v 1.1 1998-09-09 18:21:14 kernel Exp $
+#------------------------------------------------------------------------------
+#
+
+#@package: TclX-forfile for_file
+
+proc for_file {var filename cmd} {
+ upvar $var line
+ set fp [open $filename r]
+ set code 0
+ set result {}
+ while {[gets $fp line] >= 0} {
+ set code [catch {uplevel 1 $cmd} result]
+ if {$code != 0 && $code != 4} break
+ }
+ close $fp
+
+ if {$code == 0 || $code == 3 || $code == 4} {
+ return $result
+ }
+ if {$code == 1} {
+ global errorCode errorInfo
+ return -code $code -errorcode $errorCode -errorinfo $errorInfo $result
+ }
+ return -code $code $result
+}
+#
+# globrecur.tcl --
+#
+# Build or process a directory list recursively.
+#------------------------------------------------------------------------------
+# Copyright 1992-1996 Karl Lehenbauer and Mark Diekhans.
+#
+# Permission to use, copy, modify, and distribute this software and its
+# documentation for any purpose and without fee is hereby granted, provided
+# that the above copyright notice appear in all copies. Karl Lehenbauer and
+# Mark Diekhans make no representations about the suitability of this
+# software for any purpose. It is provided "as is" without express or
+# implied warranty.
+#------------------------------------------------------------------------------
+# $Id: tclx.nt,v 1.1 1998-09-09 18:21:14 kernel Exp $
+#------------------------------------------------------------------------------
+#
+
+#@package: TclX-globrecur recursive_glob
+
+proc recursive_glob {dirlist globlist} {
+ set result {}
+ set recurse {}
+ foreach dir $dirlist {
+ if ![file isdirectory $dir] {
+ error "\"$dir\" is not a directory"
+ }
+ foreach pattern $globlist {
+ set result [concat $result \
+ [glob -nocomplain -- [file join $dir $pattern]]]
+ }
+ foreach file [readdir $dir] {
+ set file [file join $dir $file]
+ if [file isdirectory $file] {
+ set fileTail [file tail $file]
+ if {!(($fileTail == ".") || ($fileTail == ".."))} {
+ lappend recurse $file
+ }
+ }
+ }
+ }
+ if ![lempty $recurse] {
+ set result [concat $result [recursive_glob $recurse $globlist]]
+ }
+ return $result
+}
+
+#@package: TclX-forrecur for_recursive_glob
+
+proc for_recursive_glob {var dirlist globlist cmd {depth 1}} {
+ upvar $depth $var myVar
+ set recurse {}
+ foreach dir $dirlist {
+ if ![file isdirectory $dir] {
+ error "\"$dir\" is not a directory"
+ }
+ set code 0
+ set result {}
+ foreach pattern $globlist {
+ foreach file [glob -nocomplain -- [file join $dir $pattern]] {
+ set myVar $file
+ set code [catch {uplevel $depth $cmd} result]
+ if {$code != 0 && $code != 4} break
+ }
+ if {$code != 0 && $code != 4} break
+ }
+ if {$code != 0 && $code != 4} {
+ if {$code == 3} {
+ return $result
+ }
+ if {$code == 1} {
+ global errorCode errorInfo
+ return -code $code -errorcode $errorCode \
+ -errorinfo $errorInfo $result
+ }
+ return -code $code $result
+ }
+
+ foreach file [readdir $dir] {
+ set file [file join $dir $file]
+ if [file isdirectory $file] {
+ set fileTail [file tail $file]
+ if {!(($fileTail == ".") || ($fileTail == ".."))} {
+ lappend recurse $file
+ }
+ }
+ }
+ }
+ if ![lempty $recurse] {
+ return [for_recursive_glob $var $recurse $globlist $cmd \
+ [expr {$depth + 1}]]
+ }
+ return {}
+}
+#
+# help.tcl --
+#
+# Tcl help command. (see TclX manual)
+#
+#------------------------------------------------------------------------------
+# Copyright 1992-1996 Karl Lehenbauer and Mark Diekhans.
+#
+# Permission to use, copy, modify, and distribute this software and its
+# documentation for any purpose and without fee is hereby granted, provided
+# that the above copyright notice appear in all copies. Karl Lehenbauer and
+# Mark Diekhans make no representations about the suitability of this
+# software for any purpose. It is provided "as is" without express or
+# implied warranty.
+#------------------------------------------------------------------------------
+# The help facility is based on a hierarchical tree of subjects (directories)
+# and help pages (files). There is a virtual root to this tree. The root
+# being the merger of all "help" directories found along the $auto_path
+# variable.
+#------------------------------------------------------------------------------
+# $Id: tclx.nt,v 1.1 1998-09-09 18:21:14 kernel Exp $
+#------------------------------------------------------------------------------
+#
+
+#@package: TclX-help help helpcd helppwd apropos
+
+#------------------------------------------------------------------------------
+# Return a list of help root directories.
+
+proc help:RootDirs {} {
+ global auto_path
+ set roots {}
+ foreach dir $auto_path {
+ if [file isdirectory $dir/help] {
+ lappend roots $dir/help
+ }
+ }
+ return $roots
+}
+
+#------------------------------------------------------------------------------
+# Take a path name which might have "." and ".." elements and flatten them out.
+# Also removes trailing and adjacent "/", unless its the only character.
+
+proc help:FlattenPath pathName {
+ set newPath {}
+ foreach element [split $pathName /] {
+ if {"$element" == "." || [lempty $element]} continue
+
+ if {"$element" == ".."} {
+ if {[llength [join $newPath /]] == 0} {
+ error "Help: name goes above subject directory root" {} \
+ [list TCLXHELP NAMEABOVEROOT $pathName]
+ }
+ lvarpop newPath [expr [llength $newPath]-1]
+ continue
+ }
+ lappend newPath $element
+ }
+ set newPath [join $newPath /]
+
+ # Take care of the case where we started with something line "/" or "/."
+
+ if {("$newPath" == "") && [string match "/*" $pathName]} {
+ set newPath "/"
+ }
+
+ return $newPath
+}
+
+#------------------------------------------------------------------------------
+# Given a pathName relative to the virtual help root, convert it to a list of
+# real file paths. A list is returned because the path could be "/", returning
+# a list of all roots. The list is returned in the same order of the auto_path
+# variable. If path does not start with a "/", it is take as relative to the
+# current help subject. Note: The root directory part of the name is not
+# flattened. This lets other commands pick out the part relative to the
+# one of the root directories.
+
+proc help:ConvertPath pathName {
+ global TCLXENV
+
+ if {![string match "/*" $pathName]} {
+ if {"$TCLXENV(help:curSubject)" == "/"} {
+ set pathName "/$pathName"
+ } else {
+ set pathName "$TCLXENV(help:curSubject)/$pathName"
+ }
+ }
+ set pathName [help:FlattenPath $pathName]
+
+ # If the virtual root is specified, return a list of directories.
+
+ if {$pathName == "/"} {
+ return [help:RootDirs]
+ }
+
+ # Not the virtual root find the first match.
+
+ foreach dir [help:RootDirs] {
+ if [file readable $dir/$pathName] {
+ return [list $dir/$pathName]
+ }
+ }
+ error "\"$pathName\" does not exist" {} \
+ [list TCLXHELP NOEXIST $pathName]
+}
+
+#------------------------------------------------------------------------------
+# Return the virtual root relative name of the file given its absolute path.
+# The root part of the path should not have been flattened, as we would not
+# be able to match it.
+
+proc help:RelativePath pathName {
+ foreach dir [help:RootDirs] {
+ if {[csubstr $pathName 0 [clength $dir]] == $dir} {
+ set name [csubstr $pathName [clength $dir] end]
+ if {$name == ""} {set name /}
+ return $name
+ }
+ }
+ if ![info exists found] {
+ error "problem translating \"$pathName\"" {} [list TCLXHELP INTERROR]
+ }
+}
+
+#------------------------------------------------------------------------------
+# Given a list of path names to subjects generated by ConvertPath, return
+# the contents of the subjects. Two lists are returned, subjects under that
+# subject and a list of pages under the subject. Both lists are returned
+# sorted. This merges all the roots into a virtual root. pathName is the
+# string that was passed to ConvertPath and is used for error reporting.
+# *.brk files are not returned.
+
+proc help:ListSubject {pathName pathList subjectsVar pagesVar} {
+ upvar $subjectsVar subjects $pagesVar pages
+
+ set subjects {}
+ set pages {}
+ set foundDir 0
+ foreach dir $pathList {
+ if ![file isdirectory $dir] continue
+ set foundDir 1
+ foreach file [glob -nocomplain $dir/*] {
+ if [string match *.brf $file] continue
+ if [file isdirectory $file] {
+ lappend subjects [file tail $file]/
+ } else {
+ lappend pages [file tail $file]
+ }
+ }
+ }
+ if !$foundDir {
+ if [cequal $pathName /] {
+ global auto_path
+ error "no \"help\" directories found on auto_path ($auto_path)" {} \
+ [list TCLXHELP NOHELPDIRS]
+ } else {
+ error "\"$pathName\" is not a subject" {} \
+ [list TCLXHELP NOTSUBJECT $pathName]
+ }
+ }
+ set subjects [lsort $subjects]
+ set pages [lsort $pages]
+ return {}
+}
+
+#------------------------------------------------------------------------------
+# Display a line of output, pausing waiting for input before displaying if the
+# screen size has been reached. Return 1 if output is to continue, return
+# 0 if no more should be outputed, indicated by input other than return.
+#
+
+proc help:Display line {
+ global TCLXENV
+ if {$TCLXENV(help:lineCnt) >= 23} {
+ set TCLXENV(help:lineCnt) 0
+ puts -nonewline stdout ":"
+ flush stdout
+ gets stdin response
+ if {![lempty $response]} {
+ return 0}
+ }
+ puts stdout $line
+ incr TCLXENV(help:lineCnt)
+}
+
+#------------------------------------------------------------------------------
+# Display a help page (file).
+
+proc help:DisplayPage filePath {
+
+ set inFH [open $filePath r]
+ while {[gets $inFH fileBuf] >= 0} {
+ if {![help:Display $fileBuf]} {
+ break}
+ }
+ close $inFH
+}
+
+#------------------------------------------------------------------------------
+# Display a list of file names in a column format. This use columns of 14
+# characters 3 blanks.
+
+proc help:DisplayColumns {nameList} {
+ set count 0
+ set outLine ""
+ foreach name $nameList {
+ if {$count == 0} {
+ append outLine " "}
+ append outLine $name
+ if {[incr count] < 4} {
+ set padLen [expr 17-[clength $name]]
+ if {$padLen < 3} {
+ set padLen 3}
+ append outLine [replicate " " $padLen]
+ } else {
+ if {![help:Display $outLine]} {
+ return}
+ set outLine ""
+ set count 0
+ }
+ }
+ if {$count != 0} {
+ help:Display [string trimright $outLine]}
+ return
+}
+
+#------------------------------------------------------------------------------
+# Display help on help, the first occurance of a help page called "help" in
+# the help root.
+
+proc help:HelpOnHelp {} {
+ set helpPage [lindex [help:ConvertPath /help] 0]
+ if [lempty $helpPage] {
+ error "No help page on help found" {} \
+ [list TCLXHELP NOHELPPAGE]
+ }
+ help:DisplayPage $helpPage
+}
+
+#------------------------------------------------------------------------------
+# Help command.
+
+proc help {{what {}}} {
+ global TCLXENV
+
+ set TCLXENV(help:lineCnt) 0
+
+ # Special case "help help", so we can get it at any level.
+
+ if {($what == "help") || ($what == "?")} {
+ help:HelpOnHelp
+ return
+ }
+
+ set pathList [help:ConvertPath $what]
+ if [file isfile [lindex $pathList 0]] {
+ help:DisplayPage [lindex $pathList 0]
+ return
+ }
+
+ help:ListSubject $what $pathList subjects pages
+ set relativeDir [help:RelativePath [lindex $pathList 0]]
+
+ if {[llength $subjects] != 0} {
+ help:Display "\nSubjects available in $relativeDir:"
+ help:DisplayColumns $subjects
+ }
+ if {[llength $pages] != 0} {
+ help:Display "\nHelp pages available in $relativeDir:"
+ help:DisplayColumns $pages
+ }
+}
+
+
+#------------------------------------------------------------------------------
+# helpcd command. The name of the new current directory is assembled from the
+# current directory and the argument.
+
+proc helpcd {{dir /}} {
+ global TCLXENV
+
+ set pathName [lindex [help:ConvertPath $dir] 0]
+
+ if {![file isdirectory $pathName]} {
+ error "\"$dir\" is not a subject" \
+ [list TCLXHELP NOTSUBJECT $dir]
+ }
+
+ set TCLXENV(help:curSubject) [help:RelativePath $pathName]
+ return
+}
+
+#------------------------------------------------------------------------------
+# Helpcd main.
+
+proc helppwd {} {
+ global TCLXENV
+ echo "Current help subject: $TCLXENV(help:curSubject)"
+}
+
+#------------------------------------------------------------------------------
+# apropos command. This search the
+
+proc apropos {regexp} {
+ global TCLXENV
+
+ set TCLXENV(help:lineCnt) 0
+
+ set ch [scancontext create]
+ scanmatch -nocase $ch $regexp {
+ set path [lindex $matchInfo(line) 0]
+ set desc [lrange $matchInfo(line) 1 end]
+ if {![help:Display [format "%s - %s" $path $desc]]} {
+ set stop 1
+ return}
+ }
+ set stop 0
+ foreach dir [help:RootDirs] {
+ foreach brief [glob -nocomplain $dir/*.brf] {
+ set briefFH [open $brief]
+ scanfile $ch $briefFH
+ close $briefFH
+ if $stop break
+ }
+ if $stop break
+ }
+ scancontext delete $ch
+}
+
+#------------------------------------------------------------------------------
+# One time initialization done when the file is sourced.
+#
+global TCLXENV
+
+set TCLXENV(help:curSubject) "/"
+#
+# profrep --
+#
+# Generate Tcl profiling reports.
+#------------------------------------------------------------------------------
+# Copyright 1992-1996 Karl Lehenbauer and Mark Diekhans.
+#
+# Permission to use, copy, modify, and distribute this software and its
+# documentation for any purpose and without fee is hereby granted, provided
+# that the above copyright notice appear in all copies. Karl Lehenbauer and
+# Mark Diekhans make no representations about the suitability of this
+# software for any purpose. It is provided "as is" without express or
+# implied warranty.
+#------------------------------------------------------------------------------
+# $Id: tclx.nt,v 1.1 1998-09-09 18:21:14 kernel Exp $
+#------------------------------------------------------------------------------
+#
+
+#@package: TclX-profrep profrep
+
+#
+# Convert the profile array from entries that have only the time spent in
+# the proc to the time spend in the proc and all it calls.
+#
+proc profrep:sum {inDataVar outDataVar} {
+ upvar 1 $inDataVar inData $outDataVar outData
+
+ foreach inStack [array names inData] {
+ for {set idx 0} {![lempty [set part [lrange $inStack $idx end]]]} \
+ {incr idx} {
+ if ![info exists outData($part)] {
+ set outData($part) {0 0 0}
+ }
+ lassign $outData($part) count real cpu
+ if {$idx == 0} {
+ incr count [lindex $inData($inStack) 0]
+ }
+ incr real [lindex $inData($inStack) 1]
+ incr cpu [lindex $inData($inStack) 2]
+ set outData($part) [list $count $real $cpu]
+ }
+ }
+}
+
+#
+# Do sort comparison. May only be called by profrep:sort, as it address its
+# local variables.
+#
+proc profrep:sortcmp {key1 key2} {
+ upvar profData profData keyIndex keyIndex
+
+ set val1 [lindex $profData($key1) $keyIndex]
+ set val2 [lindex $profData($key2) $keyIndex]
+
+ if {$val1 < $val2} {
+ return -1
+ }
+ if {$val1 > $val2} {
+ return 1
+ }
+ return 0
+}
+
+#
+# Generate a list, sorted in descending order by the specified key, contain
+# the indices into the summarized data.
+#
+proc profrep:sort {profDataVar sortKey} {
+ upvar $profDataVar profData
+
+ case $sortKey {
+ {calls} {set keyIndex 0}
+ {real} {set keyIndex 1}
+ {cpu} {set keyIndex 2}
+ default {
+ error "Expected a sort type of: `calls', `cpu' or ` real'"
+ }
+ }
+
+ return [lsort -integer -decreasing -command profrep:sortcmp \
+ [array names profData]]
+}
+
+#
+# Print the sorted report
+#
+proc profrep:print {profDataVar sortedProcList outFile userTitle} {
+ upvar $profDataVar profData
+
+ set maxNameLen 0
+ foreach procStack [array names profData] {
+ foreach procName $procStack {
+ set maxNameLen [max $maxNameLen [clength $procName]]
+ }
+ }
+
+ if {$outFile == ""} {
+ set outFH stdout
+ } else {
+ set outFH [open $outFile w]
+ }
+
+ # Output a header.
+
+ set stackTitle "Procedure Call Stack"
+ set maxNameLen [max [expr $maxNameLen+6] [expr [clength $stackTitle]+4]]
+ set hdr [format "%-${maxNameLen}s %10s %10s %10s" $stackTitle \
+ "Calls" "Real Time" "CPU Time"]
+ if {$userTitle != ""} {
+ puts $outFH [replicate - [clength $hdr]]
+ puts $outFH $userTitle
+ }
+ puts $outFH [replicate - [clength $hdr]]
+ puts $outFH $hdr
+ puts $outFH [replicate - [clength $hdr]]
+
+ # Output the data in sorted order.
+
+ foreach procStack $sortedProcList {
+ set data $profData($procStack)
+ puts $outFH [format "%-${maxNameLen}s %10d %10d %10d" \
+ [lvarpop procStack] \
+ [lindex $data 0] [lindex $data 1] [lindex $data 2]]
+ foreach procName $procStack {
+ if {$procName == "<global>"} break
+ puts $outFH " $procName"
+ }
+ }
+ if {$outFile != ""} {
+ close $outFH
+ }
+}
+
+#------------------------------------------------------------------------------
+# Generate a report from data collect from the profile command.
+# o profDataVar (I) - The name of the array containing the data from profile.
+# o sortKey (I) - Value to sort by. One of "calls", "cpu" or "real".
+# o outFile (I) - Name of file to write the report to. If omitted, stdout
+# is assumed.
+# o userTitle (I) - Title line to add to output.
+
+proc profrep {profDataVar sortKey {outFile {}} {userTitle {}}} {
+ upvar $profDataVar profData
+
+ profrep:sum profData sumProfData
+ set sortedProcList [profrep:sort sumProfData $sortKey]
+ profrep:print sumProfData $sortedProcList $outFile $userTitle
+
+}
+#
+# pushd.tcl --
+#
+# C-shell style directory stack procs.
+#
+#------------------------------------------------------------------------------
+# Copyright 1992-1996 Karl Lehenbauer and Mark Diekhans.
+#
+# Permission to use, copy, modify, and distribute this software and its
+# documentation for any purpose and without fee is hereby granted, provided
+# that the above copyright notice appear in all copies. Karl Lehenbauer and
+# Mark Diekhans make no representations about the suitability of this
+# software for any purpose. It is provided "as is" without express or
+# implied warranty.
+#------------------------------------------------------------------------------
+# $Id: tclx.nt,v 1.1 1998-09-09 18:21:14 kernel Exp $
+#------------------------------------------------------------------------------
+#
+
+#@package: TclX-directory_stack pushd popd dirs
+
+global TCLXENV(dirPushList)
+
+set TCLXENV(dirPushList) ""
+
+proc pushd {{new ""}} {
+ global TCLXENV
+
+ set current [pwd]
+ if {[clength $new] > 0} {
+ set dirs [glob -nocomplain $new]
+ set count [llength $dirs]
+ if {$count == 0} {
+ error "no such directory: $new"
+ } elseif {$count != 1} {
+ error "ambiguous directory: $new: [join $directories ", "]"
+ }
+ cd [lindex $dirs 0]
+ lvarpush TCLXENV(dirPushList) $current
+ } else {
+ if [lempty $TCLXENV(dirPushList)] {
+ error "directory stack empty"
+ }
+ cd [lindex $TCLXENV(dirPushList) 0]
+ lvarpop TCLXENV(dirPushList)
+ lvarpush TCLXENV(dirPushList) $current
+ }
+ return [pwd]
+}
+
+proc popd {} {
+ global TCLXENV
+
+ if [lempty $TCLXENV(dirPushList)] {
+ error "directory stack empty"
+ }
+ cd [lvarpop TCLXENV(dirPushList)]
+ return [pwd]
+}
+
+proc dirs {} {
+ global TCLXENV
+ return [concat [list [pwd]] $TCLXENV(dirPushList)]
+}
+#
+# setfuncs --
+#
+# Perform set functions on lists. Also has a procedure for removing duplicate
+# list entries.
+#------------------------------------------------------------------------------
+# Copyright 1992-1996 Karl Lehenbauer and Mark Diekhans.
+#
+# Permission to use, copy, modify, and distribute this software and its
+# documentation for any purpose and without fee is hereby granted, provided
+# that the above copyright notice appear in all copies. Karl Lehenbauer and
+# Mark Diekhans make no representations about the suitability of this
+# software for any purpose. It is provided "as is" without express or
+# implied warranty.
+#------------------------------------------------------------------------------
+# $Id: tclx.nt,v 1.1 1998-09-09 18:21:14 kernel Exp $
+#------------------------------------------------------------------------------
+#
+
+#@package: TclX-set_functions union intersect intersect3 lrmdups
+
+#
+# return the logical union of two lists, removing any duplicates
+#
+proc union {lista listb} {
+ return [lrmdups [concat $lista $listb]]
+}
+
+#
+# sort a list, returning the sorted version minus any duplicates
+#
+proc lrmdups list {
+ if [lempty $list] {
+ return {}
+ }
+ set list [lsort $list]
+ set last [lvarpop list]
+ lappend result $last
+ foreach element $list {
+ if ![cequal $last $element] {
+ lappend result $element
+ set last $element
+ }
+ }
+ return $result
+}
+
+#
+# intersect3 - perform the intersecting of two lists, returning a list
+# containing three lists. The first list is everything in the first
+# list that wasn't in the second, the second list contains the intersection
+# of the two lists, the third list contains everything in the second list
+# that wasn't in the first.
+#
+
+proc intersect3 {list1 list2} {
+ set a1(0) {} ; unset a1(0)
+ set a2(0) {} ; unset a2(0)
+ set a3(0) {} ; unset a3(0)
+ foreach v $list1 {
+ set a1($v) {}
+ }
+ foreach v $list2 {
+ if [info exists a1($v)] {
+ set a2($v) {} ; unset a1($v)
+ } {
+ set a3($v) {}
+ }
+ }
+ list [lsort [array names a1]] [lsort [array names a2]] \
+ [lsort [array names a3]]
+}
+
+#
+# intersect - perform an intersection of two lists, returning a list
+# containing every element that was present in both lists
+#
+proc intersect {list1 list2} {
+ set intersectList ""
+
+ set list1 [lsort $list1]
+ set list2 [lsort $list2]
+
+ while {1} {
+ if {[lempty $list1] || [lempty $list2]} break
+
+ set compareResult [string compare [lindex $list1 0] [lindex $list2 0]]
+
+ if {$compareResult < 0} {
+ lvarpop list1
+ continue
+ }
+
+ if {$compareResult > 0} {
+ lvarpop list2
+ continue
+ }
+
+ lappend intersectList [lvarpop list1]
+ lvarpop list2
+ }
+ return $intersectList
+}
+
+
+#
+# showproc.tcl --
+#
+# Display procedure headers and bodies.
+#------------------------------------------------------------------------------
+# Copyright 1992-1996 Karl Lehenbauer and Mark Diekhans.
+#
+# Permission to use, copy, modify, and distribute this software and its
+# documentation for any purpose and without fee is hereby granted, provided
+# that the above copyright notice appear in all copies. Karl Lehenbauer and
+# Mark Diekhans make no representations about the suitability of this
+# software for any purpose. It is provided "as is" without express or
+# implied warranty.
+#------------------------------------------------------------------------------
+# $Id: tclx.nt,v 1.1 1998-09-09 18:21:14 kernel Exp $
+#------------------------------------------------------------------------------
+#
+
+#@package: TclX-showproc showproc
+
+proc showproc args {
+ if [lempty $args] {
+ set args [info procs]
+ }
+ set out {}
+
+ foreach procname $args {
+ if [lempty [info procs $procname]] {
+ auto_load $procname
+ }
+ set arglist [info args $procname]
+ set nargs {}
+ while {[llength $arglist] > 0} {
+ set varg [lvarpop arglist 0]
+ if [info default $procname $varg defarg] {
+ lappend nargs [list $varg $defarg]
+ } else {
+ lappend nargs $varg
+ }
+ }
+ append out "proc $procname [list $nargs] \{[info body $procname]\}\n"
+ }
+ return $out
+}
+#
+# string_file --
+#
+# Functions to read and write strings from a file that has not been opened.
+#------------------------------------------------------------------------------
+# Copyright 1992-1996 Karl Lehenbauer and Mark Diekhans.
+#
+# Permission to use, copy, modify, and distribute this software and its
+# documentation for any purpose and without fee is hereby granted, provided
+# that the above copyright notice appear in all copies. Karl Lehenbauer and
+# Mark Diekhans make no representations about the suitability of this
+# software for any purpose. It is provided "as is" without express or
+# implied warranty.
+#------------------------------------------------------------------------------
+# $Id: tclx.nt,v 1.1 1998-09-09 18:21:14 kernel Exp $
+#------------------------------------------------------------------------------
+#
+
+#@package: TclX-stringfile_functions read_file write_file
+
+proc read_file {fileName args} {
+ if {$fileName == "-nonewline"} {
+ set flag $fileName
+ set fileName [lvarpop args]
+ } else {
+ set flag {}
+ }
+ set fp [open $fileName]
+ set stat [catch {
+ eval read $flag $fp $args
+ } result]
+ close $fp
+ if {$stat != 0} {
+ global errorInfo errorCode
+ error $result $errorInfo $errorCode
+ }
+ return $result
+}
+
+proc write_file {fileName args} {
+ set fp [open $fileName w]
+
+ set stat [catch {
+ foreach string $args {
+ puts $fp $string
+ }
+ } result]
+ close $fp
+ if {$stat != 0} {
+ global errorInfo errorCode
+ error $result $errorInfo $errorCode
+ }
+}
+
+#
+# tcllib.tcl --
+#
+# Various command dealing with tlib package libraries.
+#------------------------------------------------------------------------------
+# Copyright 1992-1996 Karl Lehenbauer and Mark Diekhans.
+#
+# Permission to use, copy, modify, and distribute this software and its
+# documentation for any purpose and without fee is hereby granted, provided
+# that the above copyright notice appear in all copies. Karl Lehenbauer and
+# Mark Diekhans make no representations about the suitability of this
+# software for any purpose. It is provided "as is" without express or
+# implied warranty.
+#------------------------------------------------------------------------------
+# Copyright (c) 1991-1994 The Regents of the University of California.
+# All rights reserved.
+#
+# Permission is hereby granted, without written agreement and without
+# license or royalty fees, to use, copy, modify, and distribute this
+# software and its documentation for any purpose, provided that the
+# above copyright notice and the following two paragraphs appear in
+# all copies of this software.
+#
+# IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
+# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
+# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
+# CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+#
+# THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
+# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+# AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
+# ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
+# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
+#------------------------------------------------------------------------------
+# $Id: tclx.nt,v 1.1 1998-09-09 18:21:14 kernel Exp $
+#------------------------------------------------------------------------------
+#
+
+#@package: TclX-libraries searchpath auto_load_file
+
+#------------------------------------------------------------------------------
+# searchpath:
+# Search a path list for a file. (catch is for bad ~user)
+#
+proc searchpath {pathlist file} {
+ foreach dir $pathlist {
+ if {$dir == ""} {set dir .}
+ if {[catch {file exists $dir/$file} result] == 0 && $result} {
+ return $dir/$file
+ }
+ }
+ return {}
+}
+
+#------------------------------------------------------------------------------
+# auto_load_file:
+# Search auto_path for a file and source it.
+#
+proc auto_load_file {name} {
+ global auto_path errorCode
+ if {[string first / $name] >= 0} {
+ return [uplevel 1 source $name]
+ }
+ set where [searchpath $auto_path $name]
+ if [lempty $where] {
+ error "couldn't find $name in any directory in auto_path"
+ }
+ uplevel 1 source $where
+}
+
+#@package: TclX-lib-list auto_packages auto_commands
+
+#------------------------------------------------------------------------------
+# auto_packages:
+# List all of the loadable packages. If -files is specified, the file paths
+# of the packages is also returned.
+
+proc auto_packages {{option {}}} {
+ global auto_pkg_index
+
+ auto_load ;# Make sure all indexes are loaded.
+ if ![info exists auto_pkg_index] {
+ return {}
+ }
+
+ set packList [array names auto_pkg_index]
+ if [lempty $option] {
+ return $packList
+ }
+
+ if {$option != "-files"} {
+ error "Unknow option \"$option\", expected \"-files\""
+ }
+ set locList {}
+ foreach pack $packList {
+ lappend locList [list $pack [lindex $auto_pkg_index($pack) 0]]
+ }
+ return $locList
+}
+
+#------------------------------------------------------------------------------
+# auto_commands:
+# List all of the loadable commands. If -loaders is specified, the commands
+# that will be involked to load the commands is also returned.
+
+proc auto_commands {{option {}}} {
+ global auto_index
+
+ auto_load ;# Make sure all indexes are loaded.
+ if ![info exists auto_index] {
+ return {}
+ }
+
+ set cmdList [array names auto_index]
+ if [lempty $option] {
+ return $cmdList
+ }
+
+ if {$option != "-loaders"} {
+ error "Unknow option \"$option\", expected \"-loaders\""
+ }
+ set loadList {}
+ foreach cmd $cmdList {
+ lappend loadList [list $cmd $auto_index($cmd)]
+ }
+ return $loadList
+}
+
+#
+# fmath.tcl --
+#
+# Contains a package of procs that interface to the Tcl expr command built-in
+# functions. These procs provide compatibility with older versions of TclX and
+# are also generally useful.
+#------------------------------------------------------------------------------
+# Copyright 1993-1996 Karl Lehenbauer and Mark Diekhans.
+#
+# Permission to use, copy, modify, and distribute this software and its
+# documentation for any purpose and without fee is hereby granted, provided
+# that the above copyright notice appear in all copies. Karl Lehenbauer and
+# Mark Diekhans make no representations about the suitability of this
+# software for any purpose. It is provided "as is" without express or
+# implied warranty.
+#------------------------------------------------------------------------------
+# $Id: tclx.nt,v 1.1 1998-09-09 18:21:14 kernel Exp $
+#------------------------------------------------------------------------------
+
+#@package: TclX-fmath acos asin atan ceil cos cosh exp fabs floor log log10 \
+ sin sinh sqrt tan tanh fmod pow atan2 abs double int round
+
+proc acos x {uplevel [list expr acos($x)]}
+proc asin x {uplevel [list expr asin($x)]}
+proc atan x {uplevel [list expr atan($x)]}
+proc ceil x {uplevel [list expr ceil($x)]}
+proc cos x {uplevel [list expr cos($x)]}
+proc cosh x {uplevel [list expr cosh($x)]}
+proc exp x {uplevel [list expr exp($x)]}
+proc fabs x {uplevel [list expr abs($x)]}
+proc floor x {uplevel [list expr floor($x)]}
+proc log x {uplevel [list expr log($x)]}
+proc log10 x {uplevel [list expr log10($x)]}
+proc sin x {uplevel [list expr sin($x)]}
+proc sinh x {uplevel [list expr sinh($x)]}
+proc sqrt x {uplevel [list expr sqrt($x)]}
+proc tan x {uplevel [list expr tan($x)]}
+proc tanh x {uplevel [list expr tanh($x)]}
+
+proc fmod {x n} {uplevel [list expr fmod($x,$n)]}
+proc pow {x n} {uplevel [list expr pow($x,$n)]}
+
+# New functions that TclX did not provide in eariler versions.
+
+proc atan2 x {uplevel [list expr atan2($x)]}
+proc abs x {uplevel [list expr abs($x)]}
+proc double x {uplevel [list expr double($x)]}
+proc int x {uplevel [list expr int($x)]}
+proc round x {uplevel [list expr round($x)]}
+
+#
+# buildhelp.tcl --
+#
+# Program to extract help files from TCL manual pages or TCL script files.
+# The help directories are built as a hierarchical tree of subjects and help
+# files.
+#
+#------------------------------------------------------------------------------
+# Copyright 1992-1996 Karl Lehenbauer and Mark Diekhans.
+#
+# Permission to use, copy, modify, and distribute this software and its
+# documentation for any purpose and without fee is hereby granted, provided
+# that the above copyright notice appear in all copies. Karl Lehenbauer and
+# Mark Diekhans make no representations about the suitability of this
+# software for any purpose. It is provided "as is" without express or
+# implied warranty.
+#------------------------------------------------------------------------------
+# $Id: tclx.nt,v 1.1 1998-09-09 18:21:14 kernel Exp $
+#------------------------------------------------------------------------------
+#
+# For nroff man pages, the areas of text to extract are delimited with:
+#
+# '\"@help: subjectdir/helpfile
+# '\"@endhelp
+#
+# start in column one. The text between these markers is extracted and stored
+# in help/subjectdir/help. The file must not exists, this is done to enforced
+# cleaning out the directories before help file generation is started, thus
+# removing any stale files. The extracted text is run through:
+#
+# nroff -man|col -xb {col -b on BSD derived systems}
+#
+# If there is other text to include in the helpfile, but not in the manual
+# page, the text, along with nroff formatting commands, may be included using:
+#
+# '\"@:Other text to include in the help page.
+#
+# A entry in the brief file, used by apropos my be included by:
+#
+# '\"@brief: Short, one line description
+#
+# These brief request must occur with in the bounds of a help section.
+#
+# If some header text, such as nroff macros, need to be preappended to the
+# text streem before it is run through nroff, then that text can be bracketed
+# with:
+#
+# '\"@header
+# '\"@endheader
+#
+# If multiple header blocks are encountered, they will all be preappended.
+#
+# For TCL script files, which are indentified because they end in ".tcl",
+# the text to be extracted is delimited by:
+#
+# #@help: subjectdir/helpfile
+# #@endhelp
+#
+# And brief lines are in the form:
+#
+# #@brief: Short, one line description
+#
+# The only processing done on text extracted from .tcl files it to replace
+# the # in column one with a space.
+#
+#
+#-----------------------------------------------------------------------------
+#
+# To generate help:
+#
+# buildhelp helpDir brief.brf filelist
+#
+# o helpDir is the help tree root directory. helpDir should exists, but any
+# subdirectories that don't exists will be created. helpDir should be
+# cleaned up before the start of manual page generation, as this program
+# will not overwrite existing files.
+# o brief.brf is the name of the brief file to create form the @brief entries.
+# It must have an extension of ".brf". It will be created in helpDir.
+# o filelist are the nroff manual pages, or .tcl, .tlib files to extract
+# the help files from. If the suffix is not .tcl or .tlib, a nroff manual
+# page is assumed.
+#
+#-----------------------------------------------------------------------------
+
+#@package: TclX-buildhelp buildhelp
+
+#-----------------------------------------------------------------------------
+# Truncate a file name of a help file if the system does not support long
+# file names. If the name starts with `Tcl_', then this prefix is removed.
+# If the name is then over 14 characters, it is truncated to 14 charactes
+#
+proc TruncFileName {pathName} {
+ global truncFileNames
+
+ if {!$truncFileNames} {
+ return $pathName}
+ set fileName [file tail $pathName]
+ if {"[crange $fileName 0 3]" == "Tcl_"} {
+ set fileName [crange $fileName 4 end]}
+ set fileName [crange $fileName 0 13]
+ return "[file dirname $pathName]/$fileName"
+}
+
+#-----------------------------------------------------------------------------
+# Proc to ensure that all directories for the specified file path exists,
+# and if they don't create them. Don't use -path so we can set the
+# permissions.
+
+proc EnsureDirs {filePath} {
+ set dirPath [file dirname $filePath]
+ if [file exists $dirPath] return
+ foreach dir [split $dirPath /] {
+ lappend dirList $dir
+ set partPath [join $dirList /]
+ if [file exists $partPath] continue
+
+ mkdir $partPath
+ chmod u=rwx,go=rx $partPath
+ }
+}
+
+#-----------------------------------------------------------------------------
+# Proc to set up scan context for use by FilterNroffManPage.
+# This keeps the a two line cache of the previous two lines encountered
+# and the blank lines that followed them.
+#
+
+proc CreateFilterNroffManPageContext {} {
+ global filterNroffManPageContext
+
+ set filterNroffManPageContext [scancontext create]
+
+ # On finding a page header, drop the previous line (which is
+ # the page footer). Also deleting the blank lines followin
+ # the last line on the previous page.
+
+ scanmatch $filterNroffManPageContext {@@@BUILDHELP@@@} {
+ catch {unset prev2Blanks}
+ catch {unset prev1Line}
+ catch {unset prev1Blanks}
+ set nukeBlanks {}
+ }
+
+ # Save blank lines
+
+ scanmatch $filterNroffManPageContext {$^} {
+ if ![info exists nukeBlanks] {
+ append prev1Blanks \n
+ }
+ }
+
+ # Non-blank line, save it. Output the 2nd previous line if necessary.
+
+ scanmatch $filterNroffManPageContext {
+ catch {unset nukeBlanks}
+ if [info exists prev2Line] {
+ puts $outFH $prev2Line
+ unset prev2Line
+ }
+ if [info exists prev2Blanks] {
+ puts $outFH $prev2Blanks nonewline
+ unset prev2Blanks
+ }
+ if [info exists prev1Line] {
+ set prev2Line $prev1Line
+ }
+ set prev1Line $matchInfo(line)
+ if [info exists prev1Blanks] {
+ set prev2Blanks $prev1Blanks
+ unset prev1Blanks
+ }
+ }
+}
+
+#-----------------------------------------------------------------------------
+# Proc to filter a formatted manual page, removing the page headers and
+# footers. This relies on each manual page having a .TH macro in the form:
+# .TH @@@BUILDHELP@@@ n
+
+proc FilterNroffManPage {inFH outFH} {
+ global filterNroffManPageContext
+
+ if ![info exists filterNroffManPageContext] {
+ CreateFilterNroffManPageContext
+ }
+
+ scanfile $filterNroffManPageContext $inFH
+
+ if [info exists prev2Line] {
+ puts $outFH $prev2Line
+ }
+}
+
+#-----------------------------------------------------------------------------
+# Proc to set up scan context for use by ExtractNroffHeader
+#
+
+proc CreateExtractNroffHeaderContext {} {
+ global extractNroffHeaderContext
+
+ set extractNroffHeaderContext [scancontext create]
+
+ scanmatch $extractNroffHeaderContext {'\\"@endheader[ ]*$} {
+ break
+ }
+ scanmatch $extractNroffHeaderContext {'\\"@:} {
+ append nroffHeader "[crange $matchInfo(line) 5 end]\n"
+ }
+ scanmatch $extractNroffHeaderContext {
+ append nroffHeader "$matchInfo(line)\n"
+ }
+}
+
+#-----------------------------------------------------------------------------
+# Proc to extract nroff text to use as a header to all pass to nroff when
+# processing a help file.
+# manPageFH - The file handle of the manual page.
+#
+
+proc ExtractNroffHeader {manPageFH} {
+ global extractNroffHeaderContext nroffHeader
+
+ if ![info exists extractNroffHeaderContext] {
+ CreateExtractNroffHeaderContext
+ }
+ scanfile $extractNroffHeaderContext $manPageFH
+}
+
+
+#-----------------------------------------------------------------------------
+# Proc to set up scan context for use by ExtractNroffHelp
+#
+
+proc CreateExtractNroffHelpContext {} {
+ global extractNroffHelpContext
+
+ set extractNroffHelpContext [scancontext create]
+
+ scanmatch $extractNroffHelpContext {^'\\"@endhelp[ ]*$} {
+ break
+ }
+
+ scanmatch $extractNroffHelpContext {^'\\"@brief:} {
+ if $foundBrief {
+ error {Duplicate "@brief:" entry}
+ }
+ set foundBrief 1
+ puts $briefHelpFH "$helpName\t[csubstr $matchInfo(line) 11 end]"
+ continue
+ }
+
+ scanmatch $extractNroffHelpContext {^'\\"@:} {
+ puts $nroffFH [csubstr $matchInfo(line) 5 end]
+ continue
+ }
+ scanmatch $extractNroffHelpContext {^'\\"@help:} {
+ error {"@help" found within another help section"}
+ }
+ scanmatch $extractNroffHelpContext {
+ puts $nroffFH $matchInfo(line)
+ }
+}
+
+#-----------------------------------------------------------------------------
+# Proc to extract a nroff help file when it is located in the text.
+# manPageFH - The file handle of the manual page.
+# manLine - The '\"@help: line starting the data to extract.
+#
+
+proc ExtractNroffHelp {manPageFH manLine} {
+ global helpDir nroffHeader briefHelpFH colArgs
+ global extractNroffHelpContext
+
+ if ![info exists extractNroffHelpContext] {
+ CreateExtractNroffHelpContext
+ }
+
+ set helpName [string trim [csubstr $manLine 9 end]]
+ set helpFile [TruncFileName "$helpDir/$helpName"]
+ if [file exists $helpFile] {
+ error "Help file already exists: $helpFile"
+ }
+ EnsureDirs $helpFile
+
+ set tmpFile "[file dirname $helpFile]/tmp.[id process]"
+
+ echo " creating help file $helpName"
+
+ set nroffFH [open "| nroff -man | col $colArgs > $tmpFile" w]
+
+ puts $nroffFH {.TH @@@BUILDHELP@@@ 1}
+
+ set foundBrief 0
+ scanfile $extractNroffHelpContext $manPageFH
+
+ # Close returns an error on if anything comes back on stderr, even if
+ # its a warning. Output errors and continue.
+
+ set stat [catch {
+ close $nroffFH
+ } msg]
+ if $stat {
+ puts stderr "nroff: $msg"
+ }
+
+ set tmpFH [open $tmpFile r]
+ set helpFH [open $helpFile w]
+
+ FilterNroffManPage $tmpFH $helpFH
+
+ close $tmpFH
+ close $helpFH
+
+ unlink $tmpFile
+ chmod a-w,a+r $helpFile
+}
+
+#-----------------------------------------------------------------------------
+# Proc to set up scan context for use by ExtractScriptHelp
+#
+
+proc CreateExtractScriptHelpContext {} {
+ global extractScriptHelpContext
+
+ set extractScriptHelpContext [scancontext create]
+
+ scanmatch $extractScriptHelpContext {^#@endhelp[ ]*$} {
+ break
+ }
+
+ scanmatch $extractScriptHelpContext {^#@brief:} {
+ if $foundBrief {
+ error {Duplicate "@brief" entry}
+ }
+ set foundBrief 1
+ puts $briefHelpFH "$helpName\t[csubstr $matchInfo(line) 9 end]"
+ continue
+ }
+
+ scanmatch $extractScriptHelpContext {^#@help:} {
+ error {"@help" found within another help section"}
+ }
+
+ scanmatch $extractScriptHelpContext {^#$} {
+ puts $helpFH ""
+ }
+
+ scanmatch $extractScriptHelpContext {
+ if {[clength $matchInfo(line)] > 1} {
+ puts $helpFH " [csubstr $matchInfo(line) 1 end]"
+ } else {
+ puts $helpFH $matchInfo(line)
+ }
+ }
+}
+
+#-----------------------------------------------------------------------------
+# Proc to extract a tcl script help file when it is located in the text.
+# ScriptPageFH - The file handle of the .tcl file.
+# ScriptLine - The #@help: line starting the data to extract.
+#
+
+proc ExtractScriptHelp {scriptPageFH scriptLine} {
+ global helpDir briefHelpFH
+ global extractScriptHelpContext
+
+ if ![info exists extractScriptHelpContext] {
+ CreateExtractScriptHelpContext
+ }
+
+ set helpName [string trim [csubstr $scriptLine 7 end]]
+ set helpFile "$helpDir/$helpName"
+ if {[file exists $helpFile]} {
+ error "Help file already exists: $helpFile"
+ }
+ EnsureDirs $helpFile
+
+ echo " creating help file $helpName"
+
+ set helpFH [open $helpFile w]
+
+ set foundBrief 0
+ scanfile $extractScriptHelpContext $scriptPageFH
+
+ close $helpFH
+ chmod a-w,a+r $helpFile
+}
+
+#-----------------------------------------------------------------------------
+# Proc to scan a nroff manual file looking for the start of a help text
+# sections and extracting those sections.
+# pathName - Full path name of file to extract documentation from.
+#
+
+proc ProcessNroffFile {pathName} {
+ global nroffScanCT scriptScanCT nroffHeader
+
+ set fileName [file tail $pathName]
+
+ set nroffHeader {}
+ set manPageFH [open $pathName r]
+ set matchInfo(fileName) [file tail $pathName]
+
+ echo " scanning $pathName"
+
+ scanfile $nroffScanCT $manPageFH
+
+ close $manPageFH
+}
+
+#-----------------------------------------------------------------------------
+# Proc to scan a Tcl script file looking for the start of a
+# help text sections and extracting those sections.
+# pathName - Full path name of file to extract documentation from.
+#
+
+proc ProcessTclScript {pathName} {
+ global scriptScanCT nroffHeader
+
+ set scriptFH [open "$pathName" r]
+ set matchInfo(fileName) [file tail $pathName]
+
+ echo " scanning $pathName"
+ scanfile $scriptScanCT $scriptFH
+
+ close $scriptFH
+}
+
+#-----------------------------------------------------------------------------
+# build: main procedure. Generates help from specified files.
+# helpDirPath - Directory were the help files go.
+# briefFile - The name of the brief file to create.
+# sourceFiles - List of files to extract help files from.
+
+proc buildhelp {helpDirPath briefFile sourceFiles} {
+ global helpDir truncFileNames nroffScanCT
+ global scriptScanCT briefHelpFH colArgs
+
+ echo ""
+ echo "Begin building help tree"
+
+ # Determine version of col command to use (no -x on BSD)
+ if {[system {col -bx </dev/null >/dev/null 2>&1}] != 0} {
+ set colArgs {-b}
+ } else {
+ set colArgs {-bx}
+ }
+ set helpDir $helpDirPath
+ if {![file exists $helpDir]} {
+ mkdir $helpDir
+ }
+
+ if {![file isdirectory $helpDir]} {
+ error [concat "$helpDir is not a directory or does not exist. "
+ "This should be the help root directory"]
+ }
+
+ set status [catch {set tmpFH [open $helpDir/AVeryVeryBigFileName w]}]
+ if {$status != 0} {
+ set truncFileNames 1
+ } else {
+ close $tmpFH
+ unlink $helpDir/AVeryVeryBigFileName
+ set truncFileNames 0
+ }
+
+ set nroffScanCT [scancontext create]
+
+ scanmatch $nroffScanCT {'\\"@help:} {
+ ExtractNroffHelp $matchInfo(handle) $matchInfo(line)
+ continue
+ }
+
+ scanmatch $nroffScanCT {^'\\"@header} {
+ ExtractNroffHeader $matchInfo(handle)
+ continue
+ }
+ scanmatch $nroffScanCT {^'\\"@endhelp} {
+ error [concat {@endhelp" without corresponding "@help:"} \
+ ", offset = $matchInfo(offset)"]
+ }
+ scanmatch $nroffScanCT {^'\\"@brief} {
+ error [concat {"@brief" without corresponding "@help:"} \
+ ", offset = $matchInfo(offset)"]
+ }
+
+ set scriptScanCT [scancontext create]
+ scanmatch $scriptScanCT {^#@help:} {
+ ExtractScriptHelp $matchInfo(handle) $matchInfo(line)
+ }
+
+ if {[file extension $briefFile] != ".brf"} {
+ error "Brief file \"$briefFile\" must have an extension \".brf\""
+ }
+ if [file exists $helpDir/$briefFile] {
+ error "Brief file \"$helpDir/$briefFile\" already exists"
+ }
+ set briefHelpFH [open "|sort > $helpDir/$briefFile" w]
+
+ foreach manFile [glob $sourceFiles] {
+ set ext [file extension $manFile]
+ if {$ext == ".tcl" || $ext == ".tlib"} {
+ set status [catch {ProcessTclScript $manFile} msg]
+ } else {
+ set status [catch {ProcessNroffFile $manFile} msg]
+ }
+ if {$status != 0} {
+ global errorInfo errorCode
+ error "Error extracting help from: $manFile" $errorInfo $errorCode
+ }
+ }
+
+ close $briefHelpFH
+ chmod a-w,a+r $helpDir/$briefFile
+ echo "Completed extraction of help files"
+}
+
--- /dev/null
+/* XPM */
+static char * textfile_adm[] = {
+"12 12 3 1",
+" s None c None",
+". c orange",
+"X c #FFFFFFFFF3CE",
+" XXXXXXXX ",
+" X......X ",
+" X......XXX ",
+" X........X ",
+" X........X ",
+" X........X ",
+" X........X ",
+" X........X ",
+" X........X ",
+" X........X ",
+" X........X ",
+" XXXXXXXXXX "};
+
--- /dev/null
+/* XPM */
+static char * textfile_xpm[] = {
+"12 12 3 1",
+" s None c None",
+". c tomato",
+"X c #FFFFFFFFF3CE",
+" ........ ",
+" .XXX..X. ",
+" .XXX..X... ",
+" .XXX..XXX. ",
+" .XXX..XXX. ",
+" .XXX..XXX. ",
+" .XXX..XXX. ",
+" .XXX..XXX. ",
+" .XXX..XXX. ",
+" .XXX..XXX. ",
+" .XXX..XXX. ",
+" .......... "};
--- /dev/null
+/* XPM */
+static char * toolkit_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"24 26 22 1 0 0",
+/* colors */
+" s none m none c none",
+". s iconColor1 m black c black",
+"X c #999960605555",
+"o c #999960600000",
+"O c #999940405555",
+"+ c #CCCC60600000",
+"@ c #CCCC80805555",
+"# c #CCCC9F9F5555",
+"$ c #CCCC80800000",
+"% c #FFFF80800000",
+"& c #9999BFBFFFFF",
+"* c #9999DFDFAAAA",
+"= c #9999DFDFFFFF",
+"- c #6666BFBFFFFF",
+"; c #33339F9F5555",
+": c #333340405555",
+"? c #333360605555",
+"> c #333380805555",
+", c #333360600000",
+"< c #66668080AAAA",
+"1 c #999980805555",
+"2 c #00008080AAAA",
+/* pixels */
+" ",
+" ",
+" .XoOoXo. ",
+" ..O..+O+. ",
+" XX.@#X.. ",
+" .oO..$@ ",
+" OoX..@@# ",
+" .+O. .@%@ ",
+" .. .#@# ",
+" .@$@ ",
+" .@@# . ",
+" .@%@ &*. ",
+" .#@# =.=-=. ",
+" .@$@ &..*&=. ",
+" .@@# =.;:?.=-. ",
+" .@%@.&.:.&*.>. ",
+" .#@#>=..-=.;>;. ",
+" .@$@;&=.;>>>;>. ",
+" .?.@@#>.>;>;>.. ",
+" ..,:.@..>>;>>>.<1< ",
+" .;2?.;2;>;2;.<<< ",
+" 1<.>;>>>;..<1< ",
+" <<<..;>;.<<< ",
+" 1<1<.<1< ",
+" <<<< ",
+" < "};
--- /dev/null
+/* XPM */
+static char * toolkit_open_xpm[] = {
+"24 26 22 1",
+" c #FFFFFFFF0000",
+". c #000000000000",
+"X c #999960605555",
+"o c #999960600000",
+"O c #999940405555",
+"+ c #CCCC60600000",
+"@ c #CCCC80805555",
+"# c #CCCC9F9F5555",
+"$ c #CCCC80800000",
+"% c #FFFF80800000",
+"& c #9999BFBFFFFF",
+"* c #9999DFDFAAAA",
+"= c #9999DFDFFFFF",
+"- c #6666BFBFFFFF",
+"; c #33339F9F5555",
+": c #333340405555",
+"? c #333360605555",
+"> c #333380805555",
+", c #333360600000",
+"< c #66668080AAAA",
+"1 c #999980805555",
+"2 c #00008080AAAA",
+" ",
+" ",
+" .XoOoXo. ",
+" ..O..+O+. ",
+" XX.@#X.. ",
+" .oO..$@ ",
+" OoX..@@# ",
+" .+O. .@%@ ",
+" .. .#@# ",
+" .@$@ ",
+" .@@# . ",
+" .@%@ &*. ",
+" .#@# =.=-=. ",
+" .@$@ &..*&=. ",
+" .@@# =.;:?.=-. ",
+" .@%@.&.:.&*.>. ",
+" .#@#>=..-=.;>;. ",
+" .@$@;&=.;>>>;>. ",
+" .?.@@#>.>;>;>.. ",
+" ..,:.@..>>;>>>.<1< ",
+" .;2?.;2;>;2;.<<< ",
+" 1<.>;>>>;..<1< ",
+" <<<..;>;.<<< ",
+" 1<1<.<1< ",
+" <<<< ",
+" < "};
--- /dev/null
+/* XPM */
+static char * transient_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"16 16 4 1 -1 -1",
+/* colors */
+" s topShadowColor m white c #bdbdbdbdbdbd",
+". s iconGray6 m black c #636363636363",
+"X s bottomShadowColor m black c #636363636363",
+"o s iconColor2 m white c white",
+/* pixels */
+" ",
+" ..............X",
+" ..............X",
+" ..oooooooooo..X",
+" ......o.......X",
+" ......o.......X",
+" ......o.......X",
+" ......o.......X",
+" ......o.......X",
+" ......o.......X",
+" ......o.......X",
+" ......o.......X",
+" ......o.......X",
+" ..............X",
+" ..............X",
+" XXXXXXXXXXXXXXX"};
--- /dev/null
+/* XPM */
+static char * dir_xpm[] = {
+/* width height ncolors chars_per_pixel */
+"20 22 5 1",
+/* colors */
+" s None c None",
+". c black",
+"X c wheat",
+"o c sienna",
+"O c dark slate grey",
+/* pixels */
+" ",
+" ",
+" ",
+" ",
+" ........ ",
+" .XXXXXXXX. ",
+".XXXXXXXXXX...... ",
+".oXXXXXXXXoXXXXXX. ",
+".XooooooooXXXXXXXo. ",
+".XXXXXXXXXXXXXXXXoO.",
+".XXXXXXXXXXXXXXXXoO.",
+".XXXXXXXXXXXXXXXXoO.",
+".XXXXXXXXXXXXXXXXoO.",
+".XXXXXXXXXXXXXXXXoO.",
+".XXXXXXXXXXXXXXXXoO.",
+".XXXXXXXXXXXXXXXXoO.",
+".XXXXXXXXXXXXXXXXoO.",
+".XXXXXXXXXXXXXXXXoO.",
+".XXXXXXXXXXXXXXXXoO.",
+" .oooooooooooooooOO.",
+" .OOOOOOOOOOOOOOO.O",
+" ...............O "};
--- /dev/null
+/* XPM */
+static char * dir_open_xpm[] = {
+/* width height ncolors chars_per_pixel */
+"27 22 6 1",
+/* colors */
+" s None c None",
+". c black",
+"X c grey",
+"o c wheat",
+"O c sienna",
+"+ c dark slate grey",
+/* pixels */
+" ",
+" ",
+" ",
+" ",
+" ........ ",
+" .XXXXXXXX. ",
+".XXXXXXXXXX...... ",
+".XXXXXXXXXXXXXXXX. ",
+".XXXXXXXXXXXXXXXXX. ",
+".XXXXXXXXX.XXXXXXXX....... ",
+".XXXXXXXX.o.XXXXXX.ooooooO.",
+".XXXXXXX.ooo......ooooooO+.",
+".XXXXXX.oooooooooooooooO+. ",
+".XXXXX.oooooooooooooooO+. ",
+".XXXX.oooooooooooooooO+. ",
+".XXX.oooooooooooooooO+. ",
+".XX.oooooooooooooooO+. ",
+".X.oooooooooooooooO+. ",
+"..oooooooooooooooO+. ",
+" .OOOOOOOOOOOOOO++. ",
+" .+++++++++++++.. ",
+" .............. "};
--- /dev/null
+/* XPM */
+static char * dir_sec_xpm[] = {
+/* width height ncolors chars_per_pixel */
+"20 22 7 1",
+/* colors */
+" s None c None",
+". c black",
+"X c wheat",
+"o c tomato",
+"O c firebrick",
+"+ c sienna",
+"@ c dark slate grey",
+/* pixels */
+" ",
+" ",
+" ",
+" ",
+" ........ ",
+" .XXXXXXXX.oooo ",
+".XXXXXXXXXXooooO. ",
+".+XXXXXXXX+ooooOX. ",
+".X++++++++XooooOX+. ",
+".XXXXXXXXXXooooOX+@.",
+".XXXXXXXXXXooooOX+@.",
+".XXXXXXXXXXooooOX+@.",
+".XXXXXXXXXXooooOX+@.",
+".XXXXXXXXXXooooOX+@.",
+".XXXXXXXXXXooooOX+@.",
+".XXXXXXXXXXooooOX+@.",
+".XXXXXXXXXXooooOX+@.",
+".XXXXXXXXXXooooOX+@.",
+".XXXXXXXXXXooooOX+@.",
+" .+++++++++ooooO+@@.",
+" .@@@@@@@@ooooO@@.@",
+" .........OOOO..@ "};
--- /dev/null
+proc upack_usage { } {
+ puts stderr \
+ {
+ Usage: upack -[hcrl] <Archname> [-t <Type1>,<Type2>... ]
+
+ upack -h
+
+ Displays this text
+
+ upack -c [Unit] -o Archnamecompress
+
+ Creates archive <Archname> from Unit. If Unit is not
+ specified, then uses the current one. This is the default
+ option.
+
+ upack -r Archname [-d TclScript]
+
+ Creates a unit in the current environment using <Archname>.
+ Basename of <Archname> is used as the unit name, its extension
+ as the unit type (package nocdlpack schema executable etc... )
+
+ If -d option is specified, uses TclScript for backuping
+ the files from the archive.
+
+ upack -l Archname
+
+ Displays the contents of <Archname>
+
+ Options -t can be used to select one or more specifics types
+
+ Examples:
+ To create an archive with only "source" and "object" types:
+ > upack -c [Unit] -o Archname -t source,object
+
+ }
+ return
+}
+
+proc upack { args } {
+
+ ;# Options
+ ;#
+ set tblreq(-c) default
+ set tblreq(-h) {}
+ set tblreq(-l) {}
+ set tblreq(-r) {}
+ set tblreq(-v) {}
+ set tblreq(-d) value_required:file
+ set tblreq(-o) value_required:file
+ set tblreq(-t) value_required:list
+
+ ;# Si on n'est sur de n'avoir que de l'ascii
+ ;#
+ set tblreq(-f) {}
+ set tblreq(-F) value_required:string
+
+ ;# Parameters
+ ;#
+ set param {}
+
+ if { [wokUtils:EASY:GETOPT param table tblreq upack_usage $args] == -1 } return
+
+ if { [info exists table(-h)] } {
+ upack_usage
+ return
+ }
+
+ set verbose [info exists table(-v)]
+
+ set typsel {}
+ if { [info exists table(-t)] } {
+ set typsel $table(-t)
+ }
+
+ if { [info exists table(-c)] } {
+ set Uadr [lindex $param 0]
+ if { $Uadr == {} } {
+ set Uadr [wokcd]
+ }
+ if { [info exists table(-o)] } {
+ set Zadr $table(-o)
+ if ![catch {set idar [open $Zadr w]} status] {
+ if { [info exists table(-f)] } {
+ if { [info exists table(-F)] } {
+ auto_load $table(-F)
+ upack:Fold [$table(-F) $Uadr $verbose] $idar {} $verbose
+ } else {
+ upack:Fold [uinfo -Fp -Tsource $Uadr] $idar {} $verbose
+ }
+ } else {
+ if { $typsel == {} } {
+ set typsel [upack:Upackable]
+ }
+ upack:Fold [wokUtils:LIST:Filter [uinfo -Fp $Uadr] upack:UOK 2] $idar $typsel $verbose
+ }
+ close $idar
+ wokUtils:FILES:compress $Zadr
+ } else {
+ puts stderr "Error: $status"
+ }
+ } else {
+ upack_usage
+ }
+ return
+ }
+
+ if { [info exists table(-l)] } {
+ set Zadr [lindex $param 0]
+ set adr [wokUtils:FILES:SansZ $Zadr]
+ if { $adr != -1} {
+ if ![catch {set idar [open $adr r]} status] {
+ upack:LsFold $idar $typsel
+ close $idar
+ } else {
+ puts stderr "Error: $status"
+ }
+ if [file exists $adr] {
+ catch {unlink $adr}
+ }
+ }
+ return
+ }
+
+ if { [info exists table(-r)] } {
+ set Zadr [lindex $param 0]
+ set adr [wokUtils:FILES:SansZ $Zadr]
+ if { $adr != -1} {
+ if ![catch {set idar [open $adr r]} status] {
+ set dirtmp [wokUtils:FILES:tmpname {}]
+ upack:UnFold $idar stderr $dirtmp $typsel $verbose
+ close $idar
+ } else {
+ puts stderr "Error: $status"
+ }
+ if [file exists $adr] {
+ catch {unlink $adr}
+ }
+ }
+ return
+ }
+
+ upack_usage
+ return
+}
+#
+# Retourne le full path du fichier ou il faut restaurer le fichier
+# de nom <name> et de type <type>. Retourne -1 sinon.
+# Cette fonction peut etre redefinie en fonction de ce que l'on souhaite faire
+# Ce qui suit permet de recreer les fichiers dans le cadre d'une UD Wok++. deja existante.
+#
+proc upack:GetBackupName { type name } {
+ ;#puts stdout "type = $type name = $name longeur de name : [string length $name]"
+ if { [string length $name] != 0 } {
+ catch {unset filename}
+ if { ![catch {set filename [wokinfo -p ${type}:${name}] }] } {
+ set dna [file dirname $filename]
+ if {[file exists $dna]} {
+ return $filename
+ } else {
+ msgprint -w "Directory $dna not found. File $name not restaured."
+ return -1
+ }
+ } else {
+ msgprint -w "Unable to get type of ${type}:${name}"
+ return -1
+ }
+ } else {
+ msgprint -w "Obsolete type $type. File $name not restaured."
+ return -1
+ }
+}
+#
+# Retourne la liste des fichiers candidats a aller dans une archive de source. Si cette liste
+# est {} tout le monde y va exemple: return [list source object stadmfile]
+#
+proc upack:Upackable { } {
+ return [list source]
+}
+#
+# Permet de filtrer le retour de uinfo
+#
+proc upack:UOK { x } {
+ return [expr { [file exists $x] && ![file isdirectory $x] }]
+}
+#
+# Depliage d'une archive de sources
+#
+# FileId (entree) descripteur de l'archive de source
+# errlog : descripteur du fichier ou l'on ecrit ce que l'on n'a pas pu faire
+# (restaurer des types inconnus ou dont le profil ne correspond pas)
+# errdir : Nom du directory ou l'on restaurera tout ce qui n'a pu l'etre dans l'UD.
+# typsel : Liste des types a restaurer si {} on (tente) de tout restaurer
+#
+proc upack:UnFold { fileid errlog errdir {typsel {}} verbose } {
+ set lu {}
+ set lst [llength $typsel]
+ while {[gets $fileid line] >= 0 } {
+ if { [regexp {^=\+=\+=\+=\+=\+=\+=\+=\+=\+=\+ ([^ ]*) ([^ ]*)} $line ignore type name] } {
+ if [info exist fileout] {catch {close $fileout; unset fileout } }
+ if { ($lst == 0) || ( ($lst != 0) && ([lsearch $typsel $type] != -1)) } {
+ set retval [upack:GetBackupName $type $name]
+ if { $retval != -1 } {
+ set filename $retval
+ } else {
+ puts $errlog "Error: Item $line not processed"
+ set filename $errdir/notdone
+ }
+ if {[string compare [file extension $retval] .U] == 0 } {
+ lappend lu $retval
+ }
+ if ![catch { set fileout [open $filename w] } errout] {
+ if { $verbose } { msgprint -i "Creating $filename" }
+ } else {
+ msgprint -e "$errout"
+ return -1
+ }
+ } else {
+ }
+ } else {
+ if [info exist fileout] {
+ puts $fileout $line
+ }
+ }
+ }
+ if [info exist fileout] {catch {close $fileout; unset fileout } }
+ foreach u $lu {
+ puts -nonewline stderr "Decoding $u ..."
+ wokUtils:FILES:uudecode $u
+ unlink $u
+ puts stderr "Done"
+ }
+ return
+}
+#
+# Pliage d'un liste de fichiers dans fileid (deja ouvert et checke)
+# TypesAndFullPathesList : retour de uinfo -Fp
+# Si typsel = {} tout le monde y va
+#
+proc upack:Fold { List3 fileid {typsel {}} verbose } {
+ set lst [llength $typsel]
+ set dirtmp [wokUtils:FILES:tmpname {}]
+ foreach e $List3 {
+ set type [lindex $e 0]
+ if {[lsearch $typsel $type] != -1 || $lst == 0} {
+ set tnam [lindex $e 2]
+ set name $tnam
+ set code [wokUtils:FILES:Encodable $tnam]
+ if { $code != -1 } {
+ set name $dirtmp/[file tail $tnam].U
+ wokUtils:FILES:uuencode $tnam $name
+ }
+ if { [catch { set in [ open $name r ] } errin] == 0 } {
+ if { $verbose } { msgprint -i "Processing file $name"}
+ puts $fileid [format "=+=+=+=+=+=+=+=+=+=+ %s %s" $type [file tail $name]]
+ puts -nonewline $fileid [read $in]
+ close $in
+ } else {
+ puts stderr "Error: $errin"
+ }
+ if { $code != -1 } {
+ unlink $name
+ }
+ }
+ }
+ return
+}
+#
+# Listing d'une archive de sources
+#
+# FileId (entree) descripteur de l'archive de source
+#
+proc upack:LsFold { fileid {typsel {}} } {
+ set lst [llength $typsel]
+ while {[gets $fileid line] >= 0 } {
+ if { [regexp {^=\+=\+=\+=\+=\+=\+=\+=\+=\+=\+ ([^ ]*) ([^ ]*)} $line ignore type name] } {
+ if { ($lst == 0) || ( ($lst != 0) && ([lsearch $typsel $type] != -1)) } {
+ msgprint -i "$type $name"
+ }
+ }
+ }
+ return
+}
+
+#
+# Packer un workbench
+#
+proc wpack_usage { } {
+ puts stderr \
+ {
+ Usage:
+
+ To create an archive file from a workbench:
+
+ wpack -c [workbench] [-d Dirname | -f filename ] [-t <Type1>,<Type2>.. ] [-u Ud1,Ud2,..]
+
+ Backup contents of <workbench> in ,<Dirname> or <filename>.
+
+ If you specify -d Dirname, one archive file will be created for each unit in in directory
+ Dirname. They will be named Unit.type.Z. They can be further downloaded separatly using upack in
+ a existing workbench, or globally using -r option of wpack.
+
+ If you specify -f filename, all units will be archived in one file named filename.Z. This should be
+ more convenient for mailing.
+
+ Options -t and -u selects respectively the type and the name of the units to process.
+ Wildcard as * can be used for specifying type and unit names.
+
+ To restore an archive file:
+
+ wpack -r [workbench] [-d Dirname | -f filename ] [-t <Type1>,<Type2>.. ] [-u Ud1,Ud2,..]
+
+ Restores contents of <Dirname> or <filename> in <workbench>. Options -t and -u selects
+ respectively the type and the name of the units to restore. If applicable, units will be
+ automatically created and filled in with files. No test is done to check if the restored
+ files are already existing. It is recommended to create and empty workbench and restore
+ archives in that workbench. Further comparison with existing files, and housekeeping should
+ be carried out using the command wprepare.
+
+ To create an archive file from a report created by the command wprepare:
+
+ wpack -rep <ReportName> -f filename
+
+ This option should be used in conjonction with the command wprepare -since to package deltas sources.
+ See examples (wpack -examples)
+
+ Other options:
+
+ -> If applicable, source files in a parcel can be downloaded using:
+
+ wpack -r [workbench] -p ParcelName [-t <Type1>,<Type2>.. ] [-u Ud1,Ud2,..]
+
+ -> To list the contents of a archive file:
+
+ wpack -l <archname>
+
+ -> To turn on verbose mode use -v option
+
+ -> To get some examples:
+
+ wpack -examples
+
+ }
+ return
+}
+
+proc wpack:examples { } {
+ puts stderr \
+ {
+ Examples:
+
+ To pack the full workbench MDL:k4dev:ref in file /tmp/update.bck:
+ > wpack -c MDL:k4dev:ref -f /tmp/send.bck
+
+ To pack all interface and engine of current workbench in directory /tmp/transfert:
+ > wpack -c -d /tmp/transfert -t interface,engine
+
+ To restore the file /tmp/update.bck.Z in workbench FAC:WS:WB
+ > wcreate FAC:WS:WB ... ( if applicable )
+ > wpack -r FAC:WS:WB -f /tmp/update.bck.Z
+
+ To download in the current workbench, the units of delivery KERNEL-B4-1:
+ > wpack -r -p MYFACT:MYBAG:KERNEL-B4-1
+
+ To pack all sources and units modified since the mark REL1.1 (See wnews for marks)
+ > wprepare -since REL1.1 -o /tmp/update-report
+ > ... Comments report file /tmp/update-report ... (See also wnews -comments)
+ > wpack -rep /tmp/update-report -f /tmp/update.bck
+ > ... Send update.bck with mail or Internet facilities..
+
+ To restore the previous update file in a workbench named WBUPD.
+ > wcreate WBUPD -f ...
+ > wokcd FACT:SHOP:WBUPD
+ > wpack -r -f /tmp/update.bck
+ All units will be created and automatically filled in with the source files.
+
+ To restore the previous update in a integration queue ( See also command wstore)
+ > wstore -ar /tmp/update.bck
+
+ To pack a workbench FAC1:SHOP1:WB1, then restore it in an other workshop queue
+ named FAC2:SHOP2.
+ > wokcd FAC1:SHOP1
+ > wpack -c WB1 -f /tmp/arch.bck
+ > wokcd FAC2:SHOP2
+ > wstore -ar /tmp/arch.bck
+
+
+ }
+}
+proc wpack { args } {
+
+ ;# Options
+ ;#
+ set tblreq(-h) {}
+ set tblreq(-examples) {}
+ set tblreq(-c) default
+ set tblreq(-r) {}
+ set tblreq(-v) {}
+ set tblreq(-d) value_required:string
+ set tblreq(-f) value_required:string
+ set tblreq(-p) value_required:string
+ set tblreq(-t) value_required:list
+ set tblreq(-u) value_required:list
+ set tblreq(-l) {}
+
+ set tblreq(-rep) value_required:string
+
+ set disallow(-d) {-f}
+ set disallow(-d) {-p}
+ set disallow(-c) {-r}
+ ;# Parameters
+ ;#
+ set param {}
+
+ if { [wokUtils:EASY:GETOPT param table tblreq wpack_usage $args] == -1 } return
+ if { [wokUtils:EASY:DISOPT table disallow wpack_usage ] == -1 } return
+
+ if { [info exists table(-h)] } {
+ wpack_usage
+ return
+ }
+ if { [info exists table(-examples)] } {
+ wpack:examples
+ return
+ }
+
+ set verbose [info exists table(-v)]
+
+ if { [info exists table(-rep)] } {
+ if { [info exists table(-f)] } {
+ set Zadr $table(-f)
+ if ![catch {set idar [open $Zadr w]} status] {
+ wokStore:Report:Pack $idar $table(-rep) $verbose
+ close $idar
+ wokUtils:FILES:compress $Zadr
+ msgprint -i "File ${Zadr}.Z has been created."
+ } else {
+ puts stderr "$status"
+ }
+ } else {
+ wpack_usage
+ }
+ return
+ }
+
+
+ if { [info exists table(-l)] } {
+ set Zadr [lindex $param 0]
+ set adr [wokUtils:FILES:SansZ $Zadr]
+ if { $adr != -1} {
+ if ![catch {set idar [open $adr r]} status] {
+ wpack:LsFold $idar {}
+ close $idar
+ } else {
+ puts stderr "Error: $status"
+ }
+ if [file exists $adr] {
+ catch {unlink $adr}
+ }
+ }
+ return
+ }
+
+
+ set typsel *
+ if { [info exists table(-t)] } {
+ set typsel $table(-t)
+ }
+
+ set namsel *
+ if { [info exists table(-u)] } {
+ set namsel $table(-u)
+ }
+
+ set Wadr [lindex $param 0]
+ if { $Wadr == {} } {
+ set Wadr [wokcd]
+ }
+ set Wadr [wokinfo -w $Wadr]
+
+ if { [info exists table(-c)] } {
+ set ulist [wpack:UF [w_info -a $Wadr] $namsel $typsel]
+ if { $ulist == {} } {
+ msgprint -w "No units selected."
+ return
+ }
+ if { [info exists table(-f)] } {
+ set Zadr $table(-f)
+ if ![catch {set idar [open $Zadr w]} status] {
+ foreach Uadr $ulist {
+ set typ [lindex $Uadr 0]
+ set nam [lindex $Uadr 1]
+ if { $verbose } { puts -nonewline stderr "Packing $typ $nam..." }
+ puts $idar [format "=!=!=!=!=!=!=!=!=!=! %s %s" $typ $nam]
+ upack:Fold [uinfo -Fp ${Wadr}:${nam}] $idar [upack:Upackable] 0
+ if { $verbose } { puts stderr "Done" }
+ }
+ close $idar
+ wokUtils:FILES:compress $Zadr
+ msgprint -i "File ${Zadr}.Z has been created"
+ } else {
+ puts stderr "$status"
+ }
+ } elseif { [info exists table(-d)] } {
+ if { ![file exists $table(-d)] } { mkdir -path $table(-d) }
+ wpack:Fold $Wadr $ulist $table(-d) [info exists table(-v)]
+ msgprint -i "Archive files have been created in $table(-d)"
+ } else {
+ wpack_usage
+ }
+ return
+ }
+
+ if { [info exists table(-r)] } {
+ if { [info exists table(-f)] } {
+ set Zadr $table(-f)
+ set adr [wokUtils:FILES:SansZ $Zadr]
+ if { $adr != -1} {
+ if ![catch {set idar [open $adr r]} status] {
+ set dirtmp [wokUtils:FILES:tmpname {}]
+ set savwd [wokcd]
+ wpack:UnFold $idar $Wadr stderr $dirtmp {} $verbose
+ close $idar
+ wokcd $savwd
+ } else {
+ puts stderr "Error: $status"
+ }
+ if [file exists $adr] {
+ catch {unlink $adr}
+ }
+ }
+ } else {
+ if { [info exists table(-d)] } {
+ set Dadr $table(-d)
+ } else {
+ set Dadr [pwd]
+ }
+ if { [info exists table(-p)] } {
+ set ULadr $table(-p)
+ set Dadr [wokinfo -p sourcedir:. $table(-p)]
+ }
+ if { ![file exists $Dadr] } {
+ msgprint -e "Directory $Dadr not found."
+ return
+ }
+ if { [set LZ [wpack:LZ [glob $Dadr/*.*.Z] $namsel $typsel]] != {} } {
+ set savwokcd [wokcd]
+ foreach e2 [ucreate -P $Wadr] {
+ set LtoS([lindex $e2 1]) [lindex $e2 0]
+ }
+ set l_ud [w_info -l $Wadr]
+ foreach z $LZ {
+ set x [split [file tail $z] .]
+ set nam [lindex $x 0]
+ set typ [lindex $x 1]
+ if { [lsearch $l_ud $nam] == -1 } {
+ ucreate -$LtoS($typ) ${Wadr}:${nam}
+ }
+ if { $verbose } { msgprint -i "Unpacking file $z" }
+ wokcd ${Wadr}:${nam}
+ upack -r $z
+ }
+ wokcd $savwokcd
+ } else {
+ msgprint -e "No match in directory $Dadr."
+ }
+ }
+ return
+ }
+
+ wpack_usage
+
+}
+;#
+;# Filtre les UDs demandees avec -u et -t
+;# l2 liste des UDs a filtrer. (w_info)
+;# lu liste de ce qu'il y a derriere -u
+;# lt liste de ce qu'il y a derriere -t
+;#
+proc wpack:UF { l2 lu lt } {
+ set l {}
+ foreach u $lu {
+ foreach t $lt {
+ foreach e2 $l2 {
+ set typ [lindex $e2 0]
+ set nam [lindex $e2 1]
+ if { [string match $u $nam] && [string match $t $typ] } {
+ lappend l $e2
+ }
+ }
+ }
+ }
+ return $l
+}
+;#
+;# Filtre les UDs demandees avec -u et -i
+;# l1 liste des UDs a filtrer. (glob)
+;# lu liste de ce qu'il y a derriere -u
+;# lt liste de ce qu'il y a derriere -t
+;#
+proc wpack:LZ { l1 lu lt } {
+ set l {}
+ foreach u $lu {
+ foreach t $lt {
+ foreach e1 $l1 {
+ if { [string match ${u}.${t}.Z [file tail $e1] ] } {
+ lappend l $e1
+ }
+ }
+ }
+ }
+ return $l
+}
+;#
+;# Crees les archives a partir de ulist et les met dans Dadr.
+;#
+proc wpack:Fold { Wadr ulist Dadr {verbose 0 } } {
+ foreach e2 [lsort $ulist] {
+ set typ [lindex $e2 0]
+ set nam [lindex $e2 1]
+ if { $verbose } { msgprint -i "Creating file $Dadr/$nam.${typ}.Z" }
+ upack -f -c ${Wadr}:${nam} -o $Dadr/$nam.${typ}
+ }
+
+ return
+}
+#
+# Listing d'un backup de workbench
+#
+# FileId (entree) descripteur de l'archive
+#
+proc wpack:LsFold { fileid {typsel {}} } {
+ set lst [llength $typsel]
+ while {[gets $fileid line] >= 0 } {
+ if { [regexp {^=\+=\+=\+=\+=\+=\+=\+=\+=\+=\+ ([^ ]*) ([^ ]*)} $line ignore type name] } {
+ if { ($lst == 0) || ( ($lst != 0) && ([lsearch $typsel $type] != -1)) } {
+ msgprint -i "$type $name"
+ }
+ } elseif {[regexp {^=!=!=!=!=!=!=!=!=!=! ([^ ]*) ([^ ]*)} $line ignore type name]} {
+ msgprint -i ">> $type $name"
+ }
+ }
+ return
+}
+;#
+;# Cree dans le workbench Wadr les Uds packes dans le fichier pointe par fileid
+;#
+proc wpack:UnFold { fileid Wadr errlog errdir {typsel {}} verbose } {
+ set lu {}
+ set lst [llength $typsel]
+ foreach e2 [ucreate -P $Wadr] {
+ set LtoS([lindex $e2 1]) [lindex $e2 0]
+ }
+ set l_ud [w_info -l $Wadr]
+ while {[gets $fileid line] >= 0 } {
+ if { [regexp {^=\+=\+=\+=\+=\+=\+=\+=\+=\+=\+ ([^ ]*) ([^ ]*)} $line ignore type name] } {
+ if [info exist fileout] {catch {close $fileout; unset fileout } }
+ if ![string match report-* $type] {
+ if { ($lst == 0) || ( ($lst != 0) && ([lsearch $typsel $type] != -1)) } {
+ set retval [upack:GetBackupName $type $name]
+ if { $retval != -1 } {
+ set filename $retval
+ } else {
+ puts $errlog "Error: Item $line not processed"
+ set filename $errdir/notdone
+ }
+ if {[string compare [file extension $retval] .U] == 0 } {
+ lappend lu $retval
+ }
+ if ![catch { set fileout [open $filename w] } errout] {
+ if { $verbose } { msgprint -i "Creating $filename" }
+ } else {
+ msgprint -e "$errout"
+ return -1
+ }
+ }
+ } else {
+ if ![catch { set fileout [open [pwd]/$name w] } errout] {
+ msgprint -i "Creating [pwd]/$name"
+ } else {
+ msgprint -e "$errout"
+ return -1
+ }
+ }
+ } elseif {[regexp {^=!=!=!=!=!=!=!=!=!=! ([^ ]*) ([^ ]*)} $line ignore typ nam]} {
+ if ![string match report-* $typ] {
+ if { [lsearch $l_ud $nam] == -1 } {
+ ucreate -$LtoS($typ) ${Wadr}:${nam}
+ if { $verbose } { msgprint -i "Creating $typ $nam " }
+ }
+ wokcd $nam
+ }
+ } else {
+ if [info exist fileout] {
+ puts $fileout $line
+ }
+ }
+
+ }
+ if [info exist fileout] {catch {close $fileout; unset fileout } }
+ foreach u $lu {
+ puts -nonewline stderr "Decoding $u ..."
+ wokUtils:FILES:uudecode $u
+ unlink $u
+ puts stderr "Done"
+ }
+ return
+}
--- /dev/null
+/* XPM */
+static char * warehouse_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"19 19 7 1 0 0",
+/* colors */
+" s none m none c none",
+". s iconColor1 m black c black",
+"X c #CCCCBFBFAAAA",
+"o c #66668080AAAA",
+"O c #9999BFBFFFFF",
+"+ c #999980805555",
+"@ s iconColor2 m white c white",
+/* pixels */
+" ",
+" ",
+" ",
+" .XXXXXXXXXo. ",
+" OXOXOXOXO.o ",
+" ............o+ ",
+" .@XO.OX.X.X.oo ",
+" .@XXXXXXXXX.o+ ",
+" .@XO.@..XOX.oo ",
+" .@X.@+.@..X.o+ ",
+" .@X@.oo...X.oo ",
+" .@X.@+.@..X.o+ ",
+" .@XO.@..X...oo ",
+" .@XXX..XXXX.o+ ",
+" .@XOXOXOXOX.oo ",
+" .@XX.XX.X.X.. ",
+" .Oooooooooo. ",
+" o +. ",
+" . .. "};
--- /dev/null
+
+ Workbench Builder
+
+ Menus:
+
+ <File>
+ <Profile ...> : changes the compilation and database profiles.
+ <Load Cfg ...> : loads a specific configuration for a given workbench.
+ <Save Cfg ...> : saves the current configuration.
+ <Save Log ...> : saves the text in the build window into a file.
+ <Set crontab ...> : gives the configuration of the 'cron' table on the current station.
+ <Close...> : ends the build process.
+
+ <Help>
+ <Help ...> : this help.
+ <About ...> : displays the version of the 'Workbench Builder'.
+
+ Buttons:
+
+ <Build> : builds the units contained in the right window.
+ <Show Commands> : displays in the build window the commands performed.
+ <Previous Error> : positions the build window on the previous error.
+ <Next Error> : positions the build window on the next error.
+ <Errors to Emacs> : sends compilation errors to an Emacs buffer.
+ <Break> : stops the building process at the end of the current command.
+
+ <Force> : push the button to perform the umake commands with the '-f' parameter.
+ <Add All> : adds all the units from the selection window [left window] to the
+ right window.
+ <Keep Failed> : deselects all the units with no error.
+ <Del All> : deselects all the units.
+
+
+
+ Input area <Name>:
+
+ The input area is located below the selection window. It is used to filter units according to
+ their name.
+ Example: If you type the letter 'A' then space, only the selection units beginning with an 'A'
+ remain displayed in the window.
+
+
+ Selection window:
+
+ Click on the unit types (src, xcpp, obj, lib, ccl, exec, frontal, delivery) in the list provided
+ to display the menu used to filter units according to their type.
+
+
+ Profile button:
+
+ The profile button is located in the top right corner of the window with the current compilation
+ and database profiles.
+ Push the profile button to display the profile selection window.
+
--- /dev/null
+/* XPM */
+static char * wbuild_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"32 32 5 1 0 0",
+/* colors */
+" s iconGray4 m white c #949494949494",
+". s iconColor1 m black c black",
+"X c #BEBEBEBEBEBE",
+"o s iconColor5 m black c blue",
+"O c #A0A052522D2D",
+/* pixels */
+" ",
+" ",
+" ",
+" ... ... ....... ",
+" .X. .XX...XXXXXXX. ",
+" .X. .XXXXXXXoooXXX. ",
+" .XXX. .XXXXXXoooXXXXX. ",
+" .XXX. .XX...XXXXX..XXX. ",
+" .X. ... ..... .XX. ",
+" .X. .X. .X. ",
+" .X. .X. .. ",
+" .X. .X. ",
+" .X. .X. ",
+" .X. .X. ",
+" .X. .X. ",
+" .X. .X. ",
+" ... ... ",
+" .OOO. .OOO. ",
+" .OOOOO. .OOOOO. ",
+" .O.O.O. .O.O.O. ",
+" .O.O.O. .O.O.O. ",
+" .O.O.O. .O.O.O. ",
+" .O.O.O. .O.O.O. ",
+" .O.O.O. .O.O.O. ",
+" .O.O.O. .O.O.O. ",
+" .O.O.O. .O.O.O. ",
+" .O.O.O. .O.O.O. ",
+" .O.O.O. .O.O.O. ",
+" .O.O.O. .O.O.O. ",
+" .OOOOO. .OOOOO. ",
+" .OOO. .OOO. ",
+" ... ... "};
--- /dev/null
+
+#############################################################################
+#
+# W C H E C K
+# ___________
+#
+#############################################################################
+#
+# Usage
+#
+proc wokCheckUsage { } {
+ puts stderr {Usage : wcheck [-t SCCS|RCS] [-report [filename] [file1 file2 ...]}
+ puts stderr ""
+ puts stderr { wcheck filename : Check that file1 file2 ..can be placed in repository.}
+ puts stderr { -report to enter a report file <filename> created by wprepare}
+ return
+}
+
+proc wcheck { args } {
+ set tblreq(-h) {}
+ set tblreq(-s) {}
+ set tblreq(-report) value_required:string
+ set tblreq(-diff) {}
+ set tblreq(-dir) value_required:string
+
+ set param {}
+ if { [wokUtils:EASY:GETOPT param tabarg tblreq wokCheckUsage $args] == -1 } return
+
+ if { [info exists tabarg(-h)] } {
+ wokCheckUsage
+ return
+ }
+
+ if [info exists tabarg(-diff)] {
+ if [info exists tabarg(-dir)] {
+ set dir(-dir)
+ wcheck_diff $param $dir
+ } else {
+ wokCheckUsage
+ }
+ return
+ }
+
+ set BTYPE SCCS
+ if [info exists tabarg(-t)] {
+ set BTYPE $tabarg(-t)
+ }
+
+ set silent [info exists tabarg(-s)]
+
+ set tmpdir /tmp/wcheck[id process]
+ if [file exists $tmpdir] {
+ unlink [glob -nocomplain $tmpdir/*]
+ } else {
+ mkdir -path $tmpdir
+ }
+
+ set LFILE {}
+ if { [info exists tabarg(-report)] } {
+ set ID $tabarg(-report)
+ catch { unset table banner notes }
+ wokPrepare:Report:Read $ID table banner notes
+ foreach e [lsort [array names table]] {
+ foreach l $table($e) {
+ set str [wokUtils:LIST:Trim $l]
+ lappend LFILE [lindex $str 4]/[lindex $str 3]
+ }
+ }
+ } else {
+ eval set LFILE $param
+ }
+
+ switch -- $BTYPE {
+
+ SCCS {
+ set vrs 1
+ foreach file $LFILE {
+ update
+ set sfile $tmpdir/s.[file tail $file]
+ if { [catch { exec admin -i$file -r$vrs -yCheck $sfile } status ] == 0 } {
+ if { !$silent } {msgprint -c WOKVC -i "$file is OK."}
+ } else {
+ if { "$status" == "No id keywords (cm7)" } {
+ if { !$silent } { msgprint -c WOKVC -i "$file is OK"}
+ } else {
+ msgprint -c WOKVC -e "$file cannot be created ( $status )"
+ }
+ }
+ catch {unlink $sfile}
+ }
+ }
+
+ RCS {
+ msgprint -c WOKVC -e "Not yet implemented"
+ }
+
+ default {
+ msgprint -c WOKVC -e "Unknown base type. Should be SCCS or RCS"
+ }
+
+ }
+
+ catch {
+ if [file exists $tmpdir] {
+ unlink [glob -nocomplain $tmpdir/*]
+ }
+ unlink $tmpdir
+ }
+
+ return
+}
+
+proc wcheck_diff { param dir } {
+ ;#puts $param
+ ;#puts $dir
+ return
+}
+
+
--- /dev/null
+;# This procedure is called when using the command:
+;#
+;# wnews -x -from n1 -to n2 -proc MyProc where n1 and n2 are two digits
+;#
+;# Entries in MYTABLE are unit and type names on the form Unit.type.
+;#
+;# Each item in MYTABLE is a list with the the following format:
+;#
+;# Example:
+;# MYTABLE(WOKMake.p) = {Modified { WOKUMake.edl 1.2}} {Modified { WOKUMakeStep.edl 1.2}}
+;#
+
+proc MyProc { comments table args } {
+ upvar $table MYTABLE
+ set from_wb DESIGN:k1dev:ref
+ set dest_wb DESIGN:k1fab:ref
+ set l_fab [w_info -l $dest_wb]
+ set l_ud {}
+ foreach UD [lsort [array names MYTABLE]] {
+ set x [split $UD .]
+ set name [lindex $x 0]
+ set type [lindex $x 1]
+ lappend l_ud $name
+ if { [lsearch $l_fab $name] == -1 } {
+ puts "ucreate -${type} ${dest_wb}:${name}"
+ }
+ set from_src [wokinfo -p source:. ${from_wb}:${name}]
+ set dest_src [wokinfo -p source:. ${dest_wb}:${name}]
+ set l_file {}
+ foreach item $MYTABLE($UD) {
+ set mark [lindex $item 0] ;# == Modified | Added | Deleted
+ switch -- $mark {
+
+ Modified {
+ set elem [lindex $item 1] ;# == {name.ext x.y}
+ set file [lindex $elem 0] ;#
+ set vers [lindex $item 1] ;#
+ if { [lsearch $l_file $file] == -1 } {
+ puts "Copying $file from $from_src to $dest_src"
+ ;# exec cp $from_src/$file $dest_src/$file
+ lappend l_file $file
+ }
+ }
+
+ Added {
+ }
+
+ Deleted {
+ }
+ }
+ }
+ }
+ puts " je dois recopsdsdsd $l_ud"
+ puts "comments = $comments"
+ return 1
+}
--- /dev/null
+;;; Communication and interface routines for the WOK and Emacs comm
+
+(require 'cl)
+(provide 'wok-comm)
+\f
+;;; Variables
+
+(defconst wok-comm-AtFS-Header
+ "$Header: /disk4/QA/cvsroot/test/ros/src/WOKTclLib/wok-comm.el,v 1.1 1998-09-09 18:21:42 kernel Exp $")
+
+(defvar wok-comm-initialized nil
+ "If non-nil, the Wok communication module has already been initialized.")
+
+(defvar wok-log-communication t
+ "If non-nil, the communication between Emacs and the Wok widget is
+logged in wok-log-buffer.")
+
+(defvar wok-log-buffer-name " *wok-log*"
+ "Name of the buffer where Wok communication is logged.
+Begins with a blank to be invisible.")
+
+(defvar wok-log-buffer nil
+ "Buffer where Wok communication is logged.
+If it gets killed, it will be re-created on demand.")
+
+(defvar wok-controller-input-buffer-name " *wok-input*"
+ "Name of buffer containing incoming characters, not yet processed.")
+
+(defvar wok-controller-input-queue ""
+ "Incoming lines that have not yet been processed.")
+
+(defvar wok-controller-return-buffer-name " *wok-return*"
+ "Name of buffer containing returned characters, not yet processed.")
+
+(defvar wok-controller-return-queue ""
+ "return value lines that have not yet been processed.")
+
+(defvar wok-controller-process nil
+ "Process variable of wok-controller process
+(really a network connection).")
+
+(defvar wok-controller-host nil
+ "Hostname of remote wok-controller.")
+
+(defvar wok-controller-port nil
+ "Port number of remote wok-controller.")
+
+(defvar wok-controller-connectedp nil
+ "t if connected otherwise nil.")
+
+(defvar wok-write-back-eval t
+ "If non-nil, write results of evaluations back to the wok-controller.")
+
+(defvar wok-widget-name "dummy-widget"
+ "Name of the widget we talk to in the remote wok-controller.")
+
+(defvar wok-kill-widget-on-exit nil
+ "If non-nil, Emacs kills the widget on exit.")
+
+(defvar wok-default-port "1563"
+ "Default port number for connecting to the controller,
+if not given in the command line. Mostly for testing purposes.
+Must be a string because it is used as initial input for read-string.")
+
+(defvar wok-signal-errors t
+ "If non-nil, signal errors in the process-filter to the user.
+If nil, rely on the widget to process the error.")
+
+
+;;; Functions for handling wok-controller-input-buffer
+
+(defun wok-erase-input-buffer ()
+ "Erase wok-controller-input-buffer, i.e. flush all input."
+ (save-excursion
+ (set-buffer (get-buffer-create wok-controller-input-buffer-name))
+ (erase-buffer)))
+
+
+(defun wok-queue-controller-input (string)
+ "Add input STRING to wok-controller-input-buffer."
+ (save-excursion
+ (set-buffer (get-buffer-create wok-controller-input-buffer-name))
+ (goto-char (point-max))
+ (insert string)))
+
+
+(defun wok-complete-input-line-p ()
+ "Return non-nil if a complete line is available in
+wok-controller-input-buffer."
+ (save-excursion
+ (set-buffer (get-buffer-create wok-controller-input-buffer-name))
+ ;; DEBUG POUR DEC/JGAJGA
+ ;;(goto-char 1) ; don' bother with point-min here
+ ;;(and (> (length (buffer-string)) 0) ( equal "\^J" (buffer-substring 1 2))
+ ;; (delete-char 1)
+ ;; )
+ (wok-log-to-buffer "buffer" (buffer-string))
+ (goto-char 1) ; don' bother with point-min here
+ (forward-line 1)
+ (and (bolp)
+ (not (bobp)))))
+
+
+(defun wok-get-input-line ()
+ "Return the first line from wok-controller-input-buffer and erase it there."
+ (save-excursion
+ (set-buffer (get-buffer-create wok-controller-input-buffer-name))
+ (goto-char 1)
+ (let ((end (progn (forward-line 1)
+ (point))))
+ (prog1
+ (buffer-substring 1 end)
+ (delete-region 1 end)))))
+
+;;; Functions for handling wok-controller-return-buffer
+
+(defun wok-erase-return-buffer ()
+ "Erase wok-controller-input-buffer, i.e. flush all input."
+ (save-excursion
+ (set-buffer (get-buffer-create wok-controller-return-buffer-name))
+ (erase-buffer)))
+
+
+(defun wok-queue-controller-return (string)
+ "Add input STRING to wok-controller-input-buffer."
+ (save-excursion
+ (set-buffer (get-buffer-create wok-controller-return-buffer-name))
+ (goto-char (point-max))
+ (insert string)))
+
+
+(defun wok-complete-return-line-p ()
+ "Return non-nil if a complete line is available in
+wok-controller-return-buffer."
+ (save-excursion
+ (set-buffer (get-buffer-create wok-controller-return-buffer-name))
+ (goto-char 1) ; don' bother with point-min here
+ (forward-line 1)
+ (and (bolp)
+ (not (bobp)))))
+
+
+(defun wok-get-return-line ()
+ "Return the first line from wok-controller-input-buffer and erase it there."
+ (save-excursion
+ (set-buffer (get-buffer-create wok-controller-return-buffer-name))
+ (goto-char 1)
+ (let ((end (progn (forward-line 1)
+ (point))))
+ (prog1
+ (buffer-substring 1 end)
+ (delete-region 1 end)))))
+
+\f
+;;; Functions etc. to set up, continue, and shut down communication
+;;; to the WokEmacs widget
+
+(defun wok-get-command-line-args (switch)
+ "Consume commandline arguments after \"-wokwidget\" and connect
+to remote wok-controller. Arguments are:
+ - wok-widget-name
+ - wok-controller-host
+ - wok-controller-port"
+ (if (equal switch "-wokwidget")
+ (progn
+ (setq wok-widget-name
+ (car command-line-args-left))
+ (setq wok-controller-host
+ (cadr command-line-args-left))
+ (setq wok-controller-port
+ (string-to-int (caddr command-line-args-left)))
+ (setq command-line-args-left
+ (cdddr command-line-args-left))
+ (wok-connect-to-controller wok-controller-host wok-controller-port))))
+
+
+(defun wok-connect-to-controller (host port)
+ "Establish a connection to a remote wok-controller on HOST port PORT.
+This function is a command only for testing purposes."
+ (interactive (list (read-string "To host: " "localhost")
+ (string-to-int (read-string "Port: "
+ wok-default-port))))
+ (if wok-controller-process
+ ;; there must not be two controllers
+ (error "Wok-Controller already running on host %s port %s"
+ wok-controller-host wok-controller-port)
+ ;; set up process and associated variables
+ (progn
+ (message "trying connection to host %s port %s"
+ wok-controller-host wok-controller-port)
+ (let ((retries 0))
+ (while (and (not wok-controller-process) (not (equal retries 8)))
+ (condition-case error (progn
+ (setq wok-controller-process
+ (open-network-stream "wok-controller-process" nil host port))
+ t)
+ (error
+ (progn
+ (message "Retry %d failed" retries)
+ (sleep-for 1)
+ (setq retries (+ retries 1))
+ (let ((mesg (car (cdr error))))
+ (cond
+ ((string-match "^Unknown host" mesg) nil)
+ ((string-match "not responding$" mesg) mesg)
+ ((equal mesg "connection failed")
+ (if (equal (nth 2 error) "permission denied")
+ nil ; host does not exist
+ (nth 2 error)))
+ ;; Could be "Unknown service":
+ (setq retries (+ retries 1))
+ (t (signal (car error) (cdr error))))))))))
+
+ (message "Connection established.")
+
+ (if wok-controller-process
+ (progn
+ (setq wok-controller-host host)
+ (setq wok-controller-port port)
+ (wok-erase-input-buffer)
+ (wok-erase-return-buffer)
+ (set-process-filter wok-controller-process 'wok-controller-filter)
+ (set-process-sentinel wok-controller-process 'wok-shutdown-controller)
+ ;; first handshake
+ (wok-send-return-value "Hello widget, pleased to meet you!")
+
+ (run-hooks 'wok-connect-hooks)
+
+ (setq wok-controler-connectedp t)
+ wok-controller-process)))))
+
+(defun wok-shutdown-controller (&optional proc message)
+ "Sentinel for the connection to a remote wok-controller.
+This is a command only for testing purposes.
+Since the only status change is connection loss, the only action to
+be done is cleaning up.
+Optional arguments: PROC MESSAGE.
+If PROC is nil, no message is given."
+ (interactive "p")
+ (if proc
+ (message "Wok-Controller on %s port %d shutdown."
+ wok-controller-host wok-controller-port))
+ (condition-case dummy
+ ;; this closes the network connection. Errors must be ignored,
+ ;; because the connection will already be closed if this
+ ;; function is called as the process sentinel.
+ (delete-process wok-controller-process)
+ (error nil))
+ ;; reset associated variables
+ (setq wok-controller-process nil)
+ (setq wok-controller-port nil)
+ (setq wok-controller-host nil)
+ (setq wok-controler-connectedp nil)
+ (if proc
+ ;; proc is non-nil if this function has been called as the
+ ;; sentinel or if the user wants it.
+ (ding)))
+
+
+(defun wok-controller-filter (proc string)
+ "Filter for the connection to a remote wok-controller.
+It relies on the messages coming in line by line,
+perhaps this is a bug, we'll see."
+
+ ;; log to buffer if requested
+ (wok-log-to-buffer "recv" string)
+ ;; collect a complete line first
+ (wok-queue-controller-input string)
+ ;; line complete?
+ (wok-log-to-buffer "input-line-p" (wok-complete-input-line-p))
+
+ (while (wok-complete-input-line-p)
+ (condition-case error-message
+ (let ((line (wok-get-input-line)))
+ (wok-log-to-buffer "line" line)
+ (if (< (length line) 5) ; including newline character
+ ;; line is too short
+ (progn (wok-erase-input-buffer)
+ (wok-raise-error "line too short"))
+ ;; The message type tokens are four characters long
+ (let ((token (substring line 0 4)))
+ ;; switch according to the type of token.
+ (cond ((equal token "RST:")
+ ;; reset communication. All input is flushed.
+ (setq wok-controller-input-queue "")
+ (wok-erase-input-buffer))
+
+ ((equal token "CMD:")
+ ;; command lines are collected in
+ ;; wok-controller-input-queue
+ (setq wok-controller-input-queue
+ (concat wok-controller-input-queue
+ (substring line 5))))
+
+ ((equal token "END:")
+ (cond ((> (length wok-controller-input-queue) 0)
+ ;; end of command. Now the command in
+ ;; wok-controller-input-queue can be executed
+ (let ((exp (read wok-controller-input-queue)) value)
+ ;; it is important to clear the input queue
+ ;; immmediately since the filter can be
+ ;; invoked in parallel
+ (setq wok-controller-input-queue "")
+ (setq value (eval exp))
+ ;; write result back only if requested
+ (if wok-write-back-eval
+ (wok-send-return-value value))
+ ))
+ ((> (length wok-controller-return-queue) 0)
+ (progn
+ (setq wok-return-value wok-controller-return-queue)
+ (setq wok-controller-return-queue "")
+ (setq wok-return-value-p 1)
+ ))
+ ;; (t
+ ;; (wok-raise-error "Mixed RET: and CMD: tokens"))
+ ))
+
+ ((equal token "RET:")
+ ;; should not appear (yet). Will perhaps later be
+ ;; needed.
+ (setq wok-controller-return-queue
+ (concat wok-controller-return-queue
+ (substring line 5))))
+
+ ((equal token "ERR:")
+ ;; is error message from Wok widget
+ (progn
+ (setq wok-return-value "ERR:ERR")
+ (setq wok-error-msg (substring line 5 ))
+ (ding)
+ (message "Wok error: %s"
+ (substring line 5 ))
+ (setq wok-return-value-p 1)
+ )
+ )
+
+ (t
+ ;; an unrecognized token occurred
+ (wok-raise-error (format "protocol error, token \"%s\""
+ (substring string 0 4)))
+ (setq wok-controller-input-queue "")))
+ ;; reset input line, this one has been processed.
+ (setq line ""))))
+ (quit
+ (progn (setq wok-controller-input-queue "")
+ (wok-erase-input-buffer)
+ (ding)
+ (message "Quit")
+ (wok-raise-error error-message)))
+ (error
+ ;; any error is given to controller
+ (progn (setq wok-controller-input-queue "")
+ (wok-raise-error error-message)
+ (if wok-signal-errors
+ (signal (car error-message) (cdr error-message))))))))
+
+\f
+;;; Functions to synchronize termination and redisplay
+
+(defun wok-kill-emacs ()
+ "Function for Wok to shut down the WokEmacs widget.
+For some unknown reason this must include the action which is already
+placed in kill-emacs-hook."
+ (if wok-controller-process
+ (wok-shutdown-controller))
+ ;; this must not happen twice, so reset kill-emacs-hook
+ (setq kill-emacs-hook nil)
+ (kill-emacs))
+
+
+(defun wok-advise-destroy-widget-on-exit ()
+ "Advise Emacs to destroy the widget on exit. Does not yet work.
+This is necessary for XfEmacs."
+ (setq wok-kill-widget-on-exit t))
+
+
+(defun wok-kill-emacs-hook ()
+ "To be put into kill-emacs-hook in order to guarantee proper
+shutdown of the WokEmacs widget."
+ ;; notify widget of Emacs' death
+ (if wok-kill-widget-on-exit
+ (if wok-controller-process
+ (wok-send-command (format "%s stopemacs; catch {destroy .}; catch {exit 0}" wok-widget-name))))
+ (wok-shutdown-controller))
+
+
+\f
+;;; Functions to implement the protocol between Emacs and the widget
+
+(defun wok-send-command (string)
+ "Send STRING as Tcl command to remote wok-controller."
+ (interactive "sSend Tcl command: ")
+ (progn
+ (setq wok-error-msg nil)
+ (setq wok-return-value "")
+ (setq wok-return-value-p 0)
+ (wok-send-raw-string (wok-string-format 'cmd "%s" string))
+ (while (not (= wok-return-value-p 1)) (sit-for .1))
+ (if (equal wok-return-value "ERR:ERR")
+ nil
+ wok-return-value)
+ ))
+
+
+(defun wok-send-return-value (object)
+ "Send OBJECT as a return value to the wok-controller.
+OBJECT can be any Lisp object."
+ (wok-send-raw-string (wok-string-format 'ret "%s" object)))
+
+
+(defun wok-raise-error (message)
+ "Send MESSAGE as an error message to the wok-controller."
+ (condition-case dummy
+ (wok-send-raw-string (wok-string-format 'err "%s" message))
+ (error nil)))
+
+
+(defun wok-send-raw-string (string)
+ "Send STRING to remote wok-controller. Do not use this
+unless you really know what you are doing, since this function
+lies below the protocol between Emacs and the wok-controller."
+ (if wok-controller-process
+ (progn (process-send-string wok-controller-process string)
+ (wok-log-to-buffer "send" string))))
+
+
+(defun wok-string-format (type &rest format-args)
+ "Format string suitable for transmission to the wok widget.
+TYPE may be 'ret or 'cmd or 'err, remaining FORMAT-ARGS are
+processed by format."
+ (let ((tmp-buffer (get-buffer-create " *wok-temp-send*"))
+ (header (cdr (or (assoc type '((ret . "RET: ")
+ (cmd . "CMD: ")
+ (rst . "RST: ")
+ (err . "ERR: ")))
+ (error "Wrong TYPE parameter %s" type)))))
+ (save-excursion
+ ;; insert formatted string into a buffer
+ (set-buffer tmp-buffer)
+ (erase-buffer)
+ (insert (apply 'format format-args))
+ (goto-char 0)
+ ;; insert appropriate header at line beginnings
+ (while (not (eobp))
+ (insert header)
+ (forward-line 1))
+ ;; if the last char was a newline, another header is needed
+ (if (bolp)
+ (insert header))
+ (insert (if (eq type 'err)
+ "\n"
+ "\nEND:\n"))
+ ;; return string
+ (buffer-string))))
+
+
+(defun wok-log-to-buffer (where string)
+ "Log communication to buffer, if wok-log-communication is non-nil.
+WHERE is \"recv\" or \"send\", STRING is the message.
+See also wok-log-buffer and wok-log-buffer-name."
+ (if wok-log-communication
+ (save-excursion
+ (set-buffer (get-buffer-create wok-log-buffer-name))
+ (goto-char (point-max))
+ (insert (format "##%s: %s##\n" where string)))))
+
+\f
+;;; init
+
+(defun wok-connectedp ()
+ (if wok-controller-process
+ t
+ nil)
+ )
+
+
+(defun wok-initialize-communication ()
+ "Initialize certain variables and functions for the communication
+with the WokEmacs widget."
+ (if (not wok-comm-initialized)
+ (progn
+ ;; the "-wokwidget" switch must be parsed by wok-get-command-line-args
+ (setq command-switch-alist
+ (cons '("-wokwidget" . wok-get-command-line-args)
+ command-switch-alist))
+ (setq wok-comm-initialized t)
+ (run-hooks 'wok-initialization-hooks))))
+
+
+;;; end of file
+
+
+
+(wok-initialize-communication)
--- /dev/null
+proc wokDelete { dir location } {
+ global IWOK_GLOBALS
+ set w [string tolower .wokDelete:${location}]
+ if [winfo exists $w ] {
+ wm deiconify $w
+ raise $w
+ return
+ }
+
+ toplevel $w ; wm geometry $w 517x411+453+44
+ menubutton $w.file -menu $w.file.m -text File -underline 0 -takefocus 0
+ menu $w.file.m
+ $w.file.m add command -label "Close " -underline 1 -command [list wokDelete:Cancel $w]
+
+ ;# -- label --
+ frame $w.top -relief raised -bd 1
+ label $w.top.lab
+ set img [image create compound -window $w.top.lab]
+ $img add space -width 10
+ $img add image -image [tix getimage danger]
+ $img add space -width 10
+ $img add text -text "Really do that ??"
+ pack $w.top.lab -expand 1 -fill both
+ ;# -- end label --
+
+ ;# -- paned listbox et text --
+ frame $w.mid -relief raised -bd 1
+ tixPanedWindow $w.mid.pane -orient vertical -paneborderwidth 0 -separatorbg gray50
+ pack $w.mid.pane -side top -expand yes -fill both -padx 1 -pady 1
+ set p1 [$w.mid.pane add list -min 70 -size 200]
+ set p2 [$w.mid.pane add text -min 70]
+ tixScrolledHList $p1.list ; set hlist [$p1.list subwidget hlist]
+ tixScrolledText $p2.text ;
+ set text [$p2.text subwidget text]
+ $text config -font $IWOK_GLOBALS(font)
+ pack $p1.list -expand yes -fill both -padx 1 -pady 1
+ pack $p2.text -expand yes -fill both -padx 1 -pady 1
+ ;# -- paned listbox et text --
+
+ ;# -- bouton confirm --
+ frame $w.bot -relief raised -bd 1
+ tixButtonBox $w.bot.but -orientation horizontal -relief flat -padx 0 -pady 0
+ pack $w.bot.but -expand yes -fill both -padx 1 -pady 1
+ $w.bot.but add confirm -text "Confirm"
+
+ $w.bot.but subwidget confirm config -state active -comm \
+ [list wokDelete:Confirm $hlist $text $w $w.bot.but]
+ $w.bot.but add cancel -text "Cancel" ;
+ $w.bot.but subwidget cancel config -state active -comm [list wokDelete:Cancel $w]
+ ;# -- end bouton confirm --
+
+ tixForm $w.file
+ tixForm $w.top -top $w.file -left 2 -right %99
+ tixForm $w.mid -top $w.top -left 2 -right %99 -bottom $w.bot
+ tixForm $w.bot -left 2 -right %99 -bottom %99
+
+ tixBusy $w on
+ update
+ if [wokinfo -x $location] {
+ set lrm {}
+ foreach x [wokFind $location] {
+ set type [wokinfo -t $x]
+ if {"$type" == "factory"} {set cmd "frm $x"}
+ if {"$type" == "workshop"} {set cmd "srm $x"}
+ if {"$type" == "workbench"} {set cmd "wrm $x"}
+ if {"$type" == "devunit"} {set cmd "urm $x"}
+ $hlist add $cmd -text $cmd -data [list $cmd $type] -state disabled
+ }
+ }
+ $w.top.lab config -image $img
+ tixBusy $w off
+ return
+}
+
+proc wokDelete:Confirm { hlist text tpl but } {
+ tixBusy $tpl on
+ update
+ $but subwidget cancel configure -state disabled
+ msgsetcmd wokMessageInText $text
+ set listdel {}
+ foreach itm [$hlist info children] {
+ set data [$hlist info data $itm]
+ set cmd [lindex $data 0]
+ set typ [lindex $data 1]
+ if ![ catch { eval $cmd } helas ] {
+ $hlist delete entry $cmd
+ lappend listdel $data
+ } else {
+ msgprint -e "$helas"
+ break
+ }
+ }
+ set listloc {}
+ if { $listdel != {} } {
+ foreach itm $listdel {
+ lappend listloc [list [lindex [split [lindex $itm 0]] 1] [lindex $itm 1]]
+ }
+ }
+ wokNAV:Tree:Del $listloc
+ msgunsetcmd
+ tixBusy $tpl off
+ destroy $tpl
+ return
+}
+
+
+proc wokDelete:Cancel { w } {
+ destroy $w
+ return
+}
--- /dev/null
+
+ Key definitions:
+
+ [1] Clicking mouse button 1 positions the insertion cursor just before the character underneath
+ the mouse cursor, sets the input focus to this widget, and clears any selection in the widget.
+ Dragging with mouse button 1 strokes out a selection between the insertion cursor and the
+ character under the mouse.
+
+ [2] Double mouse button 1 selects the word under the mouse and positions the insertion cursor at
+ the beginning of the word. Dragging after a double click will stroke out a selection consisting
+ of whole words.
+
+ [3] Triple-clicking button 1 selects the line under the mouse and positions the insertion cursor
+ at the beginning of the line. Dragging after a triple click will stroke out a selection which
+ consists of whole lines.
+
+ [4] The ends of the selection can be adjusted by dragging with mouse button 1 while the Shift
+ key is down; this will adjust the end of the selection that was nearest to the mouse cursor when
+ button 1 was pressed.
+ If the button is double-clicked before dragging then the selection will be adjusted in units of
+ whole words; if it is triple-clicked then the selection will be adjusted in units of whole lines.
+
+ [5] Clicking mouse button 1 with the Control key down will reposition the insertion cursor
+ without affecting the selection.
+
+ [6] If any normal printing characters are typed, they are inserted at the point of the insertion
+ cursor.
+
+ [7] The view in the widget can be adjusted by dragging with mouse button 2. If mouse button 2 is
+ clicked without moving the mouse, the selection is copied into the text at the position of the
+ mouse cursor.
+ The Insert key also inserts the selection, but at the position of the insertion cursor.
+
+ [8] If the mouse is dragged out of the widget while button 1 is pressed, the entry will
+ automatically scroll to make more text visible (if there is more text offscreen on the side
+ where the mouse left the window).
+
+ [9] The Left and Right keys move the insertion cursor one character to the left or right;
+ they also clear any selection in the text. If Left or Right is typed with the Shift key down,
+ then the insertion cursor moves and the selection is extended to include the new character.
+ Control-Left and Control-Right move the insertion cursor by words, and Control-Shift-Left and
+ ControlShift-Right move the insertion cursor by words and also extend the selection.
+ Control-b and Control-f behave the same as Left and Right, respectively.
+ Meta-b and Meta-f behave the same as Control-Left and ControlRight, respectively.
+
+ [10] The Up and Down keys move the insertion cursor one line up or down and clear any selection
+ in the text. If Up or Right is typed with the Shift key down, then the insertion cursor moves
+ and the selection is extended to include the new character.
+ Control-Up and Control-Down move the insertion cursor by paragraphs (groups of lines separated by
+ blank lines), and Control-Shift-Up and Control-Shift-Down move the insertion cursor by paragraphs
+ and also extend the selection.
+ Control-p and Control-n behave the same as Up and Down, respectively.
+
+ [11] The Next and Prior keys move the insertion cursor forward or backwards by one screenful and
+ clear any selection in the text. If the Shift key is held down while Next or Prior is typed, then
+ the selection is extended to include the new character. Control-v moves the view down one
+ screenful without moving the insertion cursor or adjusting the selection.
+
+ [12] Control-Next and Control-Prior scroll the view right or left by one page without moving the
+ insertion cursor or affecting the selection.
+
+ [13] Home and Control-a move the insertion cursor to the beginning of its line and clear any
+ selection in the widget. Shift-Home moves the insertion cursor to the beginning of the line and
+ also extends the selection to that point.
+
+ [14] End and Control-e move the insertion cursor to the end of the line and clear any selection
+ in the widget. Shift-End moves the cursor to the end of the line and extends the selection to
+ that point.
+
+ [15] Control-Home and Meta-< move the insertion cursor to the beginning of the text and clear
+ any selection in the widget. Control-Shift-Home moves the insertion cursor to the beginning of
+ the text and also extends the selection to that point.
+
+ [16] Control-End and Meta-> move the insertion cursor to the end of the text and clear any
+ selection in the widget. Control-Shift-End moves the cursor to the end of the text and extends
+ the selection to that point.
+
+ [17] The Select key and Control-Space set the selection anchor to the position of the insertion
+ cursor. They don't affect the current selection. Shift-Select and Control-Shift-Space adjust the
+ selection to the current position of the insertion cursor, selecting from the anchor to the
+ insertion cursor if there was not any selection previously.
+
+ [18] Control-/ selects the entire contents of the widget.
+
+ [19] Control-\ clears any selection in the widget.
+
+ [20] The F16 key (labelled Copy on many Sun workstations) or Meta-w copies the selection in the
+ widget to the clipboard, if there is a selection.
+
+ [21] The F20 key (labelled Cut on many Sun workstations) or Control-w copies the selection in the
+ widget to the clipboard and deletes the selection. If there is no selection in the widget then
+ these keys have no effect.
+
+ [22] The F18 key (labelled Paste on many Sun workstations) or Control-y inserts the contents of
+ the clipboard at the position of the insertion cursor.
+
+ [23] The Delete key deletes the selection, if there is one in the widget.
+ If there is no selection, it deletes the character to the right of the insertion cursor.
+
+ [24] Backspace and Control-h delete the selection, if there is one in the widget. If there is no
+ selection, they delete the character to the left of the insertion cursor.
+
+ [25] Control-d deletes the character to the right of the insertion cursor.
+
+ [26] Meta-d deletes the word to the right of the insertion cursor.
+
+ [27] Control-k deletes from the insertion cursor to the end of its line; if the insertion cursor
+ is already at the end of a line, then Control-k deletes the newline character.
+
+ [28] Control-o opens a new line by inserting a newline character in front of the insertion cursor
+ without moving the insertion cursor.
+
+ [29] Meta-backspace and Meta-Delete delete the word to the left of the insertion cursor.
+
+ [30] Control-x deletes whatever is selected in the text widget.
+
+ [31] Control-t reverses the order of the two characters to the right of the insertion cursor.
+
--- /dev/null
+;#
+;# charge file dans widget texte.
+;#
+proc wokEDF:iwok_editor { file } {
+ set w [wokTPL [id user][id host]$file]
+ if [winfo exists $w] {
+ wm deiconify $w
+ raise $w
+ return
+ }
+ set fnt [tix option get fixed_font]
+ toplevel $w
+ wm title $w "$file"
+
+ tixScrolledText $w.text ; set texte [$w.text subwidget text]
+ $texte config -font $fnt
+
+ menubutton $w.file -menu $w.file.m -text File -underline 0 -takefocus 0
+ menu $w.file.m
+ $w.file.m add command -label "Close " -underline 1 -command "destroy $w"
+
+ menubutton $w.hlp -menu $w.hlp.menu -text "Help"
+ menu $w.hlp.menu
+ $w.hlp.menu add command -label "Help" -command [list wokEDF:Help $w]
+
+ menubutton $w.edit -menu $w.edit.m -text Edit -underline 0 -takefocus 0
+ menu $w.edit.m
+ $w.edit.m add command -label "Search" -command [list wokSEA $texte]
+
+ frame $w.top -relief sunken -bd 1
+ label $w.lab -relief raised
+
+ if [ file writable $file] {
+ $w.file.m add command -label "Save" -underline 1 -command [list wokEDF:Save $texte $file]
+ }
+
+
+ tixForm $w.file -top 0
+ tixForm $w.edit -left $w.file -top 0
+ tixForm $w.hlp -right -0 -top 0
+ tixForm $w.top -top $w.file -left 2 -right %99
+ tixForm $w.text -left 2 -top $w.top -bottom $w.lab -right %99
+ tixForm $w.lab -left 2 -right %99 -bottom %99
+
+ wokReadFile $texte $file 1.0
+ update
+ return
+}
+
+proc wokEDF:Save { text file } {
+ if [file writable $file] {
+ wokTextToFile $text $file
+ }
+ return
+}
+;#
+;# envoie l'editeur charge par wokEDF:EDITOR
+;#
+proc wokEDF:EditFile { file } {
+ global IWOK_GLOBALS
+
+ if ![ info exists IWOK_GLOBALS(EDF,EDITOR)] {
+ set IWOK_GLOBALS(EDF,EDITOR) [wokEDF:EDITOR]
+ }
+
+ switch -- $IWOK_GLOBALS(EDF,EDITOR) {
+
+ connected_emacs {
+ wokemacs findfile $IWOK_GLOBALS(EDF,clients) $file
+ }
+
+ iwok_editor {
+ wokEDF:iwok_editor $file
+
+ }
+
+ default {
+ if { "file tail $IWOK_GLOBALS(EDF,EDITOR)" == "vi" } {
+ catch { exec xterm -T $file -e $IWOK_GLOBALS(EDF,EDITOR) $file & }
+ } else {
+ catch { eval exec $IWOK_GLOBALS(EDF,EDITOR) $file & }
+ }
+ }
+
+ }
+ return
+}
+;#
+;# Retourne de quoi editer un fichier
+;# 1. connected_emacs si la session courante provient d'un emacs connecte dans ce cas
+;# la variable IWOK_GLOBALS(EDF,clients) contient le numero de la connexion
+;# 2. la valeur de la V.E. EDITOR si elle existe
+;# 3. iwok_editor dans tous les autres cas (avec iwok_editor = widget text !!!)
+;#
+proc wokEDF:EDITOR { } {
+ global env
+ global IWOK_GLOBALS
+ global tcl_platform
+ set cnx [wokemacs clients]
+ if { $cnx != {} } {
+ set IWOK_GLOBALS(EDF,clients) $cnx
+ return connected_emacs
+ } else {
+ if { "$tcl_platform(platform)" == "unix" } {
+ if {[info exists env(EDITOR)]} {
+ return $env(EDITOR)
+ } else {
+ return iwok_editor
+ }
+ } else {
+ return iwok_editor
+ }
+ }
+}
+;#
+;# Help
+;#
+proc wokEDF:Help { w } {
+ global IWOK_GLOBALS
+ global env
+ set whelp [wokHelp [set IWOK_GLOBALS(EDF,help) .wokEDFHelp] "About iwok editor"]
+ set texte [lindex $whelp 0] ; set label [lindex $whelp 1]
+ if {[info exist IWOK_GLOBALS(windows)]} {
+ if {[lsearch $IWOK_GLOBALS(windows) .wokEDFHelp ] == -1} {
+ lappend IWOK_GLOBALS(windows) .wokEDFHelp
+ }
+ }
+ wokReadFile $texte $env(WOK_LIBRARY)/wokEDF.hlp
+ wokFAM $texte <.*> { $texte tag add big first last }
+
+ $texte tag configure big -background Bisque3 -foreground black -borderwidth 2 \
+ -font -Adobe-Helvetica-Medium-R-Normal--*-120-* -relief raised
+
+ $texte configure -state disabled
+ update
+ return
+}
+
+;#
+;#
+;#
+proc wokEDF:Archive { file args } {
+ set w [wokTPL [id user][id host]$file]
+ if [winfo exists $w] {
+ wm deiconify $w
+ raise $w
+ return
+ }
+ set fnt [tix option get fixed_font]
+ toplevel $w
+ wm title $w "Contents of archive $file"
+
+ wokButton setw [list archive $w]
+
+ menubutton $w.file -menu $w.file.m -text File -underline 0 -takefocus 0
+ menu $w.file.m
+ $w.file.m add command -label "Close " -underline 1 -command "destroy $w"
+
+ frame $w.top -relief sunken -bd 1
+ label $w.lab -relief raised
+
+ tixScrolledText $w.text ; set texte [$w.text subwidget text]
+ $texte config -font $fnt -cursor {hand2 red white}
+
+ tixForm $w.file
+ tixForm $w.top -top $w.file -left 2 -right %99
+ tixForm $w.text -left 2 -top $w.top -bottom $w.lab -right %99
+ tixForm $w.lab -left 2 -right %99 -bottom %99
+
+ wokReadString $texte [exec ar tv $file]
+
+ update
+ return
+}
+proc wokEDF:Archive:Exit { w } {
+ wokButton delw [list archive $w]
+ destroy $w
+ return
+}
+;#
+;# donne la liste des .o d'une shareable et proposera nm et Cie args Adr File
+;#
+proc wokEDF:Shareable { file args} {
+ global IWOK_WINDOWS
+ set location $args ;# loc WOK:k3dev:ref:TKWOK:stadmfile
+ set ll [llength [set lc [split $location :]]]
+ set actloc [join [lrange $lc 0 [expr $ll - 2]] :]
+ set typloc [lindex $lc end]
+ set ud [wokinfo -n $actloc]
+ set objlist [wokinfo -p stadmfile:${ud}.ObjList $actloc]
+ if [file exists $objlist] {
+ set tfi [split [file tail $file] .]
+ set w [string tolower .[id user]:[id host]:[join $tfi :]]
+ if [winfo exists $w] {
+ wm deiconify $w
+ raise $w
+ return
+ }
+ set fnt [tix option get fixed_font]
+ toplevel $w
+ wm title $w "Objects in file $file"
+
+ wokButton setw [list shareable $w]
+
+ tixScrolledText $w.text ; set IWOK_WINDOWS($w,text) [$w.text subwidget text]
+ $IWOK_WINDOWS($w,text) config -font $fnt -cursor {hand2 red white}
+
+ menubutton $w.file -menu $w.file.m -text File -underline 0 -takefocus 0
+ menu $w.file.m
+ $w.file.m add command -label "Close " -underline 1 -command [list wokEDF:Shareable:Exit $w]
+
+ menubutton $w.disp -menu $w.disp.m -text Arrange -underline 0 -takefocus 0
+ menu $w.disp.m
+ $w.disp.m add radio -label "By name" -under 1 -var IWOK_WINDOWS($w,bywhat) \
+ -value byname -comm [list wokEDF:Shareable:Disp $w]
+ $w.disp.m add radio -label "By date" -under 1 -var IWOK_WINDOWS($w,bywhat) \
+ -value bydate -comm [list wokEDF:Shareable:Disp $w]
+ set IWOK_WINDOWS($w,bywhat) bydate
+ $w.disp.m add separator
+ $w.disp.m add radio -label "Full path" -under 1 -var IWOK_WINDOWS($w,bywhat) \
+ -value fullpa -comm [list wokEDF:Shareable:Disp $w]
+ set IWOK_WINDOWS($w,bywhat) fullpa
+
+ frame $w.top -relief sunken -bd 1
+ label $w.lab -relief raised
+
+ menubutton $w.edit -menu $w.edit.m -text Edit -underline 0 -takefocus 0
+ menu $w.edit.m
+ $w.edit.m add command -label "Search" -command [list wokSEA $IWOK_WINDOWS($w,text)]
+
+ tixForm $w.file ; tixForm $w.disp -left $w.file ; tixForm $w.edit -left $w.disp
+ tixForm $w.top -top $w.file -left 2 -right %99
+ tixForm $w.text -left 2 -top $w.top -bottom $w.lab -right %99
+ tixForm $w.lab -left 2 -right %99 -bottom %99
+
+ set IWOK_WINDOWS($w,listo) [wokUtils:FILES:FileToList $objlist]
+ wokEDF:Shareable:Disp $w
+ set solen [llength $IWOK_WINDOWS($w,listo)]
+ set sodat [string range [fmtclock [file mtime $file]] 4 18]
+ $w.lab configure -text "$solen objects."
+ update
+ }
+ return
+}
+
+proc wokEDF:Shareable:Exit { w } {
+ wokButton delw [list shareable $w]
+ destroy $w
+ return
+}
+
+proc wokEDF:Shareable:Disp { w } {
+ global IWOK_WINDOWS
+ set ll $IWOK_WINDOWS($w,listo)
+ set l1 {}
+ if { "$IWOK_WINDOWS($w,bywhat)" == "fullpa" } {
+ wokReadList $IWOK_WINDOWS($w,text) $IWOK_WINDOWS($w,listo)
+ return
+ }
+ tixBusy $w on
+ update
+ foreach e $ll {
+ catch {unset m}
+ file lstat $e m
+ lappend l1 [list [file tail $e] $m(mtime) $m(size)]
+ }
+
+ switch -- $IWOK_WINDOWS($w,bywhat) {
+ byname {
+ set l2 [lsort -command wokEDF:Shareable:byname $l1]
+ }
+
+ bydate {
+ set l2 [lsort -decreasing -command wokEDF:Shareable:bydate $l1]
+ }
+ }
+ set l3 {}
+ foreach e $l2 {
+ set str [lindex $e 0]
+ set dat [string range [fmtclock [lindex $e 1]] 4 18]
+ set siz [lindex $e 2]
+ lappend l3 [format "%15s %-10s %s" $dat $siz $str]
+ }
+ wokReadList $IWOK_WINDOWS($w,text) $l3
+ tixBusy $w off
+ return
+}
+;#
+;# Ordre alphab sur le path ou le full path
+;#
+proc wokEDF:Shareable:byname { a b } {
+ return [string compare [lindex $a 0] [lindex $b 0] ]
+}
+
+;#
+;# dernier modifie d'abord
+;#
+proc wokEDF:Shareable:bydate { a b } {
+ return [expr [lindex $a 1] - [lindex $b 1] ]
+}
+;#
+;#
+;#
+proc wokEDF:Zfile { file args } {
+ return
+}
+
+proc wokEDF:ofile { file args } {
+ return
+}
+
+;#
+;# comment recuperer les extensions de shareable ??
+;#
+proc wokEDF:InitAdequateCommand { } {
+ global IWOK_GLOBALS
+ set IWOK_GLOBALS(EDF,EDITOR) [wokEDF:EDITOR]
+ set IWOK_GLOBALS(EDF,.a) wokEDF:Archive
+ set IWOK_GLOBALS(EDF,.so) wokEDF:Shareable
+ set IWOK_GLOBALS(EDF,.sl) wokEDF:Shareable
+ set IWOK_GLOBALS(EDF,.Z) wokEDF:Zfile
+ set IWOK_GLOBALS(EDF,.o) wokEDF:ofile
+ return
+}
+;#
+;#
+;#
+proc wokEDF:AdequateCommand { path args } {
+ global IWOK_GLOBALS
+ set ext [file extension $path]
+ if [info exists IWOK_GLOBALS(EDF,$ext)] {
+ $IWOK_GLOBALS(EDF,$ext) $path $args
+ } else {
+ wokEDF:EditFile $path
+ }
+ return
+}
+;#
+;#
+;#
+proc wokEDF:InitExtension { } {
+ global IWOK_GLOBALS
+ set IWOK_GLOBALS(EXT,package,ext) {.cdl .cxx .hxx .c .h}
+ set IWOK_GLOBALS(EXT,nocdlpack,ext) {.cxx .hxx .c .h}
+ set IWOK_GLOBALS(EXT,interface,ext) {.cdl .cxx .hxx}
+ set IWOK_GLOBALS(EXT,client,ext) {.cdl .cxx .hxx}
+ set IWOK_GLOBALS(EXT,toolkit,ext) {}
+ set IWOK_GLOBALS(EXT,engine,ext) {.cdl .cxx .hxx}
+ set IWOK_GLOBALS(EXT,executable,ext) {.cdl .cxx .hxx}
+ set IWOK_GLOBALS(EXT,schema,ext) {.cdl .cxx .hxx}
+ set IWOK_GLOBALS(EXT,ccl,ext) {.ccl .us .fr}
+ set IWOK_GLOBALS(EXT,frontal,ext) {}
+ set IWOK_GLOBALS(EXT,documentation,ext) {}
+ set IWOK_GLOBALS(EXT,resource,ext) {.o .xwd .dat .tcl .el .csh}
+ set IWOK_GLOBALS(EXT,delivery,ext) {}
+ set IWOK_GLOBALS(EXT,all) {.cdl .cxx .hxx .gxx .lxx .pxx .c .h .edl .tcl}
+ return
+}
--- /dev/null
+ Menu:
+
+
+ <File>
+
+ Ends the iwok session. The session was started by typing the iwok command.
+ You may also type iwok -f but in this case the exploration starts at the root with the session.
+
+ <Windows>
+
+ Displays the name of all the created windows with the selected one first.
+ You may choose to hide or show all the created windows.
+
+
+
+ 'Contents of' window:
+
+
+ This window displays the name of the entity being explored.
+ Click on the 'pointed finger'icon to go there (i.e. wokcd).
+ This address becomes the current entity of the Tcl session and the application buttons are
+ activated according to the type of entity.
+ The arrow located to the right of the field 'Contents of' lists all the last visited addresses; you
+ may perform your selection directly in this list.
+
+
+
+ Display management buttons:
+
+
+ <Columns>
+
+ Items are displayed in one column in alphabetical order.
+
+ <Last modified first>
+
+ Items are displayed in one column with the last modified items first.
+ For each item, the modification date and the size are provided.
+
+ <Date/Time>
+
+ Items are displayed in one column in alphabetical order.
+ For each item, the modification date and the size are provided.
+
+ <Rows>
+
+ Items are displayed in rows in alphabetical order on one line.
+
+ <Go up>
+
+ Goes up one level and displays the contents of the entity.
+ Example: If the current address is in a workbench, the list of all the workbenches in the
+ workshop is displayed.
+
+ <wokcd>
+
+ Runs the wokcd command with the contents of the location window as an argument.
+
+ <Display Layout>
+
+ Click on the Matra Datavision logo to stretch the window and display the contents of the
+ selected entity. If the window has already been stretched, it is closed.
+ Double-click on the displayed element to explore its contents. In the case of a file, it is
+ loaded into an editor.
+
+ The editor is either:
+ - emacs where you have created a *woksh* buffer,
+ - an editor defined by the environment variable EDITOR,
+ - the default editor provided with IWOK in all other cases.
+
+
+
+ WOK applications buttons:
+
+
+ The buttons are activated according to the type of entity where you performed the wokcd command.
+
+
+ <wprepare>
+
+ Gives access to the WOK command wprepare which compares the workbench with the root workbench of
+ the workshop.
+
+
+ <umake>
+
+ Gives access to the WOK command umake and all umake options.
+
+
+ <Params>
+
+ Allows consultation and possible edition of the session parameters.
+
+
+ <CDL Browser>
+
+ Allows consultation of the CDL translation results in the current Tcl session.
+
+
+
+
+
+
+
--- /dev/null
+#
+# Ouvre une entry dans le tree. (Double Click)
+#
+proc wokNAV:Tree:Open { w dir } {
+ global IWOK_WINDOWS
+ if {[$IWOK_WINDOWS($w,NAV,hlist) info children $dir] != {}} {
+ foreach kid [$IWOK_WINDOWS($w,NAV,hlist) info children $dir] {
+ $IWOK_WINDOWS($w,NAV,hlist) show entry $kid
+ }
+ set data [$IWOK_WINDOWS($w,NAV,hlist) info data $dir]
+ set loc [lindex $data 0]
+ wokUpdateLayout $loc
+ wokCWD writenocallback $loc
+ } else {
+ tixBusy $w on
+ update
+ wokNAV:Tree:Fill $w $dir
+ tixBusy $w off
+ }
+
+ return
+}
+
+#
+# Appele par Open.
+#
+proc wokNAV:Tree:Fill { w dir } {
+ global IWOK_WINDOWS
+ set data [$IWOK_WINDOWS($w,NAV,hlist) info data $dir]
+ set loc [lindex $data 0]
+ set type [lindex $data 1]
+
+ switch -glob $type {
+
+ factory {
+ wokNAV:Tree:Updateworkshop $w $loc $dir
+ }
+
+ workshop {
+ wokNAV:Tree:Updateworkbench $w $loc $dir
+ }
+
+ warehouse {
+ wokNAV:Tree:Updatewarehouse $w $loc $dir
+ }
+
+ parcel {
+ wokNAV:Tree:Updateparcel $w $loc $dir
+ }
+
+ workbench {
+ wokNAV:Tree:Updatedevunit $w $loc $dir
+ }
+
+ session {
+ wokNAV:Tree:Updatefactory $w $loc $dir
+ }
+
+ stuff_* {
+ wokNAV:Tree:Updatestufflist $w $loc $dir $type
+ }
+
+ parcel_* {
+ wokNAV:Tree:Updateparcelstufflist $w $loc $dir $type
+ }
+
+ parcelstuff_* {
+ wokNAV:Tree:Updatestufflist $w $loc $dir $type
+ }
+
+ devunit_* {
+ wokNAV:Tree:Updatedevunitstuff $w $loc $dir
+ }
+
+ default {
+ puts "type = $type = for $loc is unknown"
+ return
+ }
+ }
+ wokCWD write $loc
+ return
+}
+#
+#
+#
+proc wokNAV:Tree:Show { w dir } {
+ global IWOK_WINDOWS
+ $IWOK_WINDOWS($w,NAV,hlist) anchor clear
+ $IWOK_WINDOWS($w,NAV,hlist) anchor set $dir
+ $IWOK_WINDOWS($w,NAV,hlist) selection clear
+ $IWOK_WINDOWS($w,NAV,hlist) selection set $dir
+ $IWOK_WINDOWS($w,NAV,hlist) see $dir
+ return
+}
+#
+# Charge un terminal/trigger en fonction de son type. (Simple Click)
+#
+proc wokNAV:Tree:Browse { w dir } {
+ global IWOK_WINDOWS
+ set data [$IWOK_WINDOWS($w,NAV,hlist) info data $dir]
+ set type [lindex $data 1]
+ if { [regexp {trig_(.*)} $type all trig] } {
+ switch -- $trig {
+ terminal {
+ wokNAV:Tree:terminal $w [lindex $data 0] $dir
+ }
+
+ Repository {
+ wokUpdateRepository [lindex $data 0]
+ }
+
+ Queue {
+ wokWaffQueue [lindex $data 0]
+ }
+ }
+ }
+ return
+}
+
+#
+# Hilight l'entry correspondante et l'ouvre sauf si c'est un "trigger" (appelee par bind canvas)
+#
+proc wokNAV:Tree:Focus { w dir } {
+ global IWOK_WINDOWS
+ set data [$IWOK_WINDOWS($w,NAV,hlist) info data $dir]
+ set type [lindex $data 1]
+ if { [regexp {trig_(.*)} $type all trig] } {
+ switch -- $trig {
+ terminal {
+ wokNAV:Tree:terminal $w [lindex $data 0] $dir
+ }
+
+ Repository {
+ wokUpdateRepository [lindex $data 0]
+ }
+
+ Queue {
+ wokWaffQueue [lindex $data 0]
+ }
+
+ }
+
+ } else {
+ wokNAV:Tree:Open $w $dir
+ $IWOK_WINDOWS($w,NAV,tree) setmode $dir close
+ }
+ wokNAV:Tree:Show $w $dir
+ return
+}
+#
+#
+#
+proc wokNAV:Tree:SeeMe { w loc dir } {
+ wokNAV:tlist:Set $w $loc $dir
+ wokCWD write $loc
+ wokNAV:Tree:Focus $w $dir
+ return
+}
+#
+#
+#
+proc wokNAV:Tree:UpdateSession { w user } {
+ global IWOK_WINDOWS
+ set disp [list 18 18 600 30 16 1.4]
+ set fdate wokGetsessiondate
+ $IWOK_WINDOWS($w,NAV,hlist) add ^ -text $user -data [list : session $user {} $fdate $disp]
+ wokNAV:Tree:Fill $w ^
+ wokNAV:tlist:Set $w : ^
+ return
+}
+#
+# ici dir = ^
+#
+proc wokNAV:Tree:Updatefactory { w loc dir } {
+ global IWOK_WINDOWS
+ global IWOK_GLOBALS
+ wokNAV:Initfactory
+ set disp $IWOK_GLOBALS(factory,disp)
+ set fdate $IWOK_GLOBALS(factory,fdate)
+ set image $IWOK_GLOBALS(factory,image)
+
+ foreach name [lsort [Sinfo -F]] {
+ $IWOK_WINDOWS($w,NAV,hlist) add ${dir}$name \
+ -itemtype imagetext -text $name \
+ -image $image \
+ -data [list $name factory $name $image $fdate $disp]
+ $IWOK_WINDOWS($w,NAV,tree) setmode ${dir}$name open
+ }
+ wokNAV:tlist:Set $w $loc $dir
+ return
+}
+#
+# loc est une adresse de factory
+#
+proc wokNAV:Tree:Updateworkshop { w loc dir } {
+ global IWOK_WINDOWS
+ global IWOK_GLOBALS
+ wokNAV:Initworkshop
+
+ set disp $IWOK_GLOBALS(workshop,disp)
+ set fdate $IWOK_GLOBALS(workshop,fdate)
+ set image $IWOK_GLOBALS(workshop,image)
+
+ set name [finfo -W $loc]
+ $IWOK_WINDOWS($w,NAV,hlist) add ${dir}^$name \
+ -itemtype imagetext -text $name \
+ -image [tix getimage warehouse] \
+ -data [list ${loc}:${name} warehouse $name [tix getimage warehouse] $fdate $disp]
+ $IWOK_WINDOWS($w,NAV,tree) setmode ${dir}^$name open
+
+ foreach name [lsort [finfo -s $loc]] {
+ $IWOK_WINDOWS($w,NAV,hlist) add ${dir}^${name} \
+ -itemtype imagetext -text $name \
+ -image $image \
+ -data [list ${loc}:${name} workshop $name $image $fdate $disp]
+ $IWOK_WINDOWS($w,NAV,tree) setmode ${dir}^${name} open
+ }
+ wokNAV:tlist:Set $w $loc $dir
+ return
+}
+;#
+;# loc est une adresse de workshop
+;#
+proc wokNAV:Tree:Updateworkbench { w loc dir } {
+ global IWOK_WINDOWS
+ global IWOK_GLOBALS
+ wokNAV:Initworkbench
+ set disp $IWOK_GLOBALS(workbench,disp)
+ set fdate $IWOK_GLOBALS(workbench,fdate)
+ set image $IWOK_GLOBALS(workbench,image)
+
+ if { [wokIntegre:BASE:GetType $loc] != {} } {
+ if ![$IWOK_WINDOWS($w,NAV,hlist) info exists ${dir}^_Queue] {
+ $IWOK_WINDOWS($w,NAV,hlist) add ${dir}^_Queue \
+ -itemtype imagetext -text Queue \
+ -image [tix getimage queue] \
+ -data [list ${loc}:Queue trig_Queue Queue [tix getimage queue] $fdate $disp]
+ }
+ if ![$IWOK_WINDOWS($w,NAV,hlist) info exists ${dir}^_Reposit] {
+ $IWOK_WINDOWS($w,NAV,hlist) add ${dir}^_Reposit \
+ -itemtype imagetext -text Repository \
+ -image [tix getimage reposit] \
+ -data [list ${loc}:Repository trig_Repository Repository [tix getimage reposit] $fdate $disp]
+ }
+ }
+
+ foreach name [sinfo -w $loc] {
+ $IWOK_WINDOWS($w,NAV,hlist) add ${dir}^${name} -text $name -itemtype imagetext \
+ -image $image \
+ -data [list ${loc}:${name} workbench $name $image $fdate $disp]
+ $IWOK_WINDOWS($w,NAV,tree) setmode ${dir}^${name} open
+ }
+ wokNAV:tlist:Set $w $loc $dir
+ return
+}
+;#
+;#
+;#
+proc wokNAV:Tree:Updatedevunit { w loc dir } {
+ global IWOK_WINDOWS
+ global IWOK_GLOBALS
+ wokNAV:Initdevunit $loc
+ foreach d [lsort -command wokSortUnit [w_info -a $loc]] {
+ set name [lindex $d 1]
+ set type [lindex $d 0]
+ set disp $IWOK_GLOBALS($type,disp)
+ set fdate $IWOK_GLOBALS($type,fdate)
+ set image $IWOK_GLOBALS($type,image)
+
+ $IWOK_WINDOWS($w,NAV,hlist) add ${dir}^${name} -itemtype imagetext \
+ -text $name -image $image \
+ -data [list ${loc}:${name} devunit_$type $name $image $fdate $disp]
+ $IWOK_WINDOWS($w,NAV,tree) setmode ${dir}^${name} open
+ }
+ wokNAV:tlist:Set $w $loc $dir
+ return
+}
+;#
+;#
+;#
+proc wokSortUnit { a b } {
+ return [string compare [lindex $a 1] [lindex $b 1]]
+}
+proc wokSortPath { a b } {
+ return [string compare [file tail $a] [file tail $b]]
+}
+;#
+;#
+;#
+proc wokNAV:Tree:Updatedevunitstuff { w loc dir } {
+ global IWOK_WINDOWS
+ global IWOK_GLOBALS
+ wokNAV:Initdevunitstuff
+ set fdate $IWOK_GLOBALS(devunitstuff,fdate)
+ set disp $IWOK_GLOBALS(devunitstuff,disp)
+
+ catch { unset TLOC }
+ foreach f [uinfo -Fpl $loc] {
+ set t [lindex $f 0]
+ set p [lindex $f 2]
+ if [info exists TLOC($t)] {
+ set l $TLOC($t)
+ lappend l $p
+ set TLOC($t) $l
+ } else {
+ set TLOC($t) $p
+ }
+ }
+
+
+ if [info exists TLOC(source)] {
+ set name source
+ $IWOK_WINDOWS($w,NAV,hlist) add ${dir}^${name} -itemtype imagetext \
+ -text $name -image $IWOK_GLOBALS(devunitstuff,source) \
+ -data [list ${loc}:${name} stuff_$name $name $IWOK_GLOBALS(devunitstuff,source) $fdate $disp]
+ $IWOK_WINDOWS($w,NAV,tree) setmode ${dir}^${name} open
+ set IWOK_WINDOWS($w,NAV,tree,uinfo,${loc}:${name},$name) $TLOC($name)
+ }
+
+ foreach name [array names TLOC] {
+ if { "$name" != "source" } {
+ $IWOK_WINDOWS($w,NAV,hlist) add ${dir}^${name} -itemtype imagetext \
+ -text $name -image $IWOK_GLOBALS(devunitstuff,cell) \
+ -data [list ${loc}:${name} stuff_$name $name $IWOK_GLOBALS(devunitstuff,cell) $fdate $disp]
+ $IWOK_WINDOWS($w,NAV,tree) setmode ${dir}^${name} open
+ set IWOK_WINDOWS($w,NAV,tree,uinfo,${loc}:${name},$name) $TLOC($name)
+ }
+ }
+ wokNAV:tlist:Set $w ${loc} $dir
+
+ return
+}
+;#
+;#
+;#
+proc wokNAV:Tree:Updatestufflist { w loc dir stuff_type } {
+ global IWOK_WINDOWS
+
+ set image [tix getimage textfile]
+ set type [lindex [split $stuff_type _] 1]
+
+ foreach name [lsort -command wokSortPath $IWOK_WINDOWS($w,NAV,tree,uinfo,$loc,$type)] {
+ set text [file tail $name]
+ $IWOK_WINDOWS($w,NAV,hlist) add ${dir}^${text} -itemtype imagetext -text $text \
+ -image $image \
+ -data [list $loc trig_terminal $text $image $name]
+ }
+ wokNAV:tlist:Set $w ${loc} $dir
+ return
+}
+#
+# data /adv_23/WOK/k2dev/ref/src/NWOK/COMPONENTS terminal
+#
+proc wokNAV:Tree:terminal { w loc dir } {
+ global IWOK_WINDOWS
+ set data [$IWOK_WINDOWS($w,NAV,hlist) info data $dir]
+ wokEDF:AdequateCommand [lindex $data 4] $loc
+ return
+}
+#
+# loc est une adresse de factory
+#
+proc wokNAV:Tree:Updatewarehouse { w loc dir } {
+ global IWOK_WINDOWS
+ set disp [list 18 18 600 30 12 1.4]
+ set fdate wokGetparceldate
+ set image [tix getimage parcel]
+ foreach itm [Winfo -p $loc] {
+ if ![$IWOK_WINDOWS($w,NAV,hlist) info exists ${dir}^${itm}] {
+ $IWOK_WINDOWS($w,NAV,hlist) add ${dir}^${itm} -itemtype imagetext \
+ -text $itm -image $image \
+ -data [list ${loc}:${itm} parcel ${itm} $image $fdate $disp]
+ $IWOK_WINDOWS($w,NAV,tree) setmode ${dir}^${itm} open
+ }
+ }
+ wokNAV:tlist:Set $w $loc $dir
+ return
+}
+#
+# loc est une adresse de parcel (WOK:BAG:NWOK-K2-1)
+#
+proc wokNAV:Tree:Updateparcel { w loc dir } {
+ global IWOK_WINDOWS
+ set disp [list 18 18 600 30 12 1.4]
+ set fdate wokGetparcelunitdate
+ foreach unit [pinfo -a ${loc}] {
+ set type [lindex $unit 0]
+ set name [lindex $unit 1]
+ $IWOK_WINDOWS($w,NAV,hlist) add ${dir}^${name} -itemtype imagetext \
+ -text $name -image [tix getimage $type] \
+ -data [list ${loc}:${name} parcel_$type ${name} [tix getimage $type] $fdate $disp]
+ $IWOK_WINDOWS($w,NAV,tree) setmode ${dir}^${name} open
+ }
+ wokNAV:tlist:Set $w $loc $dir
+ return
+}
+#
+#
+#
+proc wokNAV:Tree:Updateparcelstufflist { w loc dir stuff_type } {
+ global IWOK_WINDOWS
+ ;#puts "Updateparcelstufflist : $loc $dir $stuff_type"
+
+ set isource [tix getimage source]
+ set icell [tix getimage cell]
+
+ set disp [list 18 18 600 18 10 1.2]
+ set fdate wokGetparcelunitstuffdate
+
+ catch { unset TLOC }
+ foreach f [uinfo -Fpl $loc] {
+ set t [lindex $f 0]
+ set p [lindex $f 2]
+ if [info exists TLOC($t)] {
+ set l $TLOC($t)
+ lappend l $p
+ set TLOC($t) $l
+ } else {
+ set TLOC($t) $p
+ }
+ }
+
+ foreach name [array names TLOC] {
+ set image $icell
+ if { "$name" == "source" } { set image $isource }
+ $IWOK_WINDOWS($w,NAV,hlist) add ${dir}^${name} -itemtype imagetext \
+ -text $name -image $image \
+ -data [list ${loc}:${name} parcelstuff_$name $name $image $fdate $disp]
+ $IWOK_WINDOWS($w,NAV,tree) setmode ${dir}^${name} open
+ set IWOK_WINDOWS($w,NAV,tree,uinfo,${loc}:${name},$name) $TLOC($name)
+ }
+ wokNAV:tlist:Set $w ${loc} $dir
+ return
+}
+#
+# Sauve l'adresse( dans la hlist ) de ce qui a ete affiche
+#
+proc wokNAV:tlist:Set { w loc dir } {
+ global IWOK_WINDOWS
+ set IWOK_WINDOWS($w,NAV,tlist,$loc) $dir
+ ;#puts "set IWOK_WINDOWS($w,NAV,tlist,$loc) = $dir"
+ return
+}
+#
+#
+#
+proc wokNAV:tlist:Get { w loc } {
+ global IWOK_WINDOWS
+ if [info exists IWOK_WINDOWS($w,NAV,tlist,$loc)] {
+ return $IWOK_WINDOWS($w,NAV,tlist,$loc)
+ } else {
+ ;#puts "wokNAV:tlist:Get pas d'info pour $loc"
+ return {}
+ }
+}
+#
+# horreur 1: tout ca pour ce petit cheri de wokinfo
+# on pourrait scanner tous les noeuds et chercher la data qui correspond...
+proc wokNAV:tlist:locTodir { loc } {
+ set l [split $loc :]
+ if {"[lindex $l 0]" == {} } {
+ return [join $l ^]
+ } else {
+ return ^[join $l ^]
+ }
+}
+#
+#
+#
+proc wokNAV:tlist:Type { w loc } {
+ global IWOK_WINDOWS
+ if [info exists IWOK_WINDOWS($w,NAV,tlist,$loc)] {
+ return [lindex [$IWOK_WINDOWS($w,NAV,hlist) info data $IWOK_WINDOWS($w,NAV,tlist,$loc)] 1]
+ } else {
+ return {}
+ }
+}
+#
+# Recupere les info associees a loc
+#
+proc wokNAV:tlist:GetData { w loc } {
+ global IWOK_WINDOWS
+ set hlist $IWOK_WINDOWS($w,NAV,hlist)
+ set ll {}
+ set dir [wokNAV:tlist:Get $w $loc]
+ if [$hlist info exists $dir] {
+ if { [$hlist info children $dir] != {} } {
+ foreach kid [$IWOK_WINDOWS($w,NAV,hlist) info children $dir] {
+ lappend ll [linsert [$hlist info data $kid] 0 $kid]
+ }
+ }
+ }
+ return $ll
+}
+#
+# Idem qu'au dessus : utilise pour un terminal.
+#
+proc wokNAV:tlist:TermData { w dir } {
+ global IWOK_WINDOWS
+ set hlist $IWOK_WINDOWS($w,NAV,hlist)
+ if [$hlist info exists $dir] {
+ return [$hlist info data $dir]
+ }
+}
+
+proc wokNAV:tlist:Display { w loc } {
+ global IWOK_WINDOWS
+ if [info exists IWOK_WINDOWS($w,NAV,tlist,$loc) ] {
+ return [lindex [$IWOK_WINDOWS($w,NAV,hlist) info data $IWOK_WINDOWS($w,NAV,tlist,$loc)] end]
+ }
+}
+
+proc wokNAV:tlist:date { w loc } {
+ global IWOK_WINDOWS
+ if [info exists IWOK_WINDOWS($w,NAV,tlist,$loc) ] {
+ set i [expr [llength [$IWOK_WINDOWS($w,NAV,hlist) info data $IWOK_WINDOWS($w,NAV,tlist,$loc)]] -2]
+ return [lindex [$IWOK_WINDOWS($w,NAV,hlist) info data $IWOK_WINDOWS($w,NAV,tlist,$loc)] $i]
+ }
+}
+#
+# Recupere l'adresse (loc) du pere
+#
+proc wokNAV:Tlist:Dad { w loc } {
+ global IWOK_WINDOWS
+ if [info exists IWOK_WINDOWS($w,NAV,tlist,$loc) ] {
+ set dir $IWOK_WINDOWS($w,NAV,tlist,$loc)
+ set dad [$IWOK_WINDOWS($w,NAV,hlist) info parent $dir]
+ return [lindex [$IWOK_WINDOWS($w,NAV,hlist) info data $dad] 0]
+ } else {
+ return {}
+ }
+}
+#
+# imprime tout ce qu'il y a dans hli ( Hlist )
+#
+proc wokNAV:DBG { {root {}} } {
+ global IWOK_GLOBALS
+ global IWOK_WINDOWS
+ set w $IWOK_GLOBALS(toplevel)
+ set hli $IWOK_WINDOWS($w,NAV,hlist)
+ foreach c [$hli info children $root] {
+ puts "$c : data <[$hli info data $c]>"
+ wokNAV:DBG $c
+ }
+ return
+}
+proc wokDUMP { } {
+ global IWOK_GLOBALS
+ global IWOK_WINDOWS
+ parray IWOK_WINDOWS $IWOK_GLOBALS(toplevel),NAV,tlist,*
+ return
+}
+#
+# Ajoute l'entry de type $type correspondant a loc a l'adresse fdir du tree .
+#
+#
+proc wokNAV:Tree:Add { fdir loc name type } {
+ global IWOK_GLOBALS
+ global IWOK_WINDOWS
+ set w $IWOK_GLOBALS(toplevel)
+ if { [$IWOK_WINDOWS($w,NAV,hlist) info children $fdir] != {} } {
+ wokNAV:Init${type} $loc
+ if { [info exists IWOK_GLOBALS($type,disp)] } {
+ set disp $IWOK_GLOBALS($type,disp)
+ set fdate $IWOK_GLOBALS($type,fdate)
+ set image $IWOK_GLOBALS($type,image)
+ set dir ${fdir}^${name}
+ if { ![$IWOK_WINDOWS($w,NAV,hlist) info exists $dir] } {
+ $IWOK_WINDOWS($w,NAV,hlist) add ${dir} \
+ -itemtype imagetext -text $name \
+ -image $image \
+ -data [list $name $type $name $image $fdate $disp]
+ $IWOK_WINDOWS($w,NAV,tree) setmode ${dir} open
+ wokNAV:tlist:Set $w ${loc} $dir
+ ;# si l'entry pere a ete depliee puis repliee ne pas afficher, sera fait a l'ouverture
+ if { "[$IWOK_WINDOWS($w,NAV,tree) getmode $fdir]" == "open" } {
+ ;#puts "on cache car $fdir n est pas open"
+ $IWOK_WINDOWS($w,NAV,hlist) hide entry ${dir}
+ }
+ ;# si l'adresse est celle affiche dans le canvas : mettre a jour
+ if { "[wokCWD read]:${name}" == "$loc" } {
+ wokCWD write [wokCWD read]
+ }
+ } else {
+ puts stderr "Entry $dir already exists. not done"
+ }
+ } else {
+ puts stderr "Unable to read IWOK_GLOBALS($type,disp)"
+ }
+ } else {
+ ;# n'a pas ete encore affichee => sera updatee par WOK a la prochaine ouverture.
+ }
+ return
+}
+#
+# Vire les entry de lstdir du tree. listloc = { ... {$loc $type} ... }
+# Comme on ne connait pas l'etat du tree on fait info exists...
+# meme chose pour l'historique dans la ComboBox.
+#
+proc wokNAV:Tree:Del { listloc } {
+ global IWOK_WINDOWS
+ global IWOK_GLOBALS
+ set w $IWOK_GLOBALS(toplevel)
+ set update 0
+ set layout [wokListLayout]
+ foreach itm $listloc {
+ set loc [lindex $itm 0]
+ set typ [lindex $itm 1]
+ set dir [wokNAV:tlist:locTodir $loc]
+ if { [$IWOK_WINDOWS($w,NAV,hlist) info exists $dir] } {
+ set actloc [lindex [$IWOK_WINDOWS($w,NAV,hlist) info data $dir] 0]
+ $IWOK_WINDOWS($w,NAV,hlist) delete entry ${dir}
+ if [info exists IWOK_WINDOWS($w,NAV,tlist,$actloc)] {
+ unset IWOK_WINDOWS($w,NAV,tlist,$actloc)
+ }
+ ;# faudra t-il mettre a jour le canvas ?
+ if { [lsearch $layout $actloc] != -1 } {
+ set update 1
+ }
+ wokCWD deletefromhistory $actloc
+ }
+ }
+ ;# Un des elements detruits etait dans le canvas. On met a jour.
+ ;# On monte d'un cran si en pointant dans la hlist on detruit l'element affiche (CWD read)
+ ;# tout ca est un peu complique.
+ if { $update == 1 } {
+ set displayed [wokCWD read]
+ set dir [wokNAV:tlist:locTodir $displayed]
+ if [$IWOK_WINDOWS($w,NAV,hlist) info exists $dir] {
+ wokCWD write $displayed
+ } else {
+ wokCWD write [wokinfo -N $displayed]
+ }
+ }
+ return
+}
+
+proc wokNAV:Initfactory { args } {
+ global IWOK_GLOBALS
+ if ![info exists IWOK_GLOBALS(factory,initdone)] {
+ set IWOK_GLOBALS(factory,initdone) 1
+ set IWOK_GLOBALS(factory,disp) [list 18 18 600 30 16 1.8]
+ set IWOK_GLOBALS(factory,fdate) wokGetfactorydate
+ set IWOK_GLOBALS(factory,image) [tix getimage factory]
+ }
+ return
+}
+
+proc wokNAV:Initworkshop { args } {
+ global IWOK_GLOBALS
+ if ![info exists IWOK_GLOBALS(workshop,initdone)] {
+ set IWOK_GLOBALS(workshop,initdone) 1
+ set IWOK_GLOBALS(workshop,disp) [list 18 18 600 30 14 1.5]
+ set IWOK_GLOBALS(workshop,fdate) wokGetworkshopdate
+ set IWOK_GLOBALS(workshop,image) [tix getimage workshop]
+ }
+ return
+}
+
+proc wokNAV:Initworkbench { args } {
+ global IWOK_GLOBALS
+ if ![info exists IWOK_GLOBALS(workbench,initdone)] {
+ set IWOK_GLOBALS(workbench,initdone) 1
+ set IWOK_GLOBALS(workbench,disp) [list 18 18 600 30 12 1.4]
+ set IWOK_GLOBALS(workbench,fdate) wokGetworkbenchdate
+ set IWOK_GLOBALS(workbench,image) [tix getimage workbench]
+ }
+ return
+}
+
+proc wokNAV:Initdevunit { args } {
+ global IWOK_GLOBALS
+ ;# [ucreate -P $args]
+ if ![info exists IWOK_GLOBALS(devunit,initdone)] {
+ set IWOK_GLOBALS(devunit,initdone) 1
+ foreach t $IWOK_GLOBALS(ucreate-P) {
+ set x [lindex $t 1]
+ set IWOK_GLOBALS($x,disp) [list 18 18 600 18 10 1.2]
+ set IWOK_GLOBALS($x,fdate) wokGetdevunitdate
+ set IWOK_GLOBALS($x,image) [tix getimage $x]
+ eval "proc wokNAV:Init${x} { args } {global IWOK_GLOBALS ; set IWOK_GLOBALS($x,disp) \"$IWOK_GLOBALS($x,disp)\" ;set IWOK_GLOBALS($x,fdate) $IWOK_GLOBALS($x,fdate) ;set IWOK_GLOBALS($x,image) $IWOK_GLOBALS($x,image);return }"
+ }
+ }
+ return
+}
+
+proc wokNAV:Initdevunitstuff { args } {
+ global IWOK_GLOBALS
+ if ![info exists IWOK_GLOBALS(devunitstuff,initdone)] {
+ set IWOK_GLOBALS(devunitstuff,initdone) 1
+ set IWOK_GLOBALS(devunitstuff,disp) [list 18 18 600 18 10 1.2]
+ set IWOK_GLOBALS(devunitstuff,fdate) wokGetdevunitstuffdate
+ set IWOK_GLOBALS(devunitstuff,source) [tix getimage source]
+ set IWOK_GLOBALS(devunitstuff,cell) [tix getimage cell]
+ }
+ return
+}
--- /dev/null
+
+proc wokOUC:DBG { {root {}} } {
+ global IWOK_GLOBALS
+ global IWOK_WINDOWS
+ set w .oucewokk4dev
+ set hli $IWOK_WINDOWS($w,OUC,hlist)
+ foreach c [$hli info children $root] {
+ puts "$c : data <[$hli info data $c]>"
+ wokOUC:DBG $c
+ }
+ return
+}
+
+
+
+#############################################################################
+#
+# O U C
+# _____
+#
+#############################################################################
+proc wokOUC:Exit { w } {
+ global IWOK_WINDOWS
+ destroy $w
+ wokButton delw [list ouce $w]
+ foreach var [array names IWOK_WINDOWS $w,OUC,*] {
+ unset IWOK_WINDOWS($var)
+ }
+ return
+}
+
+proc wokOUC:Help { w } {
+ return
+}
+
+proc wokOUC:Create { {loc {}} } {
+ global IWOK_WINDOWS
+ global IWOK_GLOBALS
+
+ if { $loc == {} } {
+ set verrue [wokCWD readnocell]
+ } else {
+ regexp {(.*):OUCE} $loc all verrue
+ }
+
+ if ![wokinfo -x $verrue] {
+ wokDialBox .wokcd {Unknown location} "Location $verrue is unknown" {} -1 OK
+ return
+ }
+ set fshop [wokinfo -s $verrue]
+
+ set w [wokTPL ouce${verrue}]
+ if [winfo exists $w ] {
+ wm deiconify $w
+ raise $w
+ return
+ }
+
+ toplevel $w
+ wm title $w "OUCE of $fshop"
+ wm geometry $w 880x555+515+2
+
+ wokButton setw [list ouce $w]
+
+ menubutton $w.file -menu $w.file.m -text File -underline 0 -takefocus 0
+ menu $w.file.m
+ $w.file.m add command -label "Exit " -underline 1 -command [list wokOUC:Exit $w]
+
+ menubutton $w.help -menu $w.help.m -text Help -underline 0 -takefocus 0
+ menu $w.help.m
+ $w.help.m add command -label "Help" -underline 1 -command [list wokOUC:Help $w]
+
+ frame $w.top -relief sunken -bd 1
+
+ tixPanedWindow $w.top.pane -orient horizontal -paneborderwidth 0 -separatorbg gray50
+ pack $w.top.pane -side top -expand yes -fill both -padx 10 -pady 10
+
+ set p1 [$w.top.pane add tree -min 70 -size 200]
+ set p2 [$w.top.pane add text -min 70]
+
+ set tree [tixTree $p1.tree -options {hlist.separator "^" hlist.selectMode single }]
+ set text [tixScrolledText $p2.text ] ; $text subwidget text config -font $IWOK_GLOBALS(font)
+
+ $tree config -opencmd [list wokOUC:Tree:Open $w] -browsecmd [list wokOUC:Tree:Browse $w]
+
+ pack $p1.tree -expand yes -fill both -padx 1 -pady 1
+ pack $p2.text -expand yes -fill both -padx 1 -pady 1
+
+ set IWOK_WINDOWS($w,OUC,tree) $tree
+ set IWOK_WINDOWS($w,OUC,hlist) [$tree subwidget hlist]
+ set IWOK_WINDOWS($w,OUC,text) [$text subwidget text]
+ set IWOK_WINDOWS($w,OUC,label) [label $w.lab]
+ set IWOK_WINDOWS($w,OUC,shop) $fshop
+ set IWOK_WINDOWS($w,OUC,root) [wokOUC:GetRootName $fshop]
+ set IWOK_WINDOWS($w,OUC,dupstyle) [tixDisplayStyle imagetext -fg orange]
+
+ tixButtonBox $w.act -orientation horizontal -relief flat -padx 0 -pady 0
+
+
+ tixForm $w.file ; tixForm $w.help -right -2
+ tixForm $w.act -top $w.file -left 2
+ tixForm $w.top -top $w.act -left 2 -right %99 -bottom $w.lab
+ tixForm $w.lab -left 2 -right %99 -bottom %99
+
+ bind $IWOK_WINDOWS($w,OUC,hlist) <Control-Button-1> {
+ wokOUC:Tree:diff [winfo toplevel %W]
+ }
+ bind $IWOK_WINDOWS($w,OUC,hlist) <Control-Button-1> {
+ wokOUC:Tree:diff [winfo toplevel %W]
+ }
+ wokOUC:Tree:Fill $w
+
+ return
+}
+
+proc wokOUC:Tree:diff { w } {
+ global IWOK_WINDOWS
+ if ![info exists IWOK_WINDOWS($w,OUC,v1)] {
+ set IWOK_WINDOWS($w,OUC,v1) [$IWOK_WINDOWS($w,OUC,hlist) info anchor]
+ } else {
+ if ![info exists IWOK_WINDOWS($w,OUC,v2)] {
+ set IWOK_WINDOWS($w,OUC,v2) [$IWOK_WINDOWS($w,OUC,hlist) info anchor]
+ set pth1 [lindex [lindex [$IWOK_WINDOWS($w,OUC,hlist) info data $IWOK_WINDOWS($w,OUC,v1)] 1] 2]
+ set pth2 [lindex [lindex [$IWOK_WINDOWS($w,OUC,hlist) info data $IWOK_WINDOWS($w,OUC,v2)] 1] 2]
+ if { [file exists $pth1] && [file exists $pth2] } {
+ wokDiffInText $IWOK_WINDOWS($w,OUC,text) $pth1 $pth2
+ if [wokUtils:EASY:INPATH xdiff] {
+ }
+ }
+ }
+ }
+ return
+}
+#;>
+# Pour iwok Ecrit la table dans un tree
+#;<
+proc wokOUC:Tree:Fill { w } {
+ global IWOK_WINDOWS
+ tixBusy $w on
+ set fshop $IWOK_WINDOWS($w,OUC,shop)
+ set root $IWOK_WINDOWS($w,OUC,root)
+ set hlist $IWOK_WINDOWS($w,OUC,hlist)
+ set filima [tix getimage textfile]
+ foreach e [lsort [readdir $root]] {
+ set ldup [llength [set lem [wokUtils:FILES:FileToList $root/$e]]]
+ if { $lem != {} } {
+ if { $ldup == 1 } {
+ $hlist add $e -itemtype imagetext -text $e \
+ -image $filima \
+ -data [list HEADER [list $ldup $lem]]
+ } else {
+ $hlist add $e -itemtype imagetext -text $e -style $IWOK_WINDOWS($w,OUC,dupstyle) \
+ -image $filima \
+ -data [list HEADER [list $ldup $lem]]
+ }
+ $IWOK_WINDOWS($w,OUC,tree) setmode $e open
+ update
+ } else {
+ unlink $root/$e
+ }
+ }
+ tixBusy $w off
+ return
+}
+
+
+proc wokOUC:Tree:Open { w dir } {
+ global IWOK_WINDOWS
+ global IWOK_GLOBALS
+ if {[$IWOK_WINDOWS($w,OUC,hlist) info children $dir] != {}} {
+ foreach kid [$IWOK_WINDOWS($w,OUC,hlist) info children $dir] {
+ $IWOK_WINDOWS($w,OUC,hlist) show entry $kid
+ }
+ } else {
+ tixBusy $w on
+ set lem [lindex [lindex [$IWOK_WINDOWS($w,OUC,hlist) info data $dir] 1] 1]
+ set upd {}
+ foreach f $lem {
+ set lf [split $f]
+ if { [file exists [lindex $lf 2]] } {
+ lappend upd $f
+ set adr [lindex $lf 0]
+ $IWOK_WINDOWS($w,OUC,hlist) add ${dir}^${adr} -itemtype imagetext \
+ -text [join [lrange [split $adr :] 2 3] :] \
+ -image $IWOK_GLOBALS(image,[lindex $lf 1]) \
+ -data [list PATH [list $adr [lindex $lf 1] [lindex $lf 2]]]
+ }
+ }
+ update
+ if { $upd != {} } {
+ wokUtils:FILES:ListToFile $upd $IWOK_WINDOWS($w,OUC,root)/$dir
+ } else {
+ unlink $IWOK_WINDOWS($w,OUC,root)/$dir
+ }
+ tixBusy $w off
+ }
+ return
+}
+
+proc wokOUC:Tree:Browse { w dir } {
+ global IWOK_WINDOWS
+
+ ;# parce qu'elle est aussi appelee dans le bind
+ if { [info exists IWOK_WINDOWS($w,OUC,v1)] && [info exists IWOK_WINDOWS($w,OUC,v2)] } {
+ unset IWOK_WINDOWS($w,OUC,v1) IWOK_WINDOWS($w,OUC,v2)
+ return
+ }
+
+ set data [$IWOK_WINDOWS($w,OUC,hlist) info data $dir]
+ set type [lindex $data 0]
+
+ switch -- $type {
+
+ PATH {
+ set dd [lindex $data 1]
+ set adr [lindex $dd 0]
+ set typ [lindex $dd 1]
+ set pth [lindex $dd 2]
+ wokReadFile $IWOK_WINDOWS($w,OUC,text) $pth
+ }
+
+ HEADER {
+ }
+ }
+
+ return
+}
+
+#
+#;>
+# Ajoute une entry pour lname { nam1 nam2 ..} a l'adresse adr
+# wokOUC:Add WOK:k4dev k4dev:adnk4:WOKAPI package /adv_23/WOK/k4dev/adnk4/src/WOKAPI WOKAPI_Command.c
+# Dans le cad d'une duplication update GetDupName
+#;<
+proc wokOUC:Add { fshop adr typ dir lname } {
+ set root [wokOUC:GetRootName $fshop 1]
+ set dupl [wokOUC:GetDupName $fshop 1]
+ foreach name $lname {
+ set entry $root/$name
+ if { [file exists $entry] == 1 } {
+ set lem [wokUtils:FILES:FileToList $entry]
+ set new {}
+ set add 1
+ set nbe 0
+ foreach f $lem {
+ set lf [split $f]
+ set a [lindex $lf 0]
+ set t [lindex $lf 1]
+ set p [lindex $lf 2]
+ if { [file exist $p] } {
+ lappend new $f
+ incr nbe
+ }
+ if { "$a" == "$adr" && "$t" == "$typ" && "$p" == "$dir"} {
+ set add 0
+ }
+ }
+ if { $add } {
+ lappend new "$adr $typ $dir/$name"
+ }
+ wokUtils:FILES:ListToFile $new $entry
+ if { $nbe > 1 } {
+ wokUtils:FILES:touch $dupl/$name
+ }
+ } else {
+ wokUtils:FILES:ListToFile [list "$adr $typ $dir/$name"] $entry
+ chmod 0777 $entry
+ }
+ }
+ return
+}
+#;>
+# Teste si une entry existe, la detruit sinon.
+#
+#;<
+proc wokOUC:Exists { fshop adr typ name } {
+ set root [wokOUC:GetRootName $fshop]
+ set entry $root/$name
+ if { [file exists $entry] } {
+ set lem [wokUtils:FILES:FileToList $entry]
+ set new {}
+ set x 0
+ foreach f $lem {
+ set lf [split $f]
+ set a [lindex $lf 0]
+ set t [lindex $lf 1]
+ set p [lindex $lf 2]
+ if [file exist $p] {
+ lappend new $f
+ }
+ if { "$a" == "$adr" && "$t" == "$typ" } {
+ set x 1
+ }
+ }
+ if { $new != {} } {
+ wokUtils:FILES:ListToFile $new $entry
+ } else {
+ set x 0
+ unlink $entry
+ }
+ return $x
+ } else {
+ return 0
+ }
+}
+#;>
+# Retourne le full path du repertoire d'administration de wsee pour un ilot donne.
+# 1. Si create = 1 le cree dans le cas ou il n'existe pas.
+#;<
+proc wokOUC:GetRootName { fshop {create 0} } {
+ set diradm [wokparam -e %VC_ROOT $fshop]/adm/[wokinfo -n [wokinfo -s $fshop]]/OUC_ENTRIES
+ if [file exists $diradm] {
+ return $diradm
+ } else {
+ if { $create } {
+ msgprint -c WOKVC -i "Creating file $diradm"
+ mkdir -path $diradm
+ chmod 0777 $diradm
+ return $diradm
+ } else {
+ return {}
+ }
+ }
+}
+proc wokOUC:GetDupName { fshop {create 0} } {
+ set diradm [wokparam -e %VC_ROOT $fshop]/adm/[wokinfo -n [wokinfo -s $fshop]]/OUC_DUP
+ if [file exists $diradm] {
+ return $diradm
+ } else {
+ if { $create } {
+ msgprint -c WOKVC -i "Creating file $diradm"
+ mkdir -path $diradm
+ chmod 0777 $diradm
+ return $diradm
+ } else {
+ return {}
+ }
+ }
+}
+
+#;>
+# remplit root avec le contenu de fshop sauf le workbench appele ref.
+# prevoir de faire mv root ->root-sav et d'ecrire dans root neuve.
+#;<
+proc wokOUC:Make { fshop {wr ref} } {
+ set wr ref
+ set root [wokOUC:GetRootName $fshop 1]
+ foreach adr [wokFind $fshop] {
+ if {"[wokinfo -t $adr]" == "devunit" } {
+ if { "[wokinfo -n [wokinfo -w $adr]]" != "$wr" } {
+ set typ [uinfo -t $adr]
+ set dir [wokinfo -p source:. ${adr}]
+ set lname {}
+ foreach f [glob -nocomplain $dir/*] {
+ if { "[set n [wokOUC:Valid $f]]" != {} } {
+ lappend lname $n
+ }
+ }
+ puts "Creer les entries de $adr avec:"
+ ;#puts "lname = $lname"
+ wokOUC:Add $fshop $adr $typ $dir $lname
+ }
+ }
+ }
+ return
+}
+
+proc wokOUC:Clean { fshop {type entries} } {
+ switch -- $type {
+ entries {
+ set root [wokOUC:GetRootName $fshop]
+ foreach f [glob -nocomplain $root/*] {
+ if [catch { unlink $f } status] {
+ puts "Clean: $status"
+ }
+ }
+ }
+
+ dup {
+ set duproot [wokOUC:GetDupName $fshop]
+ foreach f [glob -nocomplain $duproot/*] {
+ if [catch { unlink $f } status] {
+ puts "Clean: $status"
+ }
+ }
+ }
+ }
+ return
+}
+
+proc wokOUC:Dump { fshop {type entries} } {
+ switch -- $type {
+
+ entries {
+ set root [wokOUC:GetRootName $fshop]
+ foreach f [glob -nocomplain $root/*] {
+ puts $f
+ }
+ }
+
+ dup {
+ set duproot [wokOUC:GetDupName $fshop]
+ foreach f [glob -nocomplain $duproot/*] {
+ puts $f
+ }
+ }
+ }
+ return
+}
+
+proc wokOUC:Valid { p } {
+ if { ![file isdirectory $p] } {
+ set e [file extension [set n [file tail $p]]]
+ if { ![string match {*~} $n] } {
+ if { ![string match {*~} $e] } {
+ if { ![string match {#*#} $n] } {
+ if { ![string match {*-sav} $e] } {
+ return $n
+ } else {
+ return {}
+ }
+ } else {
+ return {}
+ }
+ } else {
+ return {}
+ }
+ } else {
+ return {}
+ }
+ } else {
+ return {}
+ }
+
+
+}
+
+
+
+
+
+#;>
+# Pour la commande
+#;<
+proc wokOUC:Tree:Print { w } {
+ global IWOK_WINDOWS
+ global IWOK_GLOBALS
+ set fshop $IWOK_WINDOWS($w,OUC,shop)
+ set root $IWOK_WINDOWS($w,OUC,root)
+ set hlist $IWOK_WINDOWS($w,OUC,hlist)
+ set filima [tix getimage textfile]
+ foreach e [lsort [readdir $root]] {
+ set lem [wokUtils:FILES:FileToList $root/$e]
+ if { $lem != {} } {
+ $hlist add $e -itemtype imagetext -text $e \
+ -image $filima \
+ -data [list HEADER {}]
+ set upd {}
+ foreach f $lem {
+ set lf [split $f]
+ if { [file exists [lindex $lf 2]] } {
+ lappend upd $f
+ set adr [lindex $lf 0]
+ $hlist add ${e}^${adr} -itemtype imagetext \
+ -text [join [lrange [split $adr :] 1 2] :] \
+ -image $IWOK_GLOBALS(image,[lindex $lf 1]) \
+ -data [list PATH [list $adr lindex $lf 2]]
+ }
+ }
+ update
+ if { $upd != {} } {
+ wokUtils:FILES:ListToFile $upd $root/$e
+ } else {
+ unlink $root/$e
+ }
+ } else {
+ unlink $root/$e
+ }
+ }
+ return
+}
--- /dev/null
+This window allows consultation of all the parameters in the current session. It contains three
+options:
+
+
+ <ByName>: Displays all the classes of parameters.
+ Open the item and click on the parameter name to get the value.
+
+ If you do not know the precise class name, use the automatic completion in the field "Class Name"
+ with the space bar. Operate similarly for the parameter name.
+
+ In any case, if more than one completion is possible, the right window indicates all the possible
+ completions. Double-click to select the name.
+
+
+ <ByFile>: Displays the directories used in the search for .edl files when evaluating a parameter.
+ The number in parentheses preceding the directory name indicates the order in which the
+ directories are scanned during parameter evaluation.
+
+
+ <Modify>: Modifies a parameter.
+
+ 1. Enter the name of the parameter in the field "Parameter Name" (if the parameter already
+ exists, use the space bar for automatic completion).
+
+ 2. To modify a given value, enter a new value in the field "Current value".
+ To add a value to the existing one, enter this value in the field "Append".
+
+ 3. Choose the scope where the modifications are performed (possible scopes are the development
+ units, the current workbench, the current workshop and the current factory).
+
+ 3. Choose the DBMS/platforms on which the modifications are performed. By default, the current
+ DBMS and workstation are selected.
+
+ 4. <Show> displays the generated EDL file. This file may be edited in the window where it is
+ displayed.
+
+ 5. <Write> writes the result into the given file.
+
+ 6. <Append> writes the result at the end of the given file.
+
+ 7. <Cancel> cancels the modification.
--- /dev/null
+;# (((((((((((((((((( P R O P E R T I E S ))))))))))))))))))))
+;#
+;#
+proc wokProperties {dir location itype } {
+ global IWOK_GLOBALS
+
+ set w [wokTPL prop$location]
+ if [winfo exists $w ] {
+ destroy $w
+ }
+
+ toplevel $w
+ wm title $w "Properties of ($location)"
+ wm geometry $w 684x439
+
+ wokButton setw [list properties $w]
+
+ set boldfnt [tix option get bold_font]
+ set IWOK_GLOBALS($w,PROP,toplevel) $w
+ set IWOK_GLOBALS($w,PROP,location) $location
+
+
+ menubutton $w.file -menu $w.file.m -text File -underline 0 -takefocus 0
+ menu $w.file.m
+ $w.file.m add command -label "Close " -underline 0 -command [list wokPROP:Kill $w]
+
+ set notes [tixNoteBook $w.notes -ipadx 1 -ipady 1]
+ tixForm $w.file
+ tixForm $notes -top $w.file -left 2 -right %99 -bottom %99
+
+ $notes.nbframe configure -backpagecolor grey51
+
+ if [wokinfo -x $location] {
+ set type [wokinfo -t $location]
+ set name [wokinfo -n $location]
+ } else {
+ regsub {trig_} $itype "" type
+ }
+
+ ;#bind $w <Destroy> { if [winfo exists %W] {wokPROP:Kill %W} }
+
+ switch $type {
+
+ session {
+ $notes add pag1 -createcmd "wokPROP:NOT wokPROP:vrs $w $notes pag1" \
+ -label "WOK Version" -raisecmd [list wokPROP:UPD $w]
+ $notes add pag2 -createcmd "wokPROP:NOT wokPROP:pkg $w $notes pag2" \
+ -label "Packages used" -raisecmd [list wokPROP:UPD $w]
+ $notes add pag3 -createcmd "wokPROP:NOT wokPROP:env $w $notes pag3" \
+ -label "Environment" -raisecmd [list wokPROP:UPD $w]
+ $notes add pag4 -createcmd "wokPROP:NOT wokPROP:pth $w $notes pag4" \
+ -label "Pathes" -raisecmd [list wokPROP:UPD $w]
+ ;#$notes add pag5 -createcmd "wokPROP:NOT wokPROP:EDF $w $notes pag5 $location" \
+ ;# -label "Editor" -raisecmd [list wokPROP:UPD $w]
+ $notes add pag6 -createcmd "wokPROP:NOT wokPROP:EDL $w $notes pag6 $location" \
+ -label "Edl" -raisecmd [list wokPROP:UPD $w]
+ }
+
+ factory {
+ $notes add pag1 -createcmd "wokPROP:NOT wokPROP:factory $w $notes pag1 $location" \
+ -label "General" -raisecmd [list wokPROP:UPD $w]
+ $notes add pag2 -createcmd "wokPROP:NOT wokPROP:EDL $w $notes pag2 $location" \
+ -label "Edl" -raisecmd [list wokPROP:UPD $w]
+ }
+
+ warehouse {
+ $notes add pag1 -createcmd "wokPROP:NOT wokPROP:warehouse $w $notes pag1 $location" \
+ -label "General" -raisecmd [list wokPROP:UPD $w]
+ $notes add pag2 -createcmd "wokPROP:NOT wokPROP:EDL $w $notes pag2 $location" \
+ -label "Edl" -raisecmd [list wokPROP:UPD $w]
+ }
+
+ parcel {
+ $notes add pag1 -createcmd "wokPROP:NOT wokPROP:parcel $w $notes pag1 $location" \
+ -label "General" -raisecmd [list wokPROP:UPD $w]
+ $notes add pag2 -createcmd "wokPROP:NOT wokPROP:parcelExtRef $w $notes pag2 $location" \
+ -label "External References" -raisecmd [list wokPROP:UPD $w]
+ }
+
+ workshop {
+ $notes add pag1 -createcmd "wokPROP:NOT wokPROP:workshop $w $notes pag1 $location" \
+ -label "General" -raisecmd [list wokPROP:UPD $w]
+ $notes add pag2 -createcmd "wokPROP:NOT wokPROP:workshopconfig $w $notes pag2 $location" \
+ -label "Parcel Configuration" -raisecmd [list wokPROP:UPD $w]
+ $notes add pag3 -createcmd "wokPROP:NOT wokPROP:workbenchtree $w $notes pag3 $location" \
+ -label "Workbench Tree" -raisecmd [list wokPROP:UPD $w]
+ $notes add pag4 -createcmd "wokPROP:NOT wokPROP:EDL $w $notes pag4 $location" \
+ -label "Edl" -raisecmd [list wokPROP:UPD $w]
+ }
+
+ workbench {
+ $notes add pag1 -createcmd "wokPROP:NOT wokPROP:workbench $w $notes pag1 $location" \
+ -label "General" -raisecmd [list wokPROP:UPD $w]
+ $notes add pag2 -createcmd "wokPROP:NOT wokPROP:workbenchtk $w $notes pag2 $location" \
+ -label "Toolkits" -raisecmd [list wokPROP:UPD $w]
+ $notes add pag3 -createcmd "wokPROP:NOT wokPROP:EDL $w $notes pag3 $location" \
+ -label "Edl" -raisecmd [list wokPROP:UPD $w]
+ }
+
+ devunit {
+ $notes add pag1 -createcmd "wokPROP:devunit $w $notes pag1 $location" \
+ -label "General" -raisecmd [list wokPROP:UPD $w]
+ $notes add pag2 -createcmd "wokPROP:arb $w $notes pag2 $name $location" \
+ -label "Suppliers" -raisecmd [list wokPROP:UPD $w]
+ $notes add pag3 -createcmd "wokPROP:clt $w $notes pag3 $name $location" \
+ -label "Clients" -raisecmd [list wokPROP:UPD $w]
+ $notes add pag4 -createcmd "wokPROP:NOT wokPROP:BLD $w $notes pag4 $location" \
+ -label "Building steps" -raisecmd [list wokPROP:UPD $w]
+ $notes add pag5 -createcmd "wokPROP:NOT wokPROP:EDL $w $notes pag5 $location" \
+ -label "Edl" -raisecmd [list wokPROP:UPD $w]
+ }
+
+ terminal {
+ set data [wokNAV:tlist:TermData $IWOK_GLOBALS(toplevel) $dir]
+ set name [lindex $data end]
+ $notes add pag1 -createcmd "wokPROP:NOT wokPROP:terminal $w $notes pag1 $name" \
+ -label "General" -raisecmd [list wokPROP:UPD $w]
+ }
+
+ Repository {
+ set data [wokNAV:tlist:TermData $IWOK_GLOBALS(toplevel) $dir]
+ ;# data = WOK:k4dev:Repository trig_Repository Repository image37 wokGetworkbenchdate {params}
+ regsub {:Repository} [lindex $data 0] "" fshop
+
+ }
+
+ Queue {
+ set data [wokNAV:tlist:TermData $IWOK_GLOBALS(toplevel) $dir]
+ ;# data = WOK:k4dev:Queue trig_Queue Queue image37 wokGetworkbenchdate {params}
+ regsub {:Queue} [lindex $data 0] "" location
+ $notes add pag1 -createcmd "wokPROP:NOT wokPROP:Queue $w $notes pag1 $location" \
+ -label "General" -raisecmd [list wokPROP:UPD $w]
+ }
+
+ }
+ return
+}
+;#
+;# ((((((( F I L E I N T E G R A T I O N )))))))
+;#
+proc wokPROP:Queue { adr nb page location} {
+ global IWOK_GLOBALS
+ set w [$nb subwidget $page]
+ frame $w.top -relief flat -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+ set qdir [wokStore:Report:GetRootName $location]
+ if { $qdir != {} } {
+ set text [text $w.top.jnl -relief flat -font $IWOK_GLOBALS(font)]
+ $text insert end "Queue in directory: $qdir\n\n"
+ set journal [wokIntegre:Journal:GetName $location]
+ if { $journal != {} } {
+ set dir [file dirname $journal]
+ $text insert end "Journal in directory: $dir\n\n"
+ foreach j [wokIntegre:Journal:List $location] {
+ $text insert end "[format "%15s %-9d" [file tail $j] [file size $j]]\n"
+ }
+ set t [fmtclock [file mtime $journal]]
+ set str [format "%15s %-8d(Last modified %s)" [file tail $journal] [file size $journal] $t]
+ $text insert end "$str\n\n"
+ set scoop [wokIntegre:Scoop:Read $location]
+ if { $scoop != {} } {
+ $text insert end "Last integration: \n\n $scoop "
+ }
+ $text configure -state disabled
+ tixForm $text -top 2 -left 2 -bottom %99 -right %99
+ }
+ }
+ return
+}
+;#
+;# ((((((( A R B R E D E P E N D A N C E S )))))))
+;#
+proc wokPROP:arb { adr nb page name location} {
+ global IWOK_GLOBALS
+ set w [$nb subwidget $page]
+ frame $w.top -relief sunken -bd 1
+ button $w.but -text "Click here to run" -command [list DependenceTree $w.top.tree $name $location]
+ label $w.lab
+ eval "proc wokPROP:LabArb {} { return $w.lab }"
+ tixForm $w.but -top 2
+ tixForm $w.top -top $w.but -left 2 -right %99 -bottom $w.lab
+ tixForm $w.lab -left 2 -right %99 -bottom %99
+ return
+}
+
+;#
+;# ((((((( A R B R E C L I E N T S )))))))
+;#
+proc wokPROP:clt { adr nb page name location} {
+ global IWOK_GLOBALS ClientTree_FileName
+ set w [$nb subwidget $page]
+
+ frame $w.top -relief sunken -bd 1
+ button $w.but -text "Click here to run" -command [list ClientTree $w.top.treeclt $name $location $w.meter]
+ label $w.lab
+ tixMeter $w.meter -value 0. -relief flat
+ $w.meter config -value 0 -text " "
+ tixLabelEntry $w.filename -label "Header Name :" -options {entry.width 20 label.width 0 entry.textVariable ClientTree_FileName}
+ eval "proc wokPROP:LabClt {} { return $w.lab }"
+ tixForm $w.but -top 2
+ tixForm $w.meter -top 4 -left $w.but -right %99
+ tixForm $w.filename -top $w.but -left 2 -right %99
+ tixForm $w.top -left 2 -right %99 -bottom $w.lab -top $w.filename
+ tixForm $w.lab -left 2 -right %99 -bottom %99
+
+ return
+}
+
+proc wokPROP:Meter {meter maxrange progress} {
+ set can [$meter subwidget canvas]
+ set width [expr [winfo width $can] + 2]
+ $meter configure -width $width
+
+ set step [expr {100.0 / $maxrange}]
+ set progress [expr {$progress + $step }]
+ set value [expr $progress * 0.01]
+ set text [expr int($progress)]%
+
+ $meter config -value $value -text $text
+
+ return $progress
+}
+
+proc wokPROP:BrowseArb { location item } {
+ if { "[info procs wokPROP:LabArb]" != "" } {
+ set lab [wokPROP:LabArb]
+ set ud [lindex [split $item .] end]
+ set lud [woklocate -u $ud $location]
+ if { $lud != {} } {
+ set type [uinfo -t $lud]
+ $lab configure -text "Location: $lud ( $type )"
+ } else {
+ $lab configure -text ""
+ }
+ }
+ return
+}
+;#
+;# ((((((( P A C K A G E S U T I L I S E S )))))))
+;#
+proc wokPROP:vrs { adr nb page location} {
+ global IWOK_GLOBALS
+ global env
+ set w [$nb subwidget $page]
+ frame $w.top -relief flat -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+ set lm {}
+ foreach name [lsort [array names env WOK*]] {
+ lappend lm [list $name $env($name)]
+ }
+ set vrs [file tail $env(WOKHOME)]
+ ;#set image [tix getimage wok]
+ label $w.top.ima ;#-image $image
+ label $w.top.vrs -font $IWOK_GLOBALS(boldfont) -text "Used: $vrs"
+ set txt [text $w.top.msg -relief flat -font $IWOK_GLOBALS(font)]
+ wokPROP:Nice $txt $lm
+ tixForm $w.top.ima -top 12 -left 6
+ tixForm $w.top.vrs -top [list $w.top.ima 10]
+ tixForm $w.top.msg -top [list $w.top.vrs 20] -left 2
+ return
+}
+
+proc wokPROP:pkg { adr nb page args} {
+ global IWOK_GLOBALS
+ set w [$nb subwidget $page]
+ frame $w.top -relief flat -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+ set lm {}
+ foreach name [lsort [package names]] {
+ lappend lm [list $name [package version $name]]
+ }
+ tixScrolledText $w.top.msg
+ set txt [$w.top.msg subwidget text]
+ $txt configure -relief flat -font $IWOK_GLOBALS(font)
+ wokPROP:Nice $txt $lm
+ tixForm $w.top.msg -left 1 -top 1 -right %100 -bottom %100
+ return
+}
+;#
+;# ((((((( P A T H E S )))))))
+;#
+proc wokPROP:pth { adr nb page args } {
+
+ global env
+ global IWOK_GLOBALS
+
+ set w [$nb subwidget $page]
+ frame $w.top -relief flat -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+
+ tixPanedWindow $w.top.pane -orient horizontal -paneborderwidth 0 -separatorbg gray50
+ pack $w.top.pane -side top -expand yes -fill both -padx 1 -pady 1
+
+ set p1 [$w.top.pane add tree -min 100 -size 220]
+ set p2 [$w.top.pane add text]
+
+ set tree [tixTree $p1.tree]
+ set text [tixScrolledText $p2.text]
+
+ pack $p1.tree -expand yes -fill both -padx 1 -pady 1
+ pack $p2.text -expand yes -fill both -padx 1 -pady 1 -padx 3
+
+
+ set hlist [$tree subwidget hlist]
+ $hlist config -indicator 1 -selectmode single -separator "^" -drawbranch 0
+ set lab [$text subwidget text]
+ $lab configure -font $IWOK_GLOBALS(font) -relief flat
+ set pthima [tix getimage path]
+ set dirima [tix getimage folder]
+ set filima [tix getimage textfile]
+ set boldstyle [tixDisplayStyle imagetext -fg #000080 -font $IWOK_GLOBALS(boldfont)]
+ $tree config -opencmd [list wokPROP:pth:Open $dirima $filima $tree $hlist ] \
+ -browsecmd [list wokPROP:pth:Browse $lab $dirima $filima $tree $hlist ]
+ $hlist add ^
+ foreach P [lsort [array names env *PATH*]] {
+ $hlist add ^${P} -itemtype imagetext -style $boldstyle -text ${P} -image $pthima -data [list PATH $env($P)]
+ $tree setmode ^${P} open
+ }
+ return
+}
+
+proc wokPROP:pth:Open { dirima filima tree hlist dir } {
+ if {[set children [$hlist info children $dir]] != {}} {
+ foreach kid $children {
+ $hlist show entry $kid
+ }
+ } else {
+ set type [lindex [set data [$hlist info data $dir]] 0]
+ switch -- $type {
+ PATH {
+ set PT [lindex $data 1]
+ if { [string match *:* $PT] != 0 } {
+ set lpp [split $PT :]
+ } else {
+ set lpp [split $PT ]
+ }
+ set i 1
+ foreach cc $lpp {
+ if { $cc != {} } {
+ if {[string match *^* $cc] == 0 } {
+ $hlist add ${dir}^${cc} -itemtype imagetext -image $dirima \
+ -text [format "#%-2s %s" $i ${cc}] -data [list PTHDIR $cc]
+ $tree setmode ${dir}^${cc} open
+ incr i
+ }
+ }
+ }
+ }
+
+ PTHDIR {
+ set pdir [lindex $data 1]
+ if ![catch { set lfdir [readdir [glob -nocomplain $pdir]] }] {
+ foreach f [lsort $lfdir] {
+ if ![file isdirectory $pdir/$f] {
+ if {[string match *^* ${f}] == 0 } {
+ $hlist add ${dir}^${f} -itemtype imagetext -image $filima \
+ -text $f -data [list TERMINAL $pdir/$f]
+ }
+ } else {
+ if {[string match *^* ${f}] == 0 } {
+ $hlist add ${dir}^${f} -itemtype imagetext -image $filima \
+ -text $f -data [list PTHDIR $pdir/$f]
+ $tree setmode ${dir}^${f} open
+ }
+ }
+ }
+ }
+ }
+
+ }
+ }
+ return
+}
+
+
+proc wokPROP:pth:Browse { lab dirima filima tree hlist dir } {
+ set type [lindex [set data [$hlist info data $dir]] 0]
+ if { "$type" == "TERMINAL" } {
+ set location [lindex $data 1]
+ if [file exists $location] {
+ catch { unset tt }
+ file lstat $location tt
+ if [file writable $location] {
+ set wrt yes
+ } else {
+ set wrt no
+ }
+ set exe no; if [file executable $location] { set exe yes }
+ set rea no; if [file readable $location] { set rea yes }
+ set lm [list \
+ [list separator 1] \
+ [list Location $location] \
+ [list separator 1] \
+ [list Size "$tt(size) (bytes)"]\
+ [list Type $tt(type)]\
+ [list separator 1]\
+ [list Created [string range [fmtclock $tt(ctime)] 4 18]]\
+ [list Modified [string range [fmtclock $tt(mtime)] 4 18]]\
+ [list Accessed [string range [fmtclock $tt(atime)] 4 18]]\
+ [list separator 1]\
+ [list Readable $rea]\
+ [list Writable $wrt]\
+ [list Executable $exe]\
+ ]
+ wokPROP:Nice $lab $lm
+ }
+ }
+ return
+}
+;#
+;# ((((((( T A B L E A U E N V )))))))
+;#
+proc wokPROP:env { adr nb page args} {
+ global IWOK_GLOBALS
+ global env
+ set w [$nb subwidget $page]
+ frame $w.top -relief sunken -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+ tixScrolledText $w.top.text ; set text [$w.top.text subwidget text]
+ $text config -font $IWOK_GLOBALS(font) -relief flat
+ button $w.top.sea -text "Search" -command [list wokSEA $text]
+ tixForm $w.top.sea -top 0 -left 1
+ tixForm $w.top.text -top $w.top.sea -left 1 -right %99 -bottom %99
+ set maxl 0
+ foreach name [array names env] {
+ lappend lpack $name
+ if {[string length $name] > $maxl} {
+ set maxl [string length $name]
+ }
+ }
+ set maxl [expr {$maxl + 1}]
+ foreach name [lsort [array names env]] {
+ $text insert end [format "%-*s = %s" $maxl $name $env($name)]\n
+ update
+ }
+ $text see 1.0
+ return
+}
+
+proc wokPROP:EDF { adr nb page location} {
+ global IWOK_GLOBALS
+ set w [$nb subwidget $page]
+ frame $w.top -relief flat -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+ return
+}
+
+proc wokPROP:EDL { adr nb page location} {
+ global IWOK_GLOBALS
+ set w [$nb subwidget $page]
+ frame $w.top -relief flat -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+
+ set p1 $w.top
+ set p2 $w.top
+
+ set tree [tixTree $p1.tree]
+ frame $p1.fram -relief flat -bd 1
+ set btn [button $p1.fram.load -text "Contents" -width 6 -command wokPROP:EDL:see -state disabled]
+ pack $btn -expand yes -fill both -padx 8 -pady 70
+ set labatt [text $p2.text]
+
+ tixForm $p1.tree -left 1 -top 1 -right %80 -bottom %50
+ tixForm $p1.fram -left $p1.tree -top 10 -right %99 -bottom $p2.text
+
+ tixForm $p2.text -left 2 -right %99 -bottom %99 -top $p1.tree
+
+ $labatt configure -relief flat -font $IWOK_GLOBALS(font)
+ set filima [tix getimage textfile]
+ set pthima [tix getimage path]
+ set hlist [$tree subwidget hlist]
+ $hlist config -indicator 1 -selectmode single -separator "^" -drawbranch 1
+ set boldstyle [tixDisplayStyle imagetext -fg #000080 -font $IWOK_GLOBALS(boldfont)]
+ set boldsimple [tixDisplayStyle imagetext -font $IWOK_GLOBALS(boldfont)]
+ $tree config -opencmd [list wokPROP:EDL:Open $btn $boldstyle $filima $labatt $tree $hlist] \
+ -browsecmd [list wokPROP:EDL:Browse $btn $labatt $tree $hlist]
+ set nb 0
+ foreach P [wokparam -L $location] {
+ if { $nb == 0 } {
+ $hlist add ${P} -itemtype imagetext -image $pthima -style $boldstyle -text ${P} \
+ -data [list PATH $P]
+ } else {
+ $hlist add ${P} -itemtype imagetext -image $pthima -style $boldsimple -text ${P} \
+ -data [list PATH $P]
+ }
+ incr nb
+ $tree setmode ${P} open
+ }
+
+ return
+}
+
+proc wokPROP:EDL:Open { btn boldstyle filima att tree hlist dir } {
+ $btn configure -state disabled
+ if {[set children [$hlist info children $dir]] != {}} {
+ foreach kid $children {
+ $hlist show entry $kid
+ }
+ } else {
+ set data [$hlist info data $dir]
+ set pdir [lindex $data 1]
+ foreach f [lsort [glob -nocomplain $pdir/*.edl]] {
+ set name [file tail $f]
+ if { [string match *_DEFAULT.edl $name] } {
+ $hlist add ${dir}^${f} -itemtype imagetext -image $filima -style $boldstyle \
+ -text $name -data [list TERMINAL $f]
+ } else {
+ $hlist add ${dir}^${f} -itemtype imagetext -image $filima \
+ -text $name -data [list TERMINAL $f]
+ }
+ }
+ }
+ return
+}
+
+proc wokPROP:EDL:Browse { btn att tree hlist dir } {
+ set type [lindex [set data [$hlist info data $dir]] 0]
+ if { "$type" == "TERMINAL" } {
+ set location [lindex $data 1]
+ if [file exists $location] {
+ catch { unset tt }
+ file lstat $location tt
+ if [file writable $location] {
+ set wrt yes
+ } else {
+ set wrt no
+ }
+ set rea no; if [file readable $location] { set rea yes }
+ set lm [list \
+ [list separator 1] \
+ [list Location $location] \
+ [list separator 1] \
+ [list Size "$tt(size) (bytes)"]\
+ [list Type $tt(type)]\
+ [list separator 1]\
+ [list Created [string range [fmtclock $tt(ctime)] 4 18]]\
+ [list Modified [string range [fmtclock $tt(mtime)] 4 18]]\
+ [list Accessed [string range [fmtclock $tt(atime)] 4 18]]\
+ [list separator 1]\
+ [list Readable $rea]\
+ [list Writable $wrt]\
+ ]
+ wokPROP:Nice $att $lm
+ $btn configure -state active
+ eval "proc wokPROP:EDL:see {} {wokEDF:EditFile $location}"
+ }
+ }
+ return
+}
+;#
+;# ((((((( F A C T O R Y )))))))
+;#
+proc wokPROP:factory { adr nb page location} {
+ global IWOK_GLOBALS
+ set w [$nb subwidget $page]
+ frame $w.top -relief flat -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+ set lm {}
+ foreach tp [wokinfo -T $location] {
+ if { ![string match {*%File} [wokinfo -d $tp $location]] } {
+ lappend lm [list $tp [wokinfo -p $tp $location]]
+ }
+ }
+ label $w.top.ima
+ set img [image create compound -window $w.top.ima]
+ $img add image -image [tix getimage factory] ; $img add text -text " factory"
+ $w.top.ima config -image $img
+
+ tixScrolledText $w.top.msg -scrollbar y
+ set txt [$w.top.msg subwidget text]
+ $txt configure -relief flat -font $IWOK_GLOBALS(font)
+ wokPROP:Nice $txt $lm
+ tixForm $w.top.ima -top 12 -left 6
+ tixForm $w.top.msg -top [list $w.top.ima 20] -left 2
+ return
+}
+;#
+;# ((((((( W A R E H O U S E )))))))
+;#
+proc wokPROP:warehouse { adr nb page location} {
+ global IWOK_GLOBALS
+ set w [$nb subwidget $page]
+ frame $w.top -relief flat -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+ set lm {}
+ foreach tp [wokinfo -T $location] {
+ lappend lm [list $tp [wokinfo -p ${tp}:. $location]]
+ }
+
+ label $w.top.ima
+ set img [image create compound -window $w.top.ima]
+ $img add image -image [tix getimage warehouse] ; $img add text -text " warehouse"
+ $w.top.ima config -image $img
+
+ tixScrolledText $w.top.msg -scrollbar y
+ set txt [$w.top.msg subwidget text]
+ $txt configure -relief flat -font $IWOK_GLOBALS(font)
+ wokPROP:Nice $txt $lm
+ tixForm $w.top.ima -top 12 -left 6
+ tixForm $w.top.msg -top [list $w.top.ima 20] -left 2
+ return
+}
+
+proc wokPROP:parcel { adr nb page location} {
+ global IWOK_GLOBALS
+ set w [$nb subwidget $page]
+ frame $w.top -relief flat -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+ set lm {}
+ foreach tp [wokinfo -T $location] {
+ lappend lm [list $tp [wokinfo -p ${tp}:. $location]]
+ }
+
+ label $w.top.ima
+ set img [image create compound -window $w.top.ima]
+ $img add image -image [tix getimage parcel] ; $img add text -text " parcel"
+ $w.top.ima config -image $img
+
+ tixScrolledText $w.top.msg -scrollbar y
+ set txt [$w.top.msg subwidget text]
+ $txt configure -relief flat -font $IWOK_GLOBALS(font)
+ wokPROP:Nice $txt $lm
+ tixForm $w.top.ima -top 12 -left 6
+ tixForm $w.top.msg -top [list $w.top.ima 20] -left 2
+ return
+}
+
+proc wokPROP:parcelExtRef { adr nb page location} {
+ global IWOK_GLOBALS
+ set w [$nb subwidget $page]
+ frame $w.top -relief flat -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+
+ tixPanedWindow $w.top.pane -orient horizontal -paneborderwidth 0 -separatorbg gray50
+ pack $w.top.pane -side top -expand yes -fill both -padx 1 -pady 1
+ set p1 [$w.top.pane add tree -min 100 -size 240]
+ set p2 [$w.top.pane add text]
+
+ set tree [tixTree $p1.tree]
+ set text [text $p2.text]
+
+ pack $p1.tree -expand yes -fill both -padx 1 -pady 1
+ pack $p2.text -expand yes -fill both -padx 1 -pady 1 -padx 3
+
+ set labatt $text
+ $labatt configure -relief flat -font $IWOK_GLOBALS(font)
+
+ set hlist [$tree subwidget hlist]
+ $hlist config -indicator 1 -selectmode single -separator "^" -drawbranch 1
+ set boldstyle [tixDisplayStyle imagetext -fg #000080 -font $IWOK_GLOBALS(boldfont)]
+
+ $tree config -opencmd [list wokPROP:parcelExtRef:Open $labatt $tree $hlist] \
+ -browsecmd [list wokPROP:parcelExtRef:Browse $labatt $tree $hlist]
+
+ foreach unit [pinfo -a $location] {
+ set type [lindex $unit 0]
+ set name [lindex $unit 1]
+ set full ${location}:${name}
+ set path [lindex [lindex [uinfo -Fpl -TEXTERNLIB $full] 0] end]
+ if { "$path" != {} } {
+ $hlist add ${name} -itemtype imagetext -style $boldstyle -text ${name} \
+ -image $IWOK_GLOBALS(image,$type) -data [list PATH $path $full]
+ $tree setmode ${name} open
+ }
+ }
+ return
+}
+
+proc wokPROP:parcelExtRef:Open { att tree hlist dir } {
+ if {[set children [$hlist info children $dir]] != {}} {
+ foreach kid $children {
+ $hlist show entry $kid
+ }
+ } else {
+ set data [$hlist info data $dir]
+ set ext [wokUtils:FILES:FileToList [lindex $data 1]]
+ foreach p $ext {
+ $hlist add ${dir}^${p} -itemtype imagetext -text $p -data [list EDLSTRING $p [lindex $data 2]]
+ }
+ }
+ return
+}
+proc wokPROP:parcelExtRef:Browse { att tree hlist dir } {
+ global IWOK_GLOBALS
+ set type [lindex [set data [$hlist info data $dir]] 0]
+ switch -- $type {
+ EDLSTRING {
+ set edlstring [lindex $data 1]
+
+ set adr [lindex $data 2] ; set val {} ; catch {set val [wokparam -e %${edlstring} $adr] } ;
+ set v1 "Value in $adr : \n $val"
+ set ici [wokcd] ; set wal {} ; catch {set wal [wokparam -e %${edlstring} $ici] }
+ set v2 "Value in $ici : \n $wal"
+ wokReadList $att [list $v1 {} {} $v2]
+ }
+ }
+ return
+}
+;#
+;# ((((((( W O R K S H O P )))))))
+;#
+proc wokPROP:workshop { adr nb page location} {
+ global IWOK_GLOBALS
+ set w [$nb subwidget $page]
+ frame $w.top -relief flat -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+ set lm {}
+
+ foreach tp [wokinfo -T $location] {
+ lappend lm [list $tp [wokinfo -p ${tp}:. $location]]
+ }
+ label $w.top.ima
+ set img [image create compound -window $w.top.ima]
+ $img add image -image [tix getimage workshop] ; $img add text -text " workshop"
+ $w.top.ima config -image $img
+
+ tixScrolledText $w.top.msg -scrollbar y
+ set txt [$w.top.msg subwidget text]
+ $txt configure -relief flat -font $IWOK_GLOBALS(font)
+ wokPROP:Nice $txt $lm
+ tixForm $w.top.ima -top 12 -left 6
+ tixForm $w.top.msg -top [list $w.top.ima 20] -left 2
+ return
+}
+proc wokPROP:workshopconfig { adr nb page location} {
+ global IWOK_GLOBALS
+ set w [$nb subwidget $page]
+ frame $w.top -relief flat -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+ set fact [wokinfo -N $location]
+
+ tixScrolledText $w.top.used ; set tused [$w.top.used subwidget text]
+ tixScrolledText $w.top.avai ; set tavai [$w.top.avai subwidget text]
+
+ label $w.top.image
+ set img [image create compound -window $w.top.image]
+ $img add image -image [tix getimage parcel] ; $img add text -text " Parcels"
+ $w.top.image config -image $img
+
+ label $w.top.iused -text "Used:" ; label $w.top.iavai -text "Available:"
+
+ tixForm $w.top.image -top 8 -left 6
+ tixForm $w.top.iused -top [list $w.top.image 20] -left 6
+ tixForm $w.top.iavai -top [list $w.top.image 20] -left [list $w.top.iused 240]
+ tixForm $w.top.used -left 2 -top $w.top.iused -bottom %99 -right %50
+ tixForm $w.top.avai -left $w.top.used -top $w.top.iused -bottom %99 -right %99
+
+ wokReadList $tused [sinfo -p $location]
+ wokReadList $tavai [lsort [Winfo -p $fact:[finfo -W $fact]]]
+
+ $tused config -state disabled
+ $tavai config -state disabled
+
+ update
+ return
+}
+;#
+;# ((((((( W O R K B E N C H )))))))
+;#
+proc wokPROP:workbench { adr nb page location} {
+ global IWOK_GLOBALS
+ set w [$nb subwidget $page]
+ frame $w.top -relief flat -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+ set lm {}
+
+ foreach tp [wokinfo -T $location] {
+ lappend lm [list $tp [wokinfo -p ${tp}:. $location]]
+ }
+ label $w.top.ima
+ set img [image create compound -window $w.top.ima]
+ $img add image -image [tix getimage workbench] ; $img add text -text " workbench"
+ $w.top.ima config -image $img
+
+ tixScrolledText $w.top.msg -scrollbar y
+ set txt [$w.top.msg subwidget text]
+ $txt configure -relief flat -font $IWOK_GLOBALS(font)
+ wokPROP:Nice $txt $lm
+ tixForm $w.top.ima -top 12 -left 6
+ tixForm $w.top.msg -top [list $w.top.ima 20] -left 2
+ return
+}
+
+
+proc wokPROP:workbenchtree { adr nb page location} {
+ global IWOK_GLOBALS
+ set w [$nb subwidget $page]
+ set image [tix getimage workbench]
+ frame $w.top -relief sunken -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+ set tree [tixTree $w.top.tree -options {hlist.separator "^" hlist.selectMode single }]
+ set hli [$tree subwidget hlist]
+ set father [wokWbtree:LoadSons $location [wokinfo -p WorkbenchListFile $location]]
+ $hli add ^
+ update
+ button $w.top.but -text "Click here to run" \
+ -command [list wokWbtree:Tree $tree $hli "" $father $image]
+ tixForm $w.top.but -top 2
+ tixForm $tree -top $w.top.but -left 2 -right %99 -bottom %99
+ return
+}
+
+proc wokPROP:workbenchtk { adr nb page location} {
+ global IWOK_GLOBALS
+ set w [$nb subwidget $page]
+ frame $w.top -relief flat -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+
+ tixPanedWindow $w.top.pane -orient horizontal -paneborderwidth 0 -separatorbg gray50
+ pack $w.top.pane -side top -expand yes -fill both -padx 1 -pady 1
+ set p1 [$w.top.pane add tree -min 100 -size 160]
+ set p2 [$w.top.pane add text]
+
+ set tree [tixTree $p1.tree]
+ set text [text $p2.text]
+
+ pack $p1.tree -expand yes -fill both -padx 1 -pady 1
+ pack $p2.text -expand yes -fill both -padx 1 -pady 1 -padx 3
+
+ set labatt $text
+ $labatt configure -relief flat -font $IWOK_GLOBALS(font)
+
+ set hlist [$tree subwidget hlist]
+ $hlist config -indicator 1 -selectmode single -separator "^" -drawbranch 1
+ set boldstyle [tixDisplayStyle imagetext -fg #000080 -font $IWOK_GLOBALS(boldfont)]
+ $tree config -opencmd [list wokPROP:workbenchtk:Open $labatt $tree $hlist] \
+ -browsecmd [list wokPROP:workbenchtk:Browse $labatt $tree $hlist]
+
+ foreach P [w_info -k $location] {
+ set packages [woklocate -p ${P}:PACKAGES]
+ $hlist add ${P} -itemtype imagetext -style $boldstyle -text ${P} \
+ -image $IWOK_GLOBALS(image,toolkit) -data [list TOOLKIT $P $packages]
+ $tree setmode ${P} open
+ }
+
+ return
+}
+
+proc wokPROP:workbenchtk:Open { att tree hlist dir } {
+ if {[set children [$hlist info children $dir]] != {}} {
+ foreach kid $children {
+ $hlist show entry $kid
+ }
+ } else {
+ set packages [wokUtils:FILES:FileToList [lindex [$hlist info data $dir] end]]
+ foreach p $packages {
+ $hlist add ${dir}^${p} -itemtype imagetext -text $p -data [list PACKAGES $p]
+ }
+ }
+ return
+}
+proc wokPROP:workbenchtk:Browse { att tree hlist dir } {
+ global IWOK_GLOBALS
+ set type [lindex [set data [$hlist info data $dir]] 0]
+ switch -- $type {
+ TOOLKIT {
+ set P [lindex $data 1]
+ set U [woklocate -u $P]
+ if { "$U" != "" } {
+ set t [uinfo -t $U]
+ set location [wokinfo -p library:lib${P}.so $U]
+ if [file exists $location] {
+ catch { unset tt }
+ file lstat $location tt
+ set lm [list \
+ [list $t $U] \
+ [list separator 1]\
+ [list File [file tail $location]] \
+ [list Location [file dirname $location]] \
+ [list separator 1] \
+ [list Size "$tt(size) (bytes)"]\
+ [list separator 1]\
+ [list Created [string range [fmtclock $tt(ctime)] 4 18]]\
+ [list Modified [string range [fmtclock $tt(mtime)] 4 18]]\
+ [list separator 1]\
+ ]
+ wokPROP:Nice $att $lm
+ }
+ }
+ }
+
+ PACKAGES {
+ set p [lindex $data 1]
+ set u [woklocate -u $p]
+ if { "$u" != "" } {
+ set t [uinfo -t $u]
+ set location [wokinfo -p library:lib${p}.so $u]
+ if [file exists $location] {
+ catch { unset tt }
+ file lstat $location tt
+ set lm [list \
+ [list $t $u] \
+ [list separator 1]\
+ [list File [file tail $location]] \
+ [list Location [file dirname $location]] \
+ [list separator 1] \
+ [list Size "$tt(size) (bytes)"]\
+ [list separator 1]\
+ [list Created [string range [fmtclock $tt(ctime)] 4 18]]\
+ [list Modified [string range [fmtclock $tt(mtime)] 4 18]]\
+ [list separator 1]\
+ ]
+ wokPROP:Nice $att $lm
+ }
+ }
+ }
+ }
+ return
+}
+;#
+;# ((((((( D E V U N I T )))))))
+;#
+proc wokPROP:devunit { adr nb page location} {
+ global IWOK_GLOBALS
+ set w [$nb subwidget $page]
+ frame $w.top -relief flat -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+ set lm {}
+
+ foreach tp [lsort [wokinfo -T $location]] {
+ set itm [wokinfo -p ${tp}:. $location]
+ if { [file exists $itm] } {
+ lappend lm [list $tp $itm]
+ }
+ }
+ set type [uinfo -t $location]
+ label $w.top.ima
+ set img [image create compound -window $w.top.ima]
+ $img add image -image $IWOK_GLOBALS(image,$type) ; $img add text -text " $type"
+ $w.top.ima config -image $img
+
+ tixScrolledText $w.top.msg -scrollbar y
+ set txt [$w.top.msg subwidget text]
+ $txt configure -relief flat -font $IWOK_GLOBALS(font)
+ wokPROP:Nice $txt $lm
+
+ tixForm $w.top.ima -top 12 -left 6
+ tixForm $w.top.msg -top [list $w.top.ima 20] -left 2 -right %99 -bottom %99
+ return
+}
+
+proc wokPROP:BLD { adr nb page location} {
+ global IWOK_GLOBALS
+ set w [$nb subwidget $page]
+ frame $w.top -relief flat -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+
+ text $w.top.txt -fg #000080 -font $IWOK_GLOBALS(boldfont) -relief flat
+ foreach string [umake -S $location] {
+ $w.top.txt insert end $string\n
+ }
+ tixForm $w.top.txt -top 0 -left %24 -right %99 -bottom %99
+ return
+}
+;#
+;# ((((((( T E R M I N A L )))))))
+;#
+proc wokPROP:terminal { adr nb page location} {
+ global IWOK_GLOBALS
+ set w [$nb subwidget $page]
+ frame $w.top -relief flat -bd 1
+ pack $w.top -side top -expand yes -fill both -padx 1 -pady 1
+
+ catch { unset tt }
+ file lstat $location tt
+
+ if [file writable $location] {
+ set wrt yes
+ set image [tix getimage textfile]
+ } else {
+ set wrt no
+ set image [tix getimage textfile_rdonly]
+ }
+ set exe no; if [file executable $location] { set exe yes }
+ set rea no; if [file readable $location] { set rea yes }
+ set lm [list \
+ [list separator 1] \
+ [list Location [file dirname $location]] \
+ [list Name [file tail $location]] \
+ [list separator 1] \
+ [list Size "$tt(size) (bytes)"]\
+ [list Type $tt(type)]\
+ [list separator 1]\
+ [list Created [string range [fmtclock $tt(ctime)] 4 18]]\
+ [list Modified [string range [fmtclock $tt(mtime)] 4 18]]\
+ [list Accessed [string range [fmtclock $tt(atime)] 4 18]]\
+ [list separator 1]\
+ [list Readable $rea]\
+ [list Writable $wrt]\
+ [list Executable $exe]\
+ ]
+
+ label $w.top.ima -image $image
+ set txt [text $w.top.msg]
+ $txt configure -relief flat -font $IWOK_GLOBALS(font)
+ wokPROP:Nice $txt $lm
+ tixForm $w.top.ima -top 12 -left 6
+ tixForm $w.top.msg -top [list $w.top.ima 20] -left 2
+ return
+}
+;#
+;# ((((((( N O T E B O O K A D M )))))))
+;#
+proc wokPROP:NOT { command adr w name args} {
+ tixBusy $w on
+ set id [after 10000 tixBusy $w off]
+ $command $adr $w $name $args
+ after cancel $id
+ after 0 tixBusy $w off
+ return
+}
+;#
+;#
+;#
+proc wokPROP:Kill { w } {
+
+ global IWOK_GLOBALS
+ wokButton delw [list properties $IWOK_GLOBALS($w,PROP,toplevel)]
+ catch {
+ destroy $IWOK_GLOBALS($w,PROP,toplevel)
+ destroy $IWOK_GLOBALS($w,PROP,help)
+ }
+ return
+}
+;#
+;#
+;#
+proc wokPROP:UPD { w } {
+ return
+}
+;#
+;# Retourne les Edl dans l'adm de location. Pas de test sur location
+;#
+proc wokPROP:GetAdmEdl { location } {
+ if ![catch { set pth [wokinfo -p AdmDir $location] }] {
+ return [lsort [glob -nocomplain $pth/*.edl]]
+ } else {
+ return {}
+ }
+}
+;#
+;#
+;#
+proc wokPROP:Nice { text lm {state disabled} } {
+ set nice [wokUtils:EASY:NiceList $lm :]
+ $text configure -state normal
+ $text delete 0.0 end
+ foreach string [split $nice \n] {
+ $text insert end $string\n
+ }
+ $text see 1.0
+ update
+ $text configure -state $state
+ return
+}
+
+
+
--- /dev/null
+
+ This window may be activated if the current workbench is the direct child of the reference
+ workbench.
+ It can be used to create an integration report which you can send into the integration queue.
+
+
+ Two lists are displayed:
+ the left list contains the UDs of your workbench, the right list contains the selected UDs.
+ The selection is performed vith the <Add all> and <Del all> buttons, as well as with <Mb1>.
+ In addition <MB3> can be used to select only one type of UD.
+
+
+ Buttons:
+
+ <Add all> : selects all the UDs in the left list.
+
+ <Del all> : deselects all the UDs from the right list.
+
+ <Compare> : compares all the selected UDs (wprepare). The result is sent to the list
+ displayed below the buttons. The files may be marked differently:
+ # the file is different, diff is displayed on the right of the list.
+ = the file is contained in your workbench but has not been modified.
+ - the file is no longer contained in the UD in your workbench.
+ + the file is displayed in the list cotaining the UD files of your workbench.
+
+
+ Use <Mb1> to select a file, and the arrows to move up and down the list. (see Exclude)
+
+ <Exclude> : removes the item from the report. If a UD is selected, the UD is removed.
+
+ This may also be done via <Control-x> or <Control-k>. This operation is faster since the diffs
+ are not displayed for each concerned element.
+
+ <Hide => : removes all the files marked "=" (those which have not been modified) from the
+ report.
+
+ <rm => : removes the unmodified files contained in your workbench. A dialog box is
+ displayed to confirm the deletion. This button may be used n your workbench.
+ A dialog box is displayed to confirm the deletion. This button may be used after
+ integration when the whole development has been transferred to the reference
+ workbench.
+
+ <Editor> : sends the file to an editor. The editor is either:
+ - emacs where you have created a *woksh* buffer,
+ - an editor defined by the environment variable EDITOR,
+ - the default editor provided with IWOK in all other cases.
+
+ <More Diff> : this button is activated if the "xdiff" command is contained in your path.
+ The comparison of the files is then performed with this program.
+
+ <Comments> : allows input of comments associated with the integration.
+
+ <Save> : writes the contents of the report onto the file ~/[user].[workbench].report, but
+ does not include it into the integration queue. This allows edition of the
+ report with an editor.
+
+ <Store> : performs the save operation and sends the result into the integration
+ queue (wstore).
+
+ The following buttons are only activated if the report being created contains one element or
+ more already in the integration queue. In this case, their names are displayed in orange in the
+ left list.
+
+ <Show warnings> : only displays elements of the report contained in the queue.
+
+ <Show all files> : redisplays the whole list.
+
+ To perform the diff between the file copy and the copy of the integration queue, select the file
+ in the left list and push <Queue diff>. To merge the files, retrieve the file in the integration
+ queue with the <Get from Queue> button.
+ The resulting file is named "<queue,file>" and is found in the src directory of the concerned UD.
+
+
+ Menu:
+
+ <File>
+
+ Ends the wprepare session.
+
+ <Admin> <Check>
+
+ Checks that the files in the selected UDs can be set in the repository.
+ This check-up may be performed before preparing a report which will be later used with the
+ wintegre -ref command.
--- /dev/null
+proc wokUpdateRepository { {loc {}} } {
+ global IWOK_GLOBALS
+ global IWOK_WINDOWS
+
+ if { $loc == {} } {
+ set verrue [wokCWD readnocell]
+ } else {
+ regexp {(.*):Repository} $loc all verrue
+ }
+
+ if ![wokinfo -x $verrue] {
+ wokDialBox .wokcd {Unknown location} "Location $verrue is unknown" {} -1 OK
+ return
+ }
+ set fact [wokinfo -f $verrue]
+ set shop [wokinfo -s $verrue]
+ set type [wokIntegre:BASE:InitFunc $shop]
+
+ set w [wokTPL rpr${verrue}]
+ if [winfo exists $w ] {
+ wm deiconify $w
+ raise $w
+ return
+ }
+
+ toplevel $w
+ wm title $w "Repository of $shop ."
+ wm geometry $w 1124x658+135+92
+ wokButton setw [list Rpr_close $w]
+ ;#bind $w <Destroy> { if [winfo exists %W] {wokRPRExit %W}}
+
+ tixBusy $w on
+ update
+
+ menubutton $w.file -menu $w.file.m -text File -underline 0 -takefocus 0
+ menu $w.file.m ; $w.file.m add command -label "Close " -underline 1 -command [list wokRPRExit $w]
+
+ menubutton $w.help -menu $w.help.m -text Help -underline 0 -takefocus 0
+ menu $w.help.m
+ $w.help.m add command -label "Help" -underline 1 -command [list wokRPRHelp $w]
+
+ menubutton $w.tools -menu $w.tools.m -text Tools -underline 0 -takefocus 0
+ menu $w.tools.m
+ $w.tools.m add command -label "Check out" -state disabled -command [list wokRPRCheckout $w]
+ $w.tools.m add command -label "To editor" -state disabled -command [list wokRPREditor $w]
+ $w.tools.m add command -label "More Diff" -state disabled -command [list wokRPRxdiff $w]
+ $w.tools.m add command -label "Search" -state disabled -command [list wokRPRSearch $w]
+
+ menubutton $w.marks -menu $w.marks.m -text Marks -underline 0 -takefocus 0
+ menu $w.marks.m
+ $w.marks.m add checkbutton -label "Display" -variable IWOK_WINDOWS($w,markdisplay)
+
+ menubutton $w.admin -menu $w.admin.m -text Admin -underline 0 -takefocus 0
+ menu $w.admin.m
+ $w.admin.m add command -label "Show params" -underline 0 -command [list wokRPRShowVersions $w]
+ $w.admin.m add command -label "Check contents" -underline 0 -command [list wokRPRCheckItem $w]
+ $w.admin.m add command -label "Delete element" -underline 0 -command [list wokRPRDeleteItem $w]
+
+ frame $w.top -relief sunken -bd 1
+ label $w.lab -relief raised
+
+ tixPanedWindow $w.top.pane -orient horizontal -paneborderwidth 0 -separatorbg gray50
+ pack $w.top.pane -side top -expand yes -fill both -padx 1 -pady 1
+
+ set p0 [$w.top.pane add tree -min 70 -size 240]
+ set p1 [$w.top.pane add scrw -min 60 -size 180]
+ set p2 [$w.top.pane add text -min 70]
+
+ set tree [tixTree $p0.tree -options {separator "^" hlist.selectMode single }]
+ $tree config \
+ -command "wokRPRBrowse $w $tree run" \
+ -browsecmd "wokRPRBrowse $w $tree browse" \
+ -opencmd "wokFillUnit $w $tree"
+
+ tixScrolledWindow $p1.scrw
+ set windo [$p1.scrw subwidget window]
+ canvas $windo.c
+ set canva $windo.c
+
+ tixScrolledText $p2.text
+ set texte [$p2.text subwidget text]
+ $texte config -font $IWOK_GLOBALS(font)
+
+ pack $p0.tree -expand yes -fill both -padx 1 -pady 1
+ pack $p1.scrw -expand yes -fill both -padx 1 -pady 1
+ pack $p2.text -expand yes -fill both -padx 1 -pady 1
+
+ tixForm $w.file ; tixForm $w.help -right -2
+ tixForm $w.tools -left $w.file
+ tixForm $w.marks -left $w.tools
+ tixForm $w.admin -left $w.marks
+ tixForm $w.top -top $w.file -left 1 -right %99 -bottom $w.lab
+ tixForm $w.lab -left 1 -right %99 -bottom %99
+
+ set IWOK_WINDOWS($w,menu) $w.file.m
+ set IWOK_WINDOWS($w,tools) $w.tools.m
+ set IWOK_WINDOWS($w,admin) $w.admin.m
+ set IWOK_WINDOWS($w,label) $w.lab
+ set IWOK_WINDOWS($w,tree) $tree
+ set IWOK_WINDOWS($w,hlist) [set hlist [$tree subwidget hlist]]
+ set IWOK_WINDOWS($w,text) $texte
+ set IWOK_WINDOWS($w,canvas) $canva
+ set IWOK_WINDOWS($w,fact) $fact
+ set IWOK_WINDOWS($w,shop) $shop
+ set IWOK_WINDOWS($w,journal) [wokIntegre:Journal:GetName $IWOK_WINDOWS($w,shop)]
+ set IWOK_WINDOWS($w,qroot) [wokIntegre:BASE:GetRootName $IWOK_WINDOWS($w,shop)]
+ set IWOK_WINDOWS($w,data) {}
+
+
+ catch {
+ wokIntegre:Mark:NiceDump $IWOK_WINDOWS($w,journal) tt
+ wokUtils:EASY:MAD IWOK_WINDOWS $w,mark tt
+ set IWOK_WINDOWS($w,lmark) [array exists tt]
+ }
+
+ set IWOK_WINDOWS($w,markdisplay) 0
+
+ set IWOK_GLOBALS(repository,popup) [tixPopupMenu $w.p -title "Select" ]
+ $w.p subwidget menubutton configure -font $IWOK_GLOBALS(font)
+ set IWOK_GLOBALS(repository,popup,menu) [$IWOK_GLOBALS(repository,popup) subwidget menu]
+ $IWOK_GLOBALS(repository,popup,menu) configure -font $IWOK_GLOBALS(font)
+
+ set LB [wokIntegre:BASE:LS $IWOK_WINDOWS($w,shop)]
+ set V [wokIntegre:Version:Get $IWOK_WINDOWS($w,shop)]
+ set R $IWOK_WINDOWS($w,qroot)
+
+ foreach d $LB {
+ set B [lindex $d 0]
+ set T [lindex $d 1]
+ $hlist add ${B}${T} -itemtype imagetext -text $B \
+ -image $IWOK_GLOBALS(image,[string index $T 1]) \
+ -data [list $R $B $T $V]
+ $tree setmode ${B}${T} open
+ }
+
+
+ set lewb {}
+ set llitm [linsert $IWOK_GLOBALS(ucreate-P) 0 [list All All..]]
+ if { "[wokinfo -t $verrue]" == "workbench" } {
+ set llitm [linsert $llitm 0 [list You Yours..]]
+ set lewb [w_info -l $verrue]
+ }
+
+ foreach t $llitm {
+ $IWOK_GLOBALS(repository,popup,menu) add command -label [lindex $t 1]\
+ -command [list wokRprFilterdevunit $tree $hlist [lindex $t 0] $LB $V $R $lewb]
+ }
+ $IWOK_GLOBALS(repository,popup) bind $hlist
+ tixBusy $w off
+ return
+}
+#
+# met list dans hlist en filtrant avec t, V version et R root
+#
+proc wokRprFilterdevunit { tree hlist t list V R lewb} {
+ global IWOK_GLOBALS
+ $hlist delete all
+ if { "$t" != "You" } {
+ foreach d $list {
+ set B [lindex $d 0]
+ set T [lindex $d 1]
+ if { "$t" != "All" } {
+ set ext [lindex $d 1]
+ if { "$ext" == ".$t" } {
+ $hlist add ${B}${T} -itemtype imagetext -text $B \
+ -image $IWOK_GLOBALS(image,[string index $T 1]) -data [list $R $B $T $V]
+ $tree setmode ${B}${T} open
+ }
+ } else {
+ $hlist add ${B}${T} -itemtype imagetext -text $B \
+ -image $IWOK_GLOBALS(image,[string index $T 1]) -data [list $R $B $T $V]
+ $tree setmode ${B}${T} open
+ }
+ }
+ } else {
+ foreach d $list {
+ set B [lindex $d 0]
+ if { [lsearch $lewb $B] != -1 } {
+ set T [lindex $d 1]
+ $hlist add ${B}${T} -itemtype imagetext -text $B \
+ -image $IWOK_GLOBALS(image,[string index $T 1]) -data [list $R $B $T $V]
+ $tree setmode ${B}${T} open
+ }
+ }
+ }
+ return
+}
+#
+# appelee a l'ouverture d'un item: Le remplit s'il est vide et montre les fils
+#
+proc wokFillUnit { w tree ent } {
+ global IWOK_GLOBALS
+ global IWOK_WINDOWS
+ set hlist [$tree subwidget hlist]
+ if {[$hlist info children $ent] == {}} {
+ set data [$hlist info data $ent] ;# R B T V
+ set R $IWOK_WINDOWS($w,qroot)
+ ;#set R [lindex $data 0]
+ set B [lindex $data 1]
+ set T [lindex $data 2]
+ set V [lindex $data 3]
+ set dir $R/${B}${T}
+ set LSF [wokIntegre:BASE:List $IWOK_WINDOWS($w,shop) $B $V]
+ set txtima [tix getimage textfile]
+ foreach s $LSF {
+ set sfile $dir/[wokIntegre:BASE:ftos $s $V]
+ $hlist add ${B}${T}^${s} -itemtype imagetext -text $s -image $txtima -data $sfile
+ }
+ }
+ foreach kid [$hlist info children $ent] {
+ $hlist show entry $kid
+ }
+ return
+}
+
+#
+# appelee quand on brouze la liste.
+#
+proc wokRPRBrowse { w slb action args } {
+ global IWOK_WINDOWS
+
+ set hlist [$slb subwidget hlist]
+ set ent [$hlist info anchor]
+
+ if {$ent == ""} {
+ return
+ }
+
+ set kid [$hlist info children $ent]
+ if {$kid != {} } {
+ ;#puts "HEADER"
+ ;# un Unit header pour l'instant rien a faire
+ return
+ } else {
+ ;# un fils donc un sfile peut aussi etre /home/wb/kl/KERNEL/SCCS/SCCS/s.BASES DBT .p {}
+ set sfile [$hlist info data $ent]
+ if { $sfile == "" || [llength $sfile] != 1 } {
+ return
+ }
+ }
+
+ case $action {
+ "run" {
+ ;#double clique
+ }
+
+ "browse" {
+ wokSetCanv $w
+ }
+ }
+ return
+}
+
+proc wokRPRShowVersions { w } {
+ global IWOK_WINDOWS
+
+ $IWOK_WINDOWS($w,text) delete 1.0 end
+
+ set msg "Versions and workshops:" ; $IWOK_WINDOWS($w,text) insert end $msg\n
+ set msg "_______________________" ; $IWOK_WINDOWS($w,text) insert end $msg\n
+ $IWOK_WINDOWS($w,text) insert end \n
+ foreach e [wokIntegre:Version:Dump $IWOK_WINDOWS($w,shop)] {
+ set msg " [lindex $e 1] : [lindex $e 0]"
+ $IWOK_WINDOWS($w,text) insert end $msg\n
+ }
+ $IWOK_WINDOWS($w,text) insert end \n
+ set msg "Repository location:"; $IWOK_WINDOWS($w,text) insert end $msg\n
+ set msg "____________________" ; $IWOK_WINDOWS($w,text) insert end $msg\n
+ $IWOK_WINDOWS($w,text) insert end \n
+ set msg " [wokIntegre:BASE:GetRootName $IWOK_WINDOWS($w,shop)]" ;
+ $IWOK_WINDOWS($w,text) insert end $msg\n
+ $IWOK_WINDOWS($w,text) insert end \n
+ set msg "Administration directory:"; $IWOK_WINDOWS($w,text) insert end $msg\n
+ set msg "_________________________" ; $IWOK_WINDOWS($w,text) insert end $msg\n
+ $IWOK_WINDOWS($w,text) insert end \n
+ set msg " [file dirname [wokIntegre:Version:GetTableName $IWOK_WINDOWS($w,shop)]]" ;
+ $IWOK_WINDOWS($w,text) insert end $msg\n
+ $IWOK_WINDOWS($w,text) insert end \n
+ set msg "EDL file used for parameters:"; $IWOK_WINDOWS($w,text) insert end $msg\n
+ set msg "_____________________________" ; $IWOK_WINDOWS($w,text) insert end $msg\n
+ $IWOK_WINDOWS($w,text) insert end \n
+ set msg " [lindex [wokparam -F VC $IWOK_WINDOWS($w,shop)] 0]" ;
+ $IWOK_WINDOWS($w,text) insert end $msg\n
+ return
+}
+
+;#
+;# Affiche un historique en X Y
+;#
+proc wokUpdateHist1 { w infile XIN YIN } {
+ global IWOK_WINDOWS
+ set Canv $IWOK_WINDOWS($w,canvas)
+
+ catch { unset FILS }
+ set root [wokIntegre:BASE:tree $infile FILS]
+ $Canv delete all
+
+ set X $XIN
+ set Y $YIN
+ set mx 0
+ set my 0
+ set t 28
+
+ set lastitl {}
+ set IWOK_WINDOWS($w,vlabels) {}
+ lappend IWOK_WINDOWS($w,vlabels) [list 1 [expr $XIN +20 ] [expr $YIN + 10 ]]
+ while 1 {
+ set dat [lindex $root 0]
+ set lab [lindex $dat 0]
+ set nxt [lindex $root 1]
+ set cmt [lindex $dat 1]
+
+ wokArtVrs
+ set lastitl $curitl
+ if ![info exists FILS($nxt)] { break }
+ set root [lindex $FILS($nxt) 0]
+
+ }
+ lappend IWOK_WINDOWS($w,vlabels) [list 9999 9999 9999]
+ set IWOK_WINDOWS($w,vlablen) [expr [llength $IWOK_WINDOWS($w,vlabels)] - 1 ]
+
+ if {$IWOK_WINDOWS($w,markdisplay) == 1} {
+ if { [wokCheckLabels $IWOK_WINDOWS($w,vlabels)] == 0 } {
+ wokDialBox .badnews {Bad news} \
+ "Incoherent archive file format. Unable to place marks for this file" {} -1 OK
+ } else {
+ if { $IWOK_WINDOWS($w,lmark) == 1 } {
+ foreach xn [array names IWOK_WINDOWS $w,mark,*] {
+ set xrk [split $IWOK_WINDOWS($xn) ,]
+ set maxt [wokArtMark $w [lindex [split $xn ,] 2] [lindex $xrk 0] [lindex $xrk 1] ]
+ if { $maxt > $mx } {
+ set mx $maxt
+ }
+ }
+ }
+ }
+ }
+ $Canv configure -width $mx -height $my
+ pack $Canv
+ update
+ return
+}
+;#
+;# verifie que list est croissante/ 1 er element. list { {a b c} {a b c }.. } Contient au moins 2 elements.
+;#
+proc wokCheckLabels { list } {
+ set ll [llength $list]
+ for {set i 0} {$i < $ll } {incr i 1} {
+ set n1 [lindex $list $i]
+ set n2 [lindex $list [expr $i + 1 ]]
+ if { $n1 != {} && $n2 != {} } {
+ if { [lindex $n1 0] > [lindex $n2 0] } {
+ return 0
+ }
+ }
+ }
+ return 1
+}
+;#
+;# dessine mrk. remonte mx my pour config du canvas
+;#
+proc wokArtMark { w txt mrk dat} {
+ global IWOK_WINDOWS
+ set c $IWOK_WINDOWS($w,canvas)
+ for {set i 0} {$i < $IWOK_WINDOWS($w,vlablen)} {incr i 1} {
+ ;#puts "i = $i ip1 = [expr $i+1]"
+ set binf [lindex $IWOK_WINDOWS($w,vlabels) $i]
+ set bsup [lindex [lindex $IWOK_WINDOWS($w,vlabels) [expr $i+1]] 0]
+ ;#puts "binf = $binf bsup = $bsup"
+ if { [lindex $binf 0] <= $mrk && $mrk < $bsup } {
+ set b1 [lindex $binf 1]
+ set b2 [lindex $binf 2]
+ set ttx [$c create text $b1 $b2 -text $txt -anchor w -tag [list MRK $txt $mrk $dat]]
+ set bbl [$IWOK_WINDOWS($w,canvas) bbox $ttx]
+ set x2 [lindex $bbl 2]
+ $c create rectangle [lindex $bbl 0] [lindex $bbl 1] $x2 [lindex $bbl 3] -fill yellow
+ $c raise $ttx
+ set hhx [expr $x2 + 10]
+ set IWOK_WINDOWS($w,vlabels) \
+ [lreplace $IWOK_WINDOWS($w,vlabels) $i $i [list [lindex $binf 0] $hhx [lindex $binf 2]]]
+ return $hhx
+ }
+ }
+}
+;#
+;# evaluee dans wokUpdateHist1
+;#
+proc wokArtVrs { } {
+ uplevel {
+ regexp {([0-9]*)\..*} $lab all bn
+ set col black
+ set itx [$Canv create text $X $Y -text $lab -fill $col -tag [list LAB $lab] -anchor n]
+ $Canv bind $itx <Any-Enter> {catch {%W configure -cursor {hand2 red white}}}
+ set lxy [$Canv bbox $itx]
+ set x1 [lindex $lxy 0]; set y1 [lindex $lxy 1] ; set x2 [lindex $lxy 2]; set y2 [lindex $lxy 3]
+ set itr [$Canv create rectangle $x1 $y1 $x2 $y2 -fill grey -tag [list RECT R${lab}]]
+ $Canv raise $itx
+ set midx [expr $x1 + ($x2-$x1)/2]
+ set curitl [$Canv create line $midx $y2 $midx [expr $y2 +$t] -arrow last]
+ if { $lastitl != {} } {
+ $Canv itemconfigure $lastitl -tag [list CMT $cmt]
+ set nbr [lindex [wokIntegre:Journal:UnMark $cmt] 1]
+ set nbr [lindex [split $nbr _] 0] ;# pour les vieux comments de DPE
+ lappend IWOK_WINDOWS($w,vlabels) [list $nbr [expr $midx + 20 ] [expr $y1 + ($y2-$y1)/2]]
+ }
+ set lastitl $curitl
+ set Y [expr $y2 + $t]
+ set mx $x2
+ set my $y2
+ }
+}
+;#
+;# Configure le label, canvas et le texte pour l'item selectionne
+;#
+proc wokSetCanv { w } {
+ global IWOK_WINDOWS
+ global IWOK_GLOBALS
+
+ set sfile [wokRPRGetSfile $w] ;# variable dans les bind
+ if { $sfile == {} } {
+ return
+ }
+
+ set canv $IWOK_WINDOWS($w,canvas) ;#
+ set text $IWOK_WINDOWS($w,text) ;# constant par rapport a w
+ set lab $IWOK_WINDOWS($w,label) ;#
+
+ $IWOK_WINDOWS($w,tools) entryconfigure 1 -state active
+ $IWOK_WINDOWS($w,tools) entryconfigure 2 -state active
+ $IWOK_WINDOWS($w,tools) entryconfigure 4 -state active
+
+ $canv delete all
+ catch {unset v1 v2}
+ wokUpdateHist1 $w $sfile 14 20
+ $text delete 0.0 end
+ wokReadString $text [wokIntegre:BASE:cat $sfile last]
+ set vrs [wokIntegre:BASE:vrs $sfile]
+ set dta [fmtclock [file mtime $sfile] "%d %h %y %R" ]
+ set item [wokIntegre:BASE:stof [file tail $sfile] {}]
+ set fmt [format "FILE: %--30s Version: %--10s Last registered: %--15s" $item $vrs $dta]
+ $lab configure -text $fmt -font $IWOK_GLOBALS(font)
+ set IWOK_WINDOWS($w,data) $vrs
+ bind $canv <Button-1> {
+ set w [winfo toplevel %W]
+ set info [%W gettags current]
+ set nat [lindex $info 0]
+ if {[string compare $nat LAB] == 0} {
+ set vrs [lindex $info 1]
+ foreach e [%W find all] {
+ set lt [%W gettags $e]
+ if {[lsearch $lt RECT] != -1} {
+ %W itemconfigure $e -outline black -width 1
+ if {[lsearch $lt R${vrs}]!= -1} {
+ %W itemconfigure $e -outline red -width 2
+ }
+ }
+ }
+ set ts [wokRPRGetSfile $w]
+ $IWOK_WINDOWS($w,label) configure -text "File [wokIntegre:BASE:stof $ts {} ] ($vrs)"
+ wokReadString $IWOK_WINDOWS($w,text) [wokIntegre:BASE:cat $ts $vrs]
+ set IWOK_WINDOWS($w,data) $vrs
+ }
+
+ if {[string compare $nat CMT] == 0} {
+ tixBusy $w on
+ update
+ set _x [wokIntegre:Journal:UnMark [lindex $info 1]]
+ set _j [wokIntegre:Journal:GetSlice [set _n [lindex $_x 1]] $IWOK_WINDOWS($w,shop) ]
+
+ wokReadList $IWOK_WINDOWS($w,text) \
+ [wokIntegre:Journal:PickMultReport $_j ${_n} ${_n}]
+ wokFAM $IWOK_WINDOWS($w,text) {^-- } { $IWOK_WINDOWS($w,text) tag add big first last }
+ $IWOK_WINDOWS($w,text) tag configure big -background orange -foreground black -borderwidth 2 \
+ -font -Adobe-Helvetica-Medium-R-Normal--*-120-* -relief raised
+ $IWOK_WINDOWS($w,text) see end
+ $IWOK_WINDOWS($w,label) configure -text [$IWOK_WINDOWS($w,text) get 1.0 1.end]
+ catch { unset _x _n _j}
+ tixBusy $w off
+ }
+
+ if {[string compare $nat MRK] == 0} {
+ wokReadList $IWOK_WINDOWS($w,text) \
+ [wokIntegre:Mark:GetComment $IWOK_WINDOWS($w,journal) [lindex $info 1]]
+ $IWOK_WINDOWS($w,label) configure \
+ -text "Mark to integration [lindex $info 2]. Placed on [fmtclock [lindex $info 3]]"
+ }
+
+ }
+
+ bind $canv <Control-Button-1> {
+ set w [winfo toplevel %W]
+ set info [%W gettags current]
+ if ![info exists v1] {
+ set v1 [lindex $info 1]
+ foreach e [%W find all] {
+ set lt [%W gettags $e]
+ if {[lsearch $lt RECT] != -1} {
+ %W itemconfigure $e -outline black -width 1
+ if {[lsearch $lt R${v1}]!= -1} {
+ %W itemconfigure $e -outline red -width 2
+ }
+ }
+ }
+
+ } else {
+ if ![info exists v2] {
+ set v2 [lindex $info 1]
+ foreach e [%W find all] {
+ if {[lsearch [%W gettags $e] R${v2}]!= -1} {
+ %W itemconfigure $e -outline red -width 2
+ }
+ }
+ set ts [wokRPRGetSfile $w]
+ wokReadString $IWOK_WINDOWS($w,text) [wokIntegre:BASE:diff $ts $v1 $v2]
+ $IWOK_WINDOWS($w,label) configure -text "Differences ($v1) <=> ($v2)"
+ if [wokUtils:EASY:INPATH xdiff] {
+ $IWOK_WINDOWS($w,tools) entryconfigure 3 -state active
+ set IWOK_WINDOWS($w,data) [list $ts $v1 $v2]
+ }
+ }
+ unset v1 v2
+ }
+ }
+ return
+}
+;#
+;# Widget
+;#
+
+;#
+;# recupere le sfile en cours
+;#
+proc wokRPRGetSfile { w } {
+ global IWOK_WINDOWS
+ set hlist $IWOK_WINDOWS($w,hlist)
+ catch { set anchor [$hlist info anchor] }
+ if { $anchor != {} } {
+ set sfile [$hlist info data $anchor]
+ if [file exists $sfile] {
+ return $sfile
+ }
+ }
+ return {}
+}
+;#
+;# Sort un fichier de la base dans le repertoire courant
+;#
+proc wokRPRCheckout { w } {
+ global IWOK_WINDOWS
+ set sfile [wokRPRGetSfile $w]
+ set vrs $IWOK_WINDOWS($w,data)
+ if ![ file exists $sfile ] {
+ return
+ }
+ set wf [pwd]/$vrs,[wokIntegre:BASE:stof [file tail $sfile] {}]
+ if ![catch { wokUtils:FILES:ListToFile [split [wokIntegre:BASE:cat $sfile $vrs] \n] $wf } status] {
+ $IWOK_WINDOWS($w,label) configure -text "File $wf has been created"
+ } else {
+ wokDialBox .nowrite {Cannot write file} $status {} -1 OK
+ }
+ return
+}
+;#
+;#
+;#
+proc wokRPRSearch { w } {
+ global IWOK_WINDOWS
+ wokSEA $IWOK_WINDOWS($w,text)
+ return
+}
+;#
+;#
+;#
+proc wokRPREditor { w } {
+ global IWOK_WINDOWS
+ set sfile [wokRPRGetSfile $w]
+ if [file exists $sfile] {
+ set f [wokIntegre:BASE:stof [file tail $sfile] {}]
+ set vrs $IWOK_WINDOWS($w,data)
+ set file "/tmp/$vrs,${f}"
+ wokUtils:FILES:ListToFile [split [wokIntegre:BASE:cat $sfile $vrs] \n] $file
+ wokEDF:EditFile $file
+ }
+ return
+}
+
+proc wokRPRxdiff { w } {
+ global IWOK_WINDOWS
+ set ts [lindex $IWOK_WINDOWS($w,data) 0]
+ set f [wokIntegre:BASE:stof [file tail [lindex $IWOK_WINDOWS($w,data) 0]] {}]
+ set v1 [lindex $IWOK_WINDOWS($w,data) 1]
+ set v2 [lindex $IWOK_WINDOWS($w,data) 2]
+ set f1 "/tmp/$v1,$f"
+ set f2 "/tmp/$v2,$f"
+ wokUtils:FILES:ListToFile [split [wokIntegre:BASE:cat $ts $v1] \n] $f1
+ wokUtils:FILES:ListToFile [split [wokIntegre:BASE:cat $ts $v2] \n] $f2
+ catch {exec xdiff $f1 $f2 &}
+ return
+}
+
+
+
+proc wokRPRDeleteItem { w } {
+ global IWOK_WINDOWS
+ set hlist $IWOK_WINDOWS($w,hlist)
+
+ set len [llength [set lstent [split [set entry [$hlist info anchor]] ^]]]
+
+ if { $len == 0 } {
+ return
+ } elseif { $len == 1 } {
+ set unit [lindex $lstent 0]
+ tixBusy $w on
+ wokIntegre:BASE:Delete $IWOK_WINDOWS($w,shop) $unit
+ tixBusy $w off
+ } elseif { $len > 1 } {
+ set unit [lindex $lstent 0]
+ set item [lindex $lstent 1]
+ set data [$hlist info data [$hlist info parent $entry]]
+ set vrs [lindex $data 2]
+ catch { unlink $IWOK_WINDOWS($w,qroot)/$unit/[wokIntegre:BASE:ftos $item $vrs] }
+ }
+ $hlist delete entry $entry
+ $IWOK_WINDOWS($w,canvas) delete all
+ $IWOK_WINDOWS($w,text) delete 1.0 end
+ return
+}
+proc wokRPRCheckItem { w } {
+ global IWOK_WINDOWS
+ set hlist $IWOK_WINDOWS($w,hlist)
+
+ set len [llength [set lstent [split [set entry [$hlist info anchor]] ^]]]
+
+ if { $len == 0 } {
+ return
+ } elseif { $len == 1 } {
+ set unit [lindex $lstent 0]
+ tixBusy $w on
+ update
+ $IWOK_WINDOWS($w,text) delete 0.0 end
+ set dir $IWOK_WINDOWS($w,qroot)/$unit
+ set lst {}
+ catch { set lst [readdir $dir] }
+ foreach sfile [lsort $lst] {
+ if [wokIntegre:BASE:IsElm $sfile] {
+ set stat [wokIntegre:BASE:check $dir/$sfile]
+ if { $stat != {} } {
+ $IWOK_WINDOWS($w,text) insert end "$stat \n"
+ } else {
+ $IWOK_WINDOWS($w,text) insert end "File OK: $dir/$sfile \n"
+ }
+ }
+ $IWOK_WINDOWS($w,text) see end
+ update
+ }
+ tixBusy $w off
+ } elseif { $len > 1 } {
+ set unit [lindex $lstent 0]
+ set item [lindex $lstent 1]
+ set data [$hlist info data [$hlist info parent $entry]]
+ set vrs [lindex $data 2]
+ $IWOK_WINDOWS($w,canvas) delete all
+ set sfile $IWOK_WINDOWS($w,qroot)/$unit/[wokIntegre:BASE:ftos $item $vrs]
+ set stat [wokIntegre:BASE:check $sfile]
+ if { $stat != {} } {
+ wokReadString $IWOK_WINDOWS($w,text) "$stat"
+ } else {
+ wokReadString $IWOK_WINDOWS($w,text) "File OK: $sfile"
+ }
+ }
+ return
+}
+
+proc wokRPRExit { w } {
+ global IWOK_WINDOWS
+ destroy $w
+ foreach f [glob -nocomplain /tmp/jnltmp[id process].*] {
+ catch { unlink $f }
+ }
+ if [info exists IWOK_WINDOWS($w,help)] {
+ catch {destroy $IWOK_WINDOWS($w,help)}
+ }
+ wokButton delw [list Rpr_close $w]
+ return
+}
+
+
+proc wokPrepareCheckWithRPR { w } {
+ global IWOK_WINDOWS
+ $IWOK_WINDOWS($w,hlist) delete all
+ $IWOK_WINDOWS($w,text) delete 1.0 end
+ msgsetcmd wokMessageInText $IWOK_WINDOWS($w,text)
+ tixBusy $w on
+ update
+ foreach item [$IWOK_WINDOWS($w,hlist2) info children] {
+ set ud $IWOK_WINDOWS($w,shop):$IWOK_WINDOWS($w,WBFils):[lindex $item 1]
+ set root [wokIntegre:BASE:GetRootName]/[lindex $item 1].[uinfo -c ${ud}]
+ wcheck -diff [uinfo -plTsource $ud] -dir $root
+ }
+ tixBusy $w off
+ msgunsetcmd
+ return
+}
+
+
+
+;#
+;# Help du repository
+;#
+proc wokRPRHelp { w } {
+ global IWOK_GLOBALS
+ global IWOK_WINDOWS
+ global env
+
+ set IWOK_WINDOWS($w,help) [set wh .wokRPRHelp]
+ if {[info exist IWOK_GLOBALS(windows)]} {
+ if {[lsearch $IWOK_GLOBALS(windows) $wh ] == -1} {
+ lappend IWOK_GLOBALS(windows) $wh
+ }
+ }
+
+ set whelp [wokHelp $wh "About sources repository"]
+ set texte [lindex $whelp 0] ; set label [lindex $whelp 1]
+ wokReadFile $texte $env(WOK_LIBRARY)/wokRPRHelp.hlp
+ wokFAM $texte <.*> { $texte tag add big first last }
+ $texte tag configure big -background Bisque3 -foreground black -borderwidth 2 \
+ -font -Adobe-Helvetica-Medium-R-Normal--*-120-* -relief raised
+ update
+ $texte configure -state disabled
+ return
+}
--- /dev/null
+
+ Consulting the source repository:
+
+ For each selected item in the left list, all the recorded versions are displayed.
+
+ Select a given version with <MB1> to display the associated contents and activate the
+ following options in the Tools menu:
+
+ <Check out> generates a copy of the selected version in the current directory.
+ This version is named x.y,file.ext where x.y is the selected version and file.ext the name of
+ the source.
+
+ <To editor> sends this copy to an editor.
+
+ Select the arrow between two consecutive versions with <MB1> to display the integration report
+ containing information on the version upgrade.
+
+ Select 2 different versions with <Control_Mb1> to display the differences between both versions.
+
+ If the xdiff programm is contained in your path, the Tools menu activates the following option:
+
+ <More Diff> displays the differences.
+
+
+ The Admin menu displays the following submenus:
+
+ <Show params>
+
+ Displays the location where to find the bases as well as the VC.edl file used for
+ parameterization.
+
+ <Check contents>
+
+ Checks the contents of the item selected in the left list. In the case of a UD, all the files in
+ the UD are checked.
+
+ <Delete File>
+
+ Deletes the item selected in the left list. In the case of a file, the file is deleted; in the
+ case of a UD, the UD is removed from the repository.
+
+
--- /dev/null
+;#
+;# Cree une boite de recherche pour le text text.
+;#
+proc wokSEA { text } {
+ global IWOK_WINDOWS
+ set wt $text.wokstringsearch ;# automatikli destroyed with parent !!
+ catch { destroy $wt }
+ toplevel $wt ; wm title $wt "Search" ; wm iconname $wt "Search"
+
+ set wask [frame $wt.ask]
+ label $wask.noma ; label $wask.lab -text "Search : "
+ entry $wask.ent -textvar IWOK_WINDOWS($wt,string) -relief sunken
+ tixForm $wask.noma -top 4 -left 4
+ tixForm $wask.lab -top [list $wask.noma 2] -left 4
+ tixForm $wask.ent -left $wask.lab -top $wask.noma
+
+ set wsens [frame $wt.sens]
+ radiobutton $wsens.fwd -text "Forward" -var IWOK_WINDOWS($wt,sens) \
+ -relief flat -val 1 -command [list wokSEA:InitCur $wt]
+ radiobutton $wsens.bwd -text "Backward" -var IWOK_WINDOWS($wt,sens) \
+ -relief flat -val 0 -command [list wokSEA:InitCur $wt]
+ checkbutton $wsens.reg -text "Regexp" -var IWOK_WINDOWS($wt,regexp) -relief flat
+ checkbutton $wsens.cas -text "Case " -var IWOK_WINDOWS($wt,case) -relief flat
+
+ tixForm $wsens.cas -top 0 -left 0
+ tixForm $wsens.bwd -left $wsens.cas
+
+ tixForm $wsens.reg -top $wsens.cas -left 0
+ tixForm $wsens.fwd -left $wsens.reg -top $wsens.bwd
+
+ set wbut [frame $wt.but]
+ button $wbut.next -text Next -width 6 -command [list wokSEA:GO $wt]
+ button $wbut.canc -text Cancel -width 6 -command [list wokSEA:Exit $wt $text]
+ pack $wbut.next $wbut.canc -side top -pady 0 -anchor w
+
+ tixForm $wask -top 0 -left 0 -right %80
+ tixForm $wsens -top $wask -left 0 -right %80
+ tixForm $wbut -left $wask -top 4 -right %99
+
+ set IWOK_WINDOWS($wt,noma) $wask.noma
+ set IWOK_WINDOWS($wt,text) $text
+ set IWOK_WINDOWS($wt,sens) 1
+ wokSEA:InitCur $wt
+
+ bind $wask.ent <Return> { wokSEA:GO [winfo toplevel %W] }
+ bind $wask.ent <KeyPress> { wokSEA:CLR [winfo toplevel %W] }
+
+ return
+}
+proc wokSEA:CLR { wt } {
+ global IWOK_WINDOWS
+ $IWOK_WINDOWS($wt,noma) configure -text ""
+}
+
+proc wokSEA:Exit { w text } {
+ global IWOK_WINDOWS
+ $text tag remove search 0.0 end
+ foreach v [array names IWOK_WINDOWS $w,*] {
+ unset IWOK_WINDOWS($v)
+ }
+ if { [winfo exists $w] } {
+ destroy $w
+ }
+ return
+}
+
+proc wokSEA:InitCur { wt } {
+ global IWOK_WINDOWS
+ if { [ info exists IWOK_WINDOWS($wt,lastmatch)] } {
+ set IWOK_WINDOWS($wt,cur) $IWOK_WINDOWS($wt,lastmatch)
+ } else {
+ if { $IWOK_WINDOWS($wt,sens) == 1 } {
+ set IWOK_WINDOWS($wt,cur) 1.0
+ } else {
+ set IWOK_WINDOWS($wt,cur) end
+ }
+ }
+ return
+}
+
+proc wokSEA:GO { wt } {
+ global IWOK_WINDOWS
+ set string $IWOK_WINDOWS($wt,string)
+ if { $string == "" } { return }
+ set text $IWOK_WINDOWS($wt,text)
+ set mode -exact
+ if { $IWOK_WINDOWS($wt,regexp) == 1 } { set mode -regexp }
+ set case -nocase
+ if { $IWOK_WINDOWS($wt,case) == 1 } { set case "" }
+ set sens -backward
+ if { $IWOK_WINDOWS($wt,sens) == 1 } { set sens -forward }
+ set ncur [eval $text search $mode $case $sens -count len -- $string $IWOK_WINDOWS($wt,cur)]
+ if {$ncur != "" } {
+ $IWOK_WINDOWS($wt,noma) configure -text ""
+ $text tag remove search 0.0 end
+ $text tag add search $ncur "$ncur + $len char"
+ $text see $ncur
+ $text tag configure search -relief raised -background white -foreground black -borderwidth 2
+ if { $IWOK_WINDOWS($wt,sens) == 1 } {
+ set IWOK_WINDOWS($wt,cur) [$text index "$ncur + $len char"]
+ } else {
+ set IWOK_WINDOWS($wt,cur) [$text index "$ncur - $len char"]
+ }
+ set IWOK_WINDOWS($wt,lastmatch) $ncur
+ } else {
+ $IWOK_WINDOWS($wt,noma) configure -text "nomatch"
+ wokSEA:InitCur $wt
+ }
+ return
+}
+;#------------------------------------------
+proc wokSEA:testme { w } {
+ toplevel $w
+ frame $w.buttons
+ pack $w.buttons -side bottom -fill x -pady 2m
+ button $w.buttons.dismiss -text Dismiss -command "destroy $w"
+ button $w.buttons.code -text "Search"
+ pack $w.buttons.dismiss $w.buttons.code -side left -expand 1
+ text $w.text -relief sunken -bd 2 -yscrollcommand "$w.scroll set" -setgrid 1 \
+ -height 10
+ scrollbar $w.scroll -command "$w.text yview"
+ pack $w.scroll -side right -fill y
+ pack $w.text -expand yes -fill both
+ $w.text insert 0.0 \
+ {This window is a text widget. It displays one or more lines of text
+ and allows you to edit the text. Here is a summary of the things you
+ can do to a text widget:
+
+ Resize the window. This widget has been configured with the "setGrid"
+ option on, so that if you resize the window it will always resize to an
+ even number of characters high and wide. Also, if you make the window
+ narrow you can see that long lines automatically wrap around onto
+ additional lines so that all the information is always visible.}
+ $w.text mark set insert 0.0
+ $w.buttons.code configure -command [list wokSEA $w.text]
+ return
+}
--- /dev/null
+ Managing the integration queue:
+
+ Click on a specific report with <Mb1> to select it.
+
+ When the queue contains duplicated elements, these elements are displayed in orange.
+ Click on two elements with <MB1> to get the difference.
+
+ <Integrate>
+
+ Integrates (wintegre) the selected report into the list of reports.
+ This button is only active if the current user is allowed to write into the repository and
+ if the report has been selected.
+
+ <Remove>
+
+ Removes the report (wstore -rm) from the selected list.
+
+ <Update>
+
+ Refreshes the window containing the list of reports.
+
+
+
+ Consulting the integration journal:
+
+ <Display>
+
+ Displays the whole contents of the integration journal.
+
+ <ToDay's>
+
+ Displays the list of integrations performed in the current day.
+
+ <Prev>
+
+ Goes to the previous day in the integration journal.
+
+ <Next>
+
+ Goes to he next day in the integration journal.
+
+ <To Editor>
+
+ Sends the integration journal to an editor.
+
+ <Purge>
+
+ Saves the contents of the integration journal and creates a new empty journal. This allows the
+ current integration journal to be maintained to a reasonable size.
--- /dev/null
+/* XPM */
+static char * hand_right_xpm[] = {
+/* width height ncolors chars_per_pixel */
+"20 22 4 1",
+/* colors */
+" s None c None",
+". c black",
+"X c wheat",
+"o c sienna",
+/* pixels */
+" ",
+" ",
+" ",
+" ",
+" ...... ",
+" .XXXXXX. ",
+" ..XXXXXXX......... ",
+"..XXXXXXo.XXXXXXXXo.",
+"XXXXXX.XXXXXXoooooo.",
+"XXXXX.oXXXX........ ",
+"XXXXX.XXXoXXXX. ",
+"X.X..oXXXXoXoo. ",
+"XXoooXXXoXXXX. ",
+"X.XXXXXXXoXoo. ",
+"o.XXXXXoXXXX. ",
+"..XXXXXXoXoo. ",
+" .XXXoXXX. ",
+" .XXXooo. ",
+" ...... ",
+" ",
+" ",
+" "};
--- /dev/null
+
+
+set wokclient_priv(debug) 0
+set wokclient_priv(timeout) 10000
+
+
+proc wokclient_read { } {
+
+ wokclient_read_server NAME;
+}
+
+
+proc wokclient_read_server {pathName } {
+
+ global wokclient_priv;
+
+ set readData "";
+ set wokclient_priv($pathName,result) "";
+
+ set fileId $pathName;
+
+ if { [eof $fileId] } {
+ puts "wokclient : lost controller of $pathName"
+
+ close $fileId
+
+ set clidx [lsearch $wokclient_priv(clients) $pathName ]
+
+ if { $clidx != -1 } {
+ if { $clidx == 0 } {
+ set wokclient_priv(clients) {};
+ } {
+ set wokclient_priv(clients) [lreplace $wokclient_priv(clients) $clidx $clidx]
+ }
+ }
+
+ if { [info exists wokclient_priv($pathName)] } {unset wokclient_priv($pathName)}
+ if { [info exists wokclient_priv($pathName,wait)] } {unset wokclient_priv($pathName,wait)}
+ if { [info exists wokclient_priv($pathName,result)] } {unset wokclient_priv($pathName,result)}
+ if { [info exists wokclient_priv($pathName,status)] } {unset wokclient_priv($pathName,status)}
+
+ return;
+ }
+
+
+ set context [scancontext create]
+
+ scanmatch $context "CMD: (.*)$" {
+ set theCmd $matchInfo(submatch0);
+
+ if {$wokclient_priv(debug)} {
+ puts stdout "Received Command : $theCmd";
+ }
+
+ if {[catch "$theCmd" res]} {
+ puts $fileId "ERR: $res"
+ } {
+ puts $fileId "RET: $res"
+ }
+ }
+
+ scanmatch $context "ERR: (.*)$" {
+ set theError $matchInfo(submatch0);
+
+ set wokclient_priv($pathName,status) 1;
+ set wokclient_priv($pathName,result) $theError
+ set wokclient_priv($pathName,wait) 0;
+
+ if {$wokclient_priv(debug)} {
+ puts stdout "Received Error : $theError";
+ }
+ }
+
+ scanmatch $context "RET: (.*)$" {
+ set theReturn $matchInfo(submatch0);
+
+ if {$wokclient_priv(debug)} {
+ puts stdout "Received Return : $theReturn";
+ }
+ lappend wokclient_priv($pathName,result) $theReturn;
+ }
+
+
+ scanmatch $context "END:" {
+ if {$wokclient_priv(debug)} {
+ puts stdout "Received END:"
+ }
+ set wokclient_priv($pathName,wait) 0;
+ return;
+ }
+
+ if { ! [eof $fileId] } {
+ scanfile $context $fileId
+ return;
+ } {
+ close $fileId
+ return;
+ }
+}
+
+proc wokclient_wait {pathName} {
+
+ global wokclient_priv;
+
+ if {$wokclient_priv($pathName,wait)} {
+ after $wokclient_priv(timeout) "set wokclient_priv($pathName,wait) 0; set wokclient_priv($pathName,result) {}"
+ vwait wokclient_priv($pathName,wait);
+ }
+}
+
+proc wokclient_connect { {host "localhost"} {port "1563"} } {
+
+ global wokclient_priv
+
+ set wokclient_priv(CLIENTSOCK) [socket $host $port];
+ set name $wokclient_priv(CLIENTSOCK)
+
+ set newBody [info body wokclient_read]
+ regsub -all NAME $newBody $name newBody
+
+ eval "proc wokclient_read_$name \{\} \{$newBody\}"
+
+ fconfigure $name -blocking 0
+ fconfigure $name -translation {auto lf}
+ fileevent $name readable wokclient_read_$name
+}
+
+proc wokclient_send { command } {
+
+ global wokclient_priv
+
+ if { ! [info exist wokclient_priv(CLIENTSOCK)] } {
+ error "tcl is not connected to a WOK server"
+ return;
+ }
+
+ set wokclient_priv($wokclient_priv(CLIENTSOCK),wait) 1;
+ set wokclient_priv($wokclient_priv(CLIENTSOCK),result) "";
+ set wokclient_priv($wokclient_priv(CLIENTSOCK),status) 0;
+
+ puts $wokclient_priv(CLIENTSOCK) "CMD: $command"
+ puts $wokclient_priv(CLIENTSOCK) "END:"
+ flush $wokclient_priv(CLIENTSOCK)
+
+ wokclient_wait $wokclient_priv(CLIENTSOCK)
+
+ if { $wokclient_priv($wokclient_priv(CLIENTSOCK),status) } {
+ error $wokclient_priv($wokclient_priv(CLIENTSOCK),result)
+ } {
+ return $wokclient_priv($wokclient_priv(CLIENTSOCK),result)
+ }
+
+}
--- /dev/null
+
+set wokemacs_priv(SERVERPORT) 1563
+set wokemacs_priv(lispfile) [file join $env(WOK_LIBRARY) wok-comm.el]
+set wokemacs_priv(debug) 0
+set wokemacs_priv(timeout) 10000
+
+if { [array names wokemacs_priv initialized] == "" } {
+ set wokemacs_priv(initialized) 0
+}
+
+set client ""
+
+proc wokemacs_handle {} {
+}
+
+proc wokemacs_read { } {
+
+ wokemacs_read_data NAME;
+}
+
+proc wokemacs_read_data {pathName } {
+
+ global wokemacs_priv;
+
+ set readData "";
+ set wokemacs_priv($pathName,result) "";
+
+ set fileId $wokemacs_priv($pathName);
+
+ if { [eof $fileId] } {
+ puts "wokemacs : lost controller of $pathName"
+
+ close $fileId
+
+ set clidx [lsearch $wokemacs_priv(clients) $pathName ]
+
+ if { $clidx != -1 } {
+ if { $clidx == 0 } {
+ set wokemacs_priv(clients) {};
+ } {
+ set wokemacs_priv(clients) [lreplace $wokemacs_priv(clients) $clidx $clidx]
+ }
+ }
+
+ if { [info exists wokemacs_priv($pathName)] } {unset wokemacs_priv($pathName)}
+ if { [info exists wokemacs_priv($pathName,wait)] } {unset wokemacs_priv($pathName,wait)}
+ if { [info exists wokemacs_priv($pathName,result)] } {unset wokemacs_priv($pathName,result)}
+ if { [info exists wokemacs_priv($pathName,status)] } {unset wokemacs_priv($pathName,status)}
+
+ return;
+ }
+
+
+ set context [scancontext create]
+
+ scanmatch $context "CMD: (.*)$" {
+ set theCmd $matchInfo(submatch0);
+
+ if {$wokemacs_priv(debug)} {
+ puts stdout "Received Command : $theCmd";
+ }
+
+ if {[catch "$theCmd" res]} {
+ puts $fileId "ERR: $res"
+ } {
+ puts $fileId "RET: $res"
+ }
+ }
+
+ scanmatch $context "ERR: (.*)$" {
+ set theError $matchInfo(submatch0);
+
+ set wokemacs_priv($pathName,status) 1;
+ set wokemacs_priv($pathName,result) $theError
+ set wokemacs_priv($pathName,wait) 0;
+
+ if {$wokemacs_priv(debug)} {
+ puts stdout "Received Error : $theError";
+ }
+ }
+
+ scanmatch $context "RET: (.*)$" {
+ set theReturn $matchInfo(submatch0);
+
+ if {$wokemacs_priv(debug)} {
+ puts stdout "Received Return : $theReturn";
+ }
+ lappend wokemacs_priv($pathName,result) $theReturn;
+ }
+
+ scanmatch $context "END:" {
+ if {$wokemacs_priv(debug)} {
+ puts stdout "Sending END:"
+ }
+ puts $fileId "END:"
+ flush $fileId
+ set wokemacs_priv($pathName,wait) 0;
+ return;
+ }
+
+ if { ! [eof $fileId] } {
+ scanfile $context $fileId
+ return;
+ } {
+ close $fileId
+ return;
+ }
+}
+
+proc wokemacs_wait {pathName} {
+
+ global wokemacs_priv;
+
+ if {$wokemacs_priv($pathName,wait)} {
+ after $wokemacs_priv(timeout) "set wokemacs_priv($pathName,wait) 0; set wokemacs_priv($pathName,result) {}"
+ vwait wokemacs_priv($pathName,wait);
+ }
+}
+
+proc wokemacs_send_command {pathName cmd} {
+
+ global wokemacs_priv
+
+
+ set fileId $wokemacs_priv($pathName)
+
+ if { [eof $fileId] } {
+ error "wokemacs : tried to access a closed socket"
+ }
+
+ puts $fileId "CMD: $cmd"
+ puts $fileId "END:"
+ flush $fileId
+
+ set wokemacs_priv($pathName,wait) 1;
+ set wokemacs_priv($pathName,result) "";
+ set wokemacs_priv($pathName,status) 0;
+
+ wokemacs_wait $pathName
+
+ if { $wokemacs_priv($pathName,status) } {
+ error $wokemacs_priv($pathName,result)
+ } {
+ return $wokemacs_priv($pathName,result)
+ }
+}
+
+
+
+proc wokemacs_accept {name address clientport} {
+
+ global wokemacs_priv
+
+ set newBody [info body wokemacs_read]
+
+
+ regsub -all NAME $newBody $clientport newBody
+
+ eval "proc wokemacs_read_$name \{\} \{$newBody\}"
+
+ if {$wokemacs_priv(debug)} {
+ puts stdout "Name : $name"
+ puts stdout "address : $address"
+ puts stdout "clientport : $clientport"
+ }
+
+ set wokemacs_priv($clientport) $name
+
+ fconfigure $name -blocking 0
+ fconfigure $name -translation {auto lf}
+ fileevent $name readable wokemacs_read_$name
+ lappend wokemacs_priv(clients) $clientport
+ close $wokemacs_priv(SERVERSOCK)
+ return;
+}
+
+
+proc wokemacs_create_server_sock { port } {
+
+ global wokemacs_priv
+ puts $port
+ set wokemacs_priv(SERVERPORT) $port
+ set wokemacs_priv(SERVERSOCK) [socket -server wokemacs_accept $port];
+}
+
+proc wokemacs_init { port } {
+
+ global wokemacs_priv
+
+ puts $port
+
+ set wokemacs_priv(SERVERPORT) $port
+ set wokemacs_priv(SERVERSOCK) [socket -server wokemacs_accept $port];
+ set wokemacs_priv(clients) "";
+ set wokemacs_priv(initialized) 1;
+}
+
+proc wokemacs_create {} {
+
+ global wokemacs_priv
+
+ if { ! $wokemacs_priv(initialized) } {
+ error "wokemacs is not initialized"
+ }
+
+ set nbclients [llength $wokemacs_priv(clients)]
+
+ set newCommand "emacs"
+ append newCommand { -rn WOKEMACS -l $wokemacs_priv(lispfile) -wokwidget WOKEMACS localhost $wokemacs_priv(SERVERPORT)} ;
+
+ eval "exec $newCommand &"
+
+ after $wokemacs_priv(timeout) "set wokemacs_priv(clients) $wokemacs_priv(clients);"
+ vwait wokemacs_priv(clients)
+
+ if { $nbclients == [llength $wokemacs_priv(clients)] } {
+ error "wokemacs : new emacs could not be created"
+ } {
+ return [lindex $wokemacs_priv(clients) [expr [llength $wokemacs_priv(clients)] -1]]
+ }
+}
+
+
+proc wokclient_connect { {host "localhost"} {port "1563"} } {
+
+ global wokemacs_priv
+
+ set wokemacs_priv(CLIENTSOCK) [socket $host $port];
+ set name $wokemacs_priv(CLIENTSOCK)
+
+ set newBody [info body wokemacs_read_server_name]
+ regsub -all NAME $newBody $name newBody
+
+ eval "proc wokemacs_read_$name \{\} \{$newBody\}"
+
+ fileevent $name readable wokemacs_read_$name
+}
+
+proc wokclient_send { command } {
+
+ global wokemacs_priv
+
+ if { ! [info exist wokemacs_priv(CLIENTSOCK)] } {
+ error "tcl is not connected to a WOK server"
+ return;
+ }
+
+ puts $wokemacs_priv(CLIENTSOCK) "CMD: $command"
+ puts $wokemacs_priv(CLIENTSOCK) "END:"
+ flush $wokemacs_priv(CLIENTSOCK)
+
+ wokemacs_wait $wokemacs_priv(CLIENTSOCK)
+
+ return $wokemacs_priv($wokemacs_priv(CLIENTSOCK),result)
+}
+
+proc wokemacs {args} {
+
+ global wokemacs_priv;
+
+ if { [llength $args] == 0} {
+ puts "usage : wokemacs \[init|create|clients...\]"
+ error;
+ }
+ set minorCommand [lindex $args 0]
+
+ case $minorCommand {
+
+ {init} {
+ if { $wokemacs_priv(initialized) } {
+ error "wokemacs is already initialized"
+ }
+ if { [llength $args] == 2 } {
+ puts "[lindex $args 2]";
+ wokemacs_init [lindex $args 2];
+ } {
+ wokemacs_init $wokemacs_priv(SERVERPORT);
+ }
+ }
+ {newserver} {
+ wokemacs_create_server_sock 1563
+ }
+ {create} {
+ if { ! $wokemacs_priv(initialized) } {
+ error "wokemacs is not initialized"
+ }
+ return [wokemacs_create];
+ }
+ {clients} {
+ if { ! $wokemacs_priv(initialized) } {
+ return {}
+ }
+ return $wokemacs_priv(clients)
+ }
+ {sendcmd} {
+ if { ! $wokemacs_priv(initialized) } {
+ error "wokemacs is not initialized"
+ }
+ if { [llength $args] != 3} {
+ error "missing args"
+ }
+ return [wokemacs_send_command [lindex $args 1] [lindex $args 2]]
+ }
+ {findfile} {
+ if { ! $wokemacs_priv(initialized) } {
+ error "wokemacs is not initialized"
+ }
+ if { [llength $args] != 3} {
+ error "missing args"
+ }
+ set thecmd "(find-file \"[lindex $args 2]\")"
+ return [wokemacs_send_command [lindex $args 1] $thecmd]
+ }
+ }
+}
--- /dev/null
+
+
+auto_load wok_cd_proc
+auto_load wok_exit_proc
+auto_load wokemacs
+
+if { [info commands tcl_exit_proc] == "" } {
+ rename exit tcl_exit_proc
+ rename wok_exit_proc exit
+}
+
+
+set tcl_prompt1 {if {[info commands wokcd] != ""} then {puts -nonewline stdout "[wokcd]> "} else {puts -nonewline stdout "tclsh> "}}
+
--- /dev/null
+
+
+proc wok_cd_cmd { format dir } {
+
+ switch $format {
+ csh {
+ return [list "cd $dir\n" ]
+ }
+ tcl {
+ return [list "cd $dir\n" ]
+ }
+ ksh {
+ return [list "cd $dir\n" ]
+ }
+ emacs {
+ return [list "(progn (shell-cd \"$dir\") (shell-dirstack-message))";]
+ }
+ cmd {
+ return [list "cd $dir\n" ]
+ }
+ default {
+ error "Invalid format $format"
+ }
+ }
+
+}
+
+
+proc wok_exit_cmd { format } {
+
+ switch $format {
+ csh {
+ return [list "exit\n"]
+ }
+ tcl {
+ return [list "exit\n"]
+ }
+ ksh {
+ return [list "exit\n"]
+ }
+ emacs {
+ return [list "(save-buffers-kill-emacs)"]
+ }
+ cmd {
+ return [list "exit\n"]
+ }
+ default {
+ error "Invalid format $format"
+ }
+ }
+}
+
+proc wok_setenv_cmd { format var value } {
+
+ switch $format {
+ csh {
+ return [list "setenv $var \"$value\"\n"]
+ }
+ tcl {
+ return [list "global env \n set env($var) \"$value\"\n"]
+ }
+ ksh {
+ return [list "$var=\"$value\"\nexport $var\n"]
+ }
+ sh {
+ return [list "$var=\"$value\"\nexport $var\n"]
+ }
+ emacs {
+ return [list "(setenv \"$var\" \"$value\")"]
+ }
+ cmd {
+ return [list "set $var=\"$value\"\n"]
+ }
+ default {
+ error "Invalid format $format"
+ }
+ }
+}
+
+
+proc wok_source_cmd { format file } {
+
+ switch $format {
+ sh {
+ return [list ". $file\n"]
+ }
+ csh {
+ return [list "source $file\n"]
+ }
+ tcl {
+ return [list "source $file\n"]
+ }
+ ksh {
+ return [list ". $file\n"]
+ }
+ emacs {
+ return [list "(load-file \"$file\")"]
+ }
+ cmd {
+ return [list "call $file\n"]
+ }
+ default {
+ error "Invalid format $format"
+ }
+ }
+}
+
+
+proc wok_cd_proc {args} {
+
+ global IWOK_GLOBALS
+ global WOK_GLOBALS
+ global wokemacs_priv;
+
+ set CLIENTS "";
+
+ set dir "$args"
+
+ if { $WOK_GLOBALS(cd_proc,emacs) } {
+ if { ! [catch {wokemacs clients} CLIENTS] } {
+ foreach client [wokemacs clients] {
+ wokemacs sendcmd $client [lindex [wok_cd_cmd emacs $dir] 0]
+ }
+ }
+ }
+
+ if { $WOK_GLOBALS(cd_proc,term) } {
+ if { [info exists IWOK_GLOBALS(term,started)] } {
+ if { $IWOK_GLOBALS(term,started) } {
+ exp_send -i $IWOK_GLOBALS(term,term_spawn_id) [lindex [wok_cd_cmd csh $dir] 0];
+ }
+ }
+ if { [info exists WOK_GLOBALS(wokinterp,csh,id)] } {
+ exp_send -i $WOK_GLOBALS(wokinterp,csh,id) [lindex [wok_cd_cmd csh $dir] 0];
+ expect -i $WOK_GLOBALS(wokinterp,csh,id) -exact $WOK_GLOBALS(wokinterp,csh,prompt);
+ }
+ }
+
+
+
+ if { $WOK_GLOBALS(cd_proc,tcl) } {
+ catch {eval [lindex [wok_cd_cmd tcl $dir] 0]}
+ }
+ return;
+}
+
+proc wok_exit_proc {args} {
+
+ global wokemacs_priv;
+ global IWOK_GLOBALS
+ global WOK_GLOBALS
+
+
+ #
+ ## Close term connection
+ #
+ if { [info exists IWOK_GLOBALS(term,started)] } {
+ if { $IWOK_GLOBALS(term,started) } {
+ close -i $IWOK_GLOBALS(term,term_spawn_id)
+ }
+ }
+
+ #
+ ## Close Emacs connection
+ #
+ set CLIENTS "";
+ if { ! [catch {wokemacs clients} CLIENTS] } {
+
+ foreach client $CLIENTS {
+ puts "Closing client $client"
+ close $wokemacs_priv($client)
+ }
+ }
+ if { $args == "" } {
+ tcl_exit_proc 0;
+ } {
+ tcl_exit_proc $args
+ }
+}
+
+
+proc wok_setenv_proc {var value} {
+
+ global IWOK_GLOBALS;
+ global WOK_GLOBALS;
+ global wokemacs_priv;
+ global env;
+
+ set limit 200;
+
+ if { $WOK_GLOBALS(setenv_proc,emacs) } {
+ if { ! [catch {wokemacs clients} CLIENTS] } {
+ foreach client [wokemacs clients] {
+ wokemacs sendcmd $client [lindex [wok_setenv_cmd emacs $var $value] 0]
+ }
+ }
+ }
+
+ if { $WOK_GLOBALS(setenv_proc,term) } {
+ if { [info exists IWOK_GLOBALS(term,started)] } {
+ if { $IWOK_GLOBALS(term,started) } {
+
+ # First Initialize Variable
+ set len [clength $value]
+ set debut 0
+
+ set i $limit
+ set sub [crange $value $debut $i]
+ set command [lindex [wok_setenv_cmd csh $var $value] 0]
+ exp_send -i $IWOK_GLOBALS(term,term_spawn_id) $command;
+ sleep .1
+ incr i
+ update
+
+ while { $i < $len } {
+
+ # Then Append trailing
+ set debut $i
+ set i [expr $i + $limit]
+
+ set sub [crange $value $debut $i]
+ exp_send -i $IWOK_GLOBALS(term,term_spawn_id) "setenv $var \"\${$var}$sub\"\n"
+ sleep .1
+ incr i
+ update
+ }
+ }
+ }
+ }
+
+ if { $WOK_GLOBALS(setenv_proc,tcl) } {
+ eval [lindex [wok_setenv_cmd tcl $var $value] 0]
+ }
+ update
+}
+
+proc wok_source_proc {type file} {
+
+ global IWOK_GLOBALS;
+ global WOK_GLOBALS;
+ global env;
+
+ switch $type {
+ csh {
+
+ if { [info exists WOK_GLOBALS(source_proc,term) ] } {
+ if { $WOK_GLOBALS(source_proc,term) } {
+ if { [info exists IWOK_GLOBALS(term,started)] } {
+ if { $IWOK_GLOBALS(term,started) } {
+ exp_send -i $IWOK_GLOBALS(term,term_spawn_id) [lindex [wok_source_cmd csh $file] 0];
+ }
+ }
+ }
+ }
+ }
+ tcl {
+ eval [lindex [wok_source_cmd tcl $file] 0]
+ }
+ emacs {
+ if { $WOK_GLOBALS(setenv_proc,emacs) } {
+ if { ! [catch {wokemacs clients} CLIENTS] } {
+ foreach client [wokemacs clients] {
+ wokemacs sendcmd $client [lindex [wok_source_cmd emacs $file] 0]
+ }
+ }
+ }
+ }
+ default {
+ }
+ }
+ update
+}
--- /dev/null
+;;; woksh.el --- WOK TCL interface
+
+;;; Code:
+
+(require 'comint)
+(require 'shell)
+(require 'wok-comm)
+
+(defvar woksh-program "tclsh"
+ "*Name of program to invoke woksh")
+
+(defvar woksh-explicit-args nil
+ "*List of arguments to pass to woksh on the command line.")
+
+(defvar woksh-mode-hook nil
+ "*Hooks to run after setting current buffer to woksh-mode.")
+
+(defvar woksh-process-connection-type t
+ "*If non-`nil', use a pty for the local woksh process.
+If `nil', use a pipe (if pipes are supported on the local system).
+
+Generally it is better not to waste ptys on systems which have a static
+number of them. On the other hand, some implementations of `woksh' assume
+a pty is being used, and errors will result from using a pipe instead.")
+
+(defvar woksh-directory-tracking-mode 'local
+ "*Control whether and how to do directory tracking in an woksh buffer.
+
+nil means don't do directory tracking.
+
+t means do so using an ftp remote file name.
+
+Any other value means do directory tracking using local file names.
+This works only if the remote machine and the local one
+share the same directories (through NFS). This is the default.
+
+This variable becomes local to a buffer when set in any fashion for it.
+
+It is better to use the function of the same name to change the behavior of
+directory tracking in an woksh session once it has begun, rather than
+simply setting this variable, since the function does the necessary
+re-synching of directories.")
+
+(make-variable-buffer-local 'woksh-directory-tracking-mode)
+
+;; Initialize woksh mode map.
+(defvar woksh-mode-map '())
+(cond
+ ((null woksh-mode-map)
+ (setq woksh-mode-map (if (consp shell-mode-map)
+ (cons 'keymap shell-mode-map)
+ (copy-keymap shell-mode-map)))
+ (define-key woksh-mode-map "\C-c\C-c" 'woksh-send-Ctrl-C)
+ (define-key woksh-mode-map "\C-c\C-d" 'woksh-send-Ctrl-D)
+ (define-key woksh-mode-map "\C-c\C-z" 'woksh-send-Ctrl-Z)
+ (define-key woksh-mode-map "\C-c\C-\\" 'woksh-send-Ctrl-backslash)
+ (define-key woksh-mode-map "\C-d" 'woksh-delchar-or-send-Ctrl-D)
+ (define-key woksh-mode-map "\C-i" 'woksh-tab-or-complete)))
+
+\f
+;;(add-hook 'same-window-regexps "^\\*woksh-.*\\*\\(\\|<[0-9]+>\\)")
+
+(defvar woksh-history nil)
+
+;;;###autoload
+(defun woksh (input-args &optional buffer)
+ "Open a woksh"
+
+ (interactive (list
+ "1566"
+ current-prefix-arg))
+
+ (let* ((process-connection-type woksh-process-connection-type)
+ (args nil)
+ (buffer-name "*woksh*")
+ (iport (string-to-int input-args))
+ proc)
+
+ (cond ((null buffer))
+ ((stringp buffer)
+ (setq buffer-name buffer))
+ ((bufferp buffer)
+ (setq buffer-name (buffer-name buffer)))
+ ((numberp buffer)
+ (setq buffer-name (format "%s<%d>" buffer-name buffer)))
+ (t
+ (setq buffer-name (generate-new-buffer-name buffer-name))))
+
+ (setq buffer (get-buffer-create buffer-name))
+ (pop-to-buffer buffer-name)
+
+ (cond
+ ((comint-check-proc buffer-name))
+ (t
+ (comint-exec buffer buffer-name woksh-program nil args)
+ (setq proc (get-buffer-process buffer))
+ ;; Set process-mark to point-max in case there is text in the
+ ;; buffer from a previous exited process.
+ (set-marker (process-mark proc) (point-max))
+ (woksh-mode)
+
+ ;; comint-output-filter-functions is just like a hook, except that the
+ ;; functions in that list are passed arguments. add-hook serves well
+ ;; enough for modifying it.
+ (add-hook 'comint-output-filter-functions 'woksh-carriage-filter)
+
+ (cd-absolute (concat comint-file-name-prefix "~/"))))
+ (if (not (eq iport 0))
+ (if (not (wok-connectedp))
+ (progn
+ (send-string nil (format "wokemacs_init %d\n" iport))
+ (wok-connect-to-controller "localhost" iport)
+ (send-string nil "auto_load wok_cd_proc\n")
+ (erase-buffer)
+ )))))
+
+(defun woksh-mode ()
+ "Set major-mode for woksh sessions.
+If `woksh-mode-hook' is set, run it."
+ (interactive)
+ (kill-all-local-variables)
+ (shell-mode)
+ (setq major-mode 'woksh-mode)
+ (setq mode-name "woksh")
+ (use-local-map woksh-mode-map)
+ (setq shell-dirtrackp woksh-directory-tracking-mode)
+ (make-local-variable 'comint-file-name-prefix)
+ (run-hooks 'woksh-mode-hook))
+
+(defun woksh-directory-tracking-mode (&optional prefix)
+ "Do remote or local directory tracking, or disable entirely.
+
+If called with no prefix argument or a unspecified prefix argument (just
+``\\[universal-argument]'' with no number) do remote directory tracking via
+ange-ftp. If called as a function, give it no argument.
+
+If called with a negative prefix argument, disable directory tracking
+entirely.
+
+If called with a positive, numeric prefix argument, e.g.
+``\\[universal-argument] 1 M-x woksh-directory-tracking-mode\'',
+then do directory tracking but assume the remote filesystem is the same as
+the local system. This only works in general if the remote machine and the
+local one share the same directories (through NFS)."
+ (interactive "P")
+ (cond
+ ((or (null prefix)
+ (consp prefix))
+ (setq woksh-directory-tracking-mode t)
+ (setq shell-dirtrackp t)
+ (setq comint-file-name-prefix ""))
+ ((< prefix 0)
+ (setq woksh-directory-tracking-mode nil)
+ (setq shell-dirtrackp nil))
+ (t
+ (setq woksh-directory-tracking-mode 'local)
+ (setq comint-file-name-prefix "")
+ (setq shell-dirtrackp t)))
+ (cond
+ (shell-dirtrackp
+ (let* ((proc (get-buffer-process (current-buffer)))
+ (proc-mark (process-mark proc))
+ (current-input (buffer-substring proc-mark (point-max)))
+ (orig-point (point))
+ (offset (and (>= orig-point proc-mark)
+ (- (point-max) orig-point))))
+ (unwind-protect
+ (progn
+ (delete-region proc-mark (point-max))
+ (goto-char (point-max))
+ (shell-resync-dirs))
+ (goto-char proc-mark)
+ (insert current-input)
+ (if offset
+ (goto-char (- (point-max) offset))
+ (goto-char orig-point)))))))
+
+\f
+;; Parse a line into its constituent parts (words separated by
+;; whitespace). Return a list of the words.
+(defun woksh-parse-words (line)
+ (let ((list nil)
+ (posn 0)
+ (match-data (match-data)))
+ (while (string-match "[^ \t\n]+" line posn)
+ (setq list (cons (substring line (match-beginning 0) (match-end 0))
+ list))
+ (setq posn (match-end 0)))
+ (store-match-data (match-data))
+ (nreverse list)))
+
+(defun woksh-carriage-filter (string)
+ (let* ((point-marker (point-marker))
+ (end (process-mark (get-buffer-process (current-buffer))))
+ (beg (or (and (boundp 'comint-last-output-start)
+ comint-last-output-start)
+ (- end (length string)))))
+ (goto-char beg)
+ (while (search-forward "\C-m" end t)
+ (delete-char -1))
+ (goto-char point-marker)))
+
+(defun woksh-send-Ctrl-C ()
+ (interactive)
+ (send-string nil "\C-c"))
+
+(defun woksh-send-Ctrl-D ()
+ (interactive)
+ (send-string nil "\C-d"))
+
+(defun woksh-send-Ctrl-Z ()
+ (interactive)
+ (send-string nil "\C-z"))
+
+(defun woksh-send-Ctrl-backslash ()
+ (interactive)
+ (send-string nil "\C-\\"))
+
+(defun woksh-delchar-or-send-Ctrl-D (arg)
+ "\
+Delete ARG characters forward, or send a C-d to process if at end of buffer."
+ (interactive "p")
+ (if (eobp)
+ (woksh-send-Ctrl-D)
+ (delete-char arg)))
+
+(defun woksh-tab-or-complete ()
+ "Complete file name if doing directory tracking, or just insert TAB."
+ (interactive)
+ (if woksh-directory-tracking-mode
+ (comint-dynamic-complete)
+ (insert "\C-i")))
+;;
+
+(defun wok-command (command)
+ (interactive (list (read-from-minibuffer "Command : "
+ nil nil nil 'woksh-history)))
+ (save-excursion
+
+ (if (not (wok-connectedp))
+ (if (equal "yes" (completing-read "WOK not connected: connect ? (yes/no) : "
+ '(("yes") ("no")) nil t
+ '("yes" . 0) 'woksh-history))
+ (woksh "1566" "*woksh*")
+ ))
+
+ (if (wok-connectedp)
+ (progn
+ (set-buffer "*woksh*")
+ (woksh-parse-words (wok-send-command command)))
+ (progn
+ (ding)
+ (error "Wok controller not connected")))))
+
+;; Goto Entity
+
+(defun wokcd ( userpath )
+ "\
+Moves into a Wok entity"
+ (interactive (list (read-from-minibuffer "wokcd : "
+ nil nil nil 'woksh-history)))
+
+ (wok-command (format "wokcd %s" userpath)))
+
+
+(defun wcd ( Unit )
+ (interactive (list (read-from-minibuffer "wcd : "
+ nil nil nil 'woksh-history)))
+ (wok-command (format "wokcd %s -PSrc" Unit)))
+
+;;; woksh.el ends here
+(defvar woksh-entity-history nil)
+(defvar woksh-type-history nil)
+(defvar woksh-name-history nil)
+
+(defun wok-dired ( Entity Type )
+ (interactive (list
+ (setq myent (completing-read "Entity : "
+ (mapcar 'list (wok-command (format "Sinfo -N"))) nil nil
+ (cons (car (wok-command "wokinfo -n [wokcd]")) 0) 'woksh-entity-history))
+ (completing-read "Type : "
+ (mapcar 'list (wok-command (format "wokinfo -T %s" myent))) nil nil
+ '("source" . 0) 'woksh-type-history)))
+ ;; insert formatted string into a buffer
+ (let ((type Type))
+ (if (not (string-match ":" Type))
+ (setq type (format "%s:." Type)))
+ (set-buffer (dired
+ (car (wok-command (format "wokinfo -p %s %s\n" type Entity)))))
+
+ (rename-buffer (format "%s-%s [%s] (%s)"
+ (car (wok-command (format "wokinfo -n %s" Entity)))
+ type
+ (car (wok-command (format "wokinfo -N %s" Entity)))
+ (car (wok-command (format "wokinfo -t %s" Entity)))))))
+
+(defun wok-findfile ( Entity Type FileName )
+ (interactive (list
+ (setq myent (completing-read "Entity : "
+ (mapcar 'list (wok-command (format "Sinfo -N"))) nil nil
+ (cons (car (wok-command "wokinfo -n [wokcd]")) 0) 'woksh-entity-history))
+ (setq mytype (completing-read "Type : "
+ (mapcar 'list (wok-command (format "wokinfo -T %s" myent))) nil nil
+ '("source" . 0) 'woksh-type-history))
+ (completing-read "Name : "
+ (mapcar 'list (wok-command (format "uinfo -fT%s %s" mytype myent))) nil nil
+ '("" . 0) 'woksh-name-history)))
+ ;; insert formatted string into a buffer
+ (set-buffer (find-file
+ (car (wok-command (format "woklocate -p %s:%s:%s\n" Entity Type FileName)))))
+ )
+
+(defun wok-locate ( Entity Type FileName )
+ (interactive (list
+ (setq myent (completing-read "Entity : "
+ (mapcar 'list (wok-command (format "Sinfo -N"))) nil nil
+ (cons (car (wok-command "wokinfo -n [wokcd]")) 0) 'woksh-entity-history))
+ (setq mytype (completing-read "Type : "
+ (mapcar 'list (wok-command (format "wokinfo -T %s" myent))) nil nil
+ '("source" . 0) 'woksh-type-history))
+ (completing-read "Name : "
+ (mapcar 'list (wok-command (format "uinfo -fT%s %s" mytype myent))) nil nil
+ '("" . 0) 'woksh-name-history)))
+ ;; insert formatted string into a buffer
+ (car (wok-command (format "woklocate -p %s:%s:%s\n" Entity Type FileName)))
+ )
+
+
+(setq wok-compile-defaults '('("umake") ("umake -o obj") ("umake -o exec") ("umake -o xcpp")))
+
+(defun wok-compile ( commande )
+ (interactive (list
+ (completing-read "Command : "
+ wok-compile-defaults nil nil
+ "umake " 'woksh-history)))
+ (set-buffer "*woksh*")
+ (wok-command commande))
+
+(defun concat-list-error (thelist)
+ (let ((res " "))
+ (mapcar (lambda (x)
+ (setq res (concat res x " ")))
+ thelist)
+ res))
+
+(defun receive-tcl-error (linearg)
+ (interactive)
+
+ (kill-buffer (switch-to-buffer-other-window "*compilation*"))
+ (switch-to-buffer-other-window "*compilation*")
+ (compilation-mode)
+ (goto-char (point-max))
+ (insert "\n\n")
+ (insert-file linearg)
+ (compile-goto-error)
+)
--- /dev/null
+/* XPM */
+static char * work_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"32 32 16 1 0 0",
+/* colors */
+" s iconGray4 m white c #949494949494",
+". s iconColor1 m black c black",
+"X c #FFFF63634747",
+"o c #707080809090",
+"O c #2F2F4F4F4F4F",
+"+ c #EEEE8282EEEE",
+"@ c #BEBEBEBEBEBE",
+"# c #DCDCDCDCDCDC",
+"$ s iconColor2 m white c white",
+"% c #A0A052522D2D",
+"& c #E6E6E6E6FAFA",
+"* c #FFFFA5A50000",
+"= s iconColor6 m white c yellow",
+"- c #B2B222222222",
+"; c #CDCD85853F3F",
+": c #D2D2B4B48C8C",
+/* pixels */
+" ",
+" ...... ",
+" ..XXXXXX. ",
+" ..ooOX++XX. ",
+" .@@##$oOXXXX. ",
+" .@@#$$@@oOXXX%. ",
+" .@&&&@@@@@@OX%%. ",
+" ..***@&@@@@oOX%%. ",
+" .====*--&@@ooo.%%. ",
+" .====*$**-&@ooO.%-. ",
+" .====*$****-@oO..--. ",
+" .====*$******-O...-..O ",
+" .====*$*******O..O.-..OOO",
+" .====*$*******%O.Oo....OOO",
+" .;****$*******%%O.oO....OOO",
+" .;:::**;;*****%%%O.O....OOOO",
+" .::&&::;;****%%%;O.....OOOO ",
+" .:&&&:::;;**%%%;O.....OOOO ",
+" .;:&&&::::;*%%%;;O....OOOO ",
+" .::&&:::::;-%%;;-....OOOO ",
+" .:&&:::::::-%;;-....OOOO ",
+" .;:::::::::;-;;-....OOOO ",
+" ...:::::::;;-;-....OOOO ",
+" .@o..::::;;%--....OOOO ",
+" .O$...::;;;%--....OOOO ",
+" .oO....;;;%.......OOO ",
+" .O.....-.......OOOOO ",
+" ............OOOOOOO ",
+" .........OOOOOOOOO ",
+" OOOOOOOOOOOO ",
+" OOOOOOOOO ",
+" OOOOO "};
--- /dev/null
+/* XPM */
+static char * workbench_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"19 19 9 1 0 0",
+/* colors */
+" s none m none c none",
+". s iconColor1 m black c black",
+"X c #999960600000",
+"o c #999940405555",
+"O c #CCCC60600000",
+"+ c #999960605555",
+"@ c #999920205555",
+"# c #CCCC20200000",
+"$ c #333360605555",
+/* pixels */
+" ",
+" ",
+" ",
+" ",
+" ... ",
+" .Xo......XoOoX ",
+" oX+X.......X@X+X ",
+" .#o#o.......oOoOo.",
+".........+.........",
+"..Oo ..... .oXoO",
+"..oX ...$... .....",
+"..Oo ....... .oOoO",
+"..+ . .Xo++",
+"..O . .oXoO",
+".. ... .",
+" o.... ",
+" ",
+" ",
+" "};
--- /dev/null
+/* XPM */
+static char * workbench_open_xpm[] = {
+"19 19 9 1",
+" c #FFFFFFFF0000",
+". c #000000000000",
+"X c #999960600000",
+"o c #999940405555",
+"O c #CCCC60600000",
+"+ c #999960605555",
+"@ c #999920205555",
+"# c #CCCC20200000",
+"$ c #333360605555",
+" ",
+" ",
+" ",
+" ",
+" ... ",
+" .Xo......XoOoX ",
+" oX+X.......X@X+X ",
+" .#o#o.......oOoOo.",
+".........+.........",
+"..Oo ..... .oXoO",
+"..oX ...$... .....",
+"..Oo ....... .oOoO",
+"..+ . .Xo++",
+"..O . .oXoO",
+".. ... .",
+" o.... ",
+" ",
+" ",
+" "};
--- /dev/null
+/* XPM */
+static char * workshop_xpm[] = {
+/* width height ncolors cpp [x_hot y_hot] */
+"32 27 11 1 0 0",
+/* colors */
+" s none m none c none",
+". s iconColor1 m black c black",
+"X s iconColor5 m black c blue",
+"o s iconColor7 m white c cyan",
+"O c #66666060AAAA",
+"+ c #666680805555",
+"@ c #66668080AAAA",
+"# c #999980805555",
+"$ s iconColor3 m black c red",
+"% c #666660605555",
+"& s iconColor6 m white c yellow",
+/* pixels */
+" ",
+" ",
+" ",
+" . ",
+" XXXXXXXXXX.. ",
+" XXXXXXXXXX.. ",
+" XXXXXXXXXX.. ",
+" XXXXXXXXXX.. ",
+" XXXXXXXXXX.. ",
+" ... XX.oooo.XX.. ",
+" .. XX.oooo.XX.. ",
+".... .. . XX.oooo.XX.. ",
+"O+@. . .. XX.oooo.XX.. ",
+"#O#. XX.oooo.XX.. ",
+"@+O. $. XX......XX.. ",
+"#%#. .$$ XXXXXXXXXX.. ",
+" $$$. X&XXXXXXXX.. ",
+"#O#... $$$$$. X&&.XXXXXX.. ",
+"....... ....$. X&XXXXXXXX.. ",
+"#% .... XXXXXXXXXX.. ",
+"O+ .&&&&&&&.. XXXXXXXXXX.. ",
+"#O &&........ XXXXXXXXXX.. ",
+"@+ && . XXXXXXXXXX.. ",
+"#% .. . XXXXXXXXXX.. ",
+"O+ .. . XXXXXXXXXX.. ",
+"#O .. XXXXXXXXXX.. ",
+"................................"};
--- /dev/null
+/* XPM */
+static char * workshop_open_xpm[] = {
+"32 27 11 1",
+" c #FFFFFFFF0000",
+". c #FFFFFFFFFFFF",
+"X c #000000000000",
+"o c #00000000FFFF",
+"O c #0000FFFFFFFF",
+"+ c #66666060AAAA",
+"@ c #666680805555",
+"# c #66668080AAAA",
+"$ c #999980805555",
+"% c #FFFF00000000",
+"& c #666660605555",
+" ",
+" ",
+" ",
+" ............X ",
+" .ooooooooooXX ",
+" .ooooooooooXX ",
+" .ooooooooooXX ",
+" .ooooooooooXX ",
+" .ooooooooooXX ",
+" XXX .ooXOOOOXooXX ",
+" ..XX .ooXOOOOXooXX ",
+"XXXX XX..X .ooXOOOOXooXX ",
+"+@#X X..XX .ooXOOOOXooXX ",
+"$+$X . .ooXOOOOXooXX ",
+"#@+X %X .ooXXXXXXooXX ",
+"$&$X X%% .ooooooooooXX ",
+" %%%X .o ooooooooXX ",
+"$+$XXX..%%%%%X. .o XooooooXX ",
+"XXXXXXX XXXX%X. .o ooooooooXX ",
+"$& XXXX. .ooooooooooXX ",
+"+@ X XX .ooooooooooXX ",
+"$+ XXXXXXXX .ooooooooooXX ",
+"#@ X .ooooooooooXX ",
+"$& XX X .ooooooooooXX ",
+"+@ XX X .ooooooooooXX ",
+"$+ .... XX .ooooooooooXX ",
+"XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"};
--- /dev/null
+#############################################################################
+#
+# W P R E P A R E
+# _______________
+#
+#############################################################################
+#
+# Usage
+#
+proc wokPrepareUsage { } {
+ puts stderr { Usage: wprepare [-ref] [-ud <ud_1,ud_2, ..,ud_N>] -o [filename]}
+ puts stderr { Note: If your specify more than one unit, separate names with a comma.}
+ puts stderr { }
+ puts stderr { The following options allows you to select files based on time. }
+ puts stderr { }
+ puts stderr { wprepare -since markname [-ud <ud_1,ud_2, ..,ud_N>] -o [filename] }
+ puts stderr { Select in the current workbench all files modified since the date }
+ puts stderr { pointed to the mark markname ( See command wnews. ) }
+ puts stderr { }
+ puts stderr { wprepare -newer file [-ud <ud_1,ud_2, ..,ud_N>] -o [filename] }
+ puts stderr { Select in the current workbench all files newer than file. }
+ puts stderr { (The term newer refers to the modification time.) }
+ puts stderr { }
+ return
+}
+#
+# Point d'entree de la commande
+#
+proc wprepare { args } {
+
+ global wokfileid
+ global WOKVC_STYPE WOKVC_LTYPE
+
+ set tblreq(-h) {}
+ set tblreq(-ud) value_required:list
+ set tblreq(-ref) {}
+ set tblreq(-o) value_required:file
+
+ set tblreq(-son) value_required:string
+ set tblreq(-dad) value_required:string
+
+ set tblreq(-ws) value_required:string
+
+ set tblreq(-since) value_required:string
+
+ set tblreq(-newer) value_required:string
+
+ set param {}
+ if { [wokUtils:EASY:GETOPT param tabarg tblreq wokPrepareUsage $args] == -1 } return
+
+ if [info exists tabarg(-h)] {
+ wokPrepareUsage
+ return
+ }
+
+ if [info exists tabarg(-son)] {
+ set WBFils $tabarg(-son)
+ } else {
+ set WBFils [wokinfo -w]
+ }
+
+ if [info exists tabarg(-dad)] {
+ set WBPere $tabarg(-dad)
+ } else {
+ set WBPere [lindex [w_info -A $WBFils] 1]
+ }
+
+
+ if [info exists tabarg(-o)] {
+ set wokfileid [open $tabarg(-o) w]
+ eval "proc wprepare_return { } { close $wokfileid ; return }"
+ } else {
+ set wokfileid stdout
+ eval "proc wprepare_return { } { return }"
+ }
+
+ if [info exists tabarg(-ud)] {
+ set LUnits $tabarg(-ud)
+ } else {
+ set LUnits [w_info -l $WBFils]
+ }
+
+
+ if [info exists tabarg(-ws)] {
+ set fshop $tabarg(-ws)
+ } else {
+ set fshop [wokinfo -s [wokcd]]
+ }
+
+ if [info exists tabarg(-since)] {
+ if { [set journal [wokIntegre:Journal:GetName $fshop]] == {} } {
+ msgprint -c WOKVC -e "Journal file not found in workshop $fshop."
+ return
+ }
+ set num [wokIntegre:Mark:Get $journal $tabarg(-since)]
+ set date [wokIntegre:Journal:ReportDate $journal $num]
+ if { $date != {} } {
+ wokclose -a
+ wokPrepare:Report:InitTypes
+ wokPrepare:Report:Output banner [wokinfo -n [wokinfo -s $WBFils]] $WBFils
+ wokPrepare:Unit:Since wokPrepare:Report:Output ${WBFils} $LUnits $date
+ puts $wokfileid "is"
+ puts $wokfileid " Author : [id user]"
+ puts $wokfileid " Study/CSR : "
+ puts $wokfileid " Debug : "
+ puts $wokfileid " Improvements : "
+ puts $wokfileid " News : Files modified since [fmtclock $date]"
+ puts $wokfileid " Deletions : "
+ puts $wokfileid " Impact : "
+ puts $wokfileid " Comments : "
+ puts $wokfileid "end;"
+ catch {unset wokfileid}
+ wprepare_return
+ return
+ } else {
+ msgprint -c WOKVC -e "Unknown mark. Try the command : wnews -admin."
+ return
+ }
+ }
+
+ if [info exists tabarg(-newer)] {
+ set datf [file mtime $tabarg(-newer)]
+ if { [info exists datf] } {
+ wokclose -a
+ wokPrepare:Report:InitTypes
+ wokPrepare:Report:Output banner [wokinfo -n [wokinfo -s $WBFils]] $WBFils
+ wokPrepare:Unit:Since wokPrepare:Report:Output ${WBFils} $LUnits $datf
+ wokPrepare:Report:Output notes
+ catch {unset wokfileid}
+ wprepare_return
+ return
+ } else {
+ msgprint -c WOKVC -e "Unknown mark. Try the command : wnews -admin."
+ return
+ }
+ }
+
+ wokclose -a
+
+ wokPrepare:Report:InitTypes
+
+ set SHPere [wokinfo -s $WBPere]
+ set SHFils [wokinfo -s $WBFils]
+
+ wokPrepare:Report:Output banner [wokinfo -n $SHFils] $WBFils
+
+ if { [info exists tabarg(-ref)] || [wokUtils:WB:IsRoot $WBFils] } {
+ wokPrepare:Unit:Ref wokPrepare:Report:Output ${WBFils} $LUnits
+ } else {
+ wokPrepare:Unit:Loop wokPrepare:Report:Output ${WBPere} ${WBFils} $LUnits
+ }
+
+ wokPrepare:Report:Output notes
+
+ catch {unset wokfileid}
+ wprepare_return
+}
+#;>
+# Boucle sur une liste {type name}, ecrit dans table(name.type) = " # name etc.."
+# pour tous les fichiers dont la mtime est superieur strictement a date.
+# wokPrepare:Unit:Ref Mytable DEMO:Demo:Kernel {NTD AccesServer}
+# Wb: un prefixe quelconque a une Ud
+#;<
+proc wokPrepare:Unit:Since { Fout Wb Uliste date } {
+ foreach e $Uliste {
+ set t [uinfo -t ${Wb}:${e}]
+ $Fout uheader "$e.$t"
+ foreach f [lsort [uinfo -pl -Tsource ${Wb}:${e}]] {
+ set mti [file mtime $f]
+ if { $mti > $date } {
+ $Fout files # [fmtclock [file mtime $f] "%d/%m/%y %R"] [file tail $f] [file dirname $f]
+ }
+ }
+ }
+ return
+}
+#;>
+# Boucle sur une liste {type name}, ecrit dans table(name.type) = " + name etc.."
+# wokPrepare:Unit:Ref Mytable DEMO:Demo:Kernel {NTD AccesServer}
+# Wb: un prefixe quelconque a une Ud
+#;<
+proc wokPrepare:Unit:Ref { Fout Wb Uliste } {
+ foreach e $Uliste {
+ set t [uinfo -t ${Wb}:${e}]
+ $Fout uheader "$e.$t"
+ foreach f [lsort [uinfo -pl -Tsource ${Wb}:${e}]] {
+ $Fout files + [fmtclock [file mtime $f] "%d/%m/%y %R"] [file tail $f] [file dirname $f]
+ }
+ }
+ return
+}
+
+#;>
+# Boucle sur une liste {type name}, ecrit dans table le resultat de la comparaison
+# wokPrepare:Unit:Loop Mytable DEMO:Demo:Kernel DEMO:Demo:FK {NTD AccesServer}
+# Pere = FACT:SHOP:WBPERE , Fils: FACT:SHOP:WBFILS
+#;<
+proc wokPrepare:Unit:Loop { Fout Pere Fils Uliste } {
+ set lupere [w_info -l $Pere]
+ foreach e $Uliste {
+ set t [uinfo -t ${Fils}:${e}]
+ $Fout uheader "$e.$t"
+ set loc [uinfo -fl -Tsource ${Fils}:$e]
+ if { [lsearch $lupere $e] != -1 } {
+ wokPrepare:Unit:Diff $Fout [uinfo -fp -Tsource ${Pere}:$e] [uinfo -fp -Tsource ${Fils}:$e] $loc
+ } else {
+ wokPrepare:Unit:Diff $Fout {} [uinfo -fp -Tsource ${Fils}:$e] $loc
+ }
+ }
+}
+
+#;>
+#
+# l1 liste des sources vue du pere {basename dirname}
+# l2 " " vue du fils " "
+# local basename des sources effectivement dans dfils
+#
+# retourne une liste des comparaisons
+#;<
+proc wokPrepare:Unit:Diff { Fout l1 l2 local } {
+ ;#
+ ;# 1. Comparaison de l1 et l2 dans wokM
+ ;#
+ catch {unset wokM}
+ foreach e $l1 {
+ set wokM([lindex $e 0]) [list - [lindex $e 1]]
+ }
+
+ foreach e $l2 {
+ set k [lindex $e 0]
+ set p [lindex $e 1]
+ if { [info exists wokM($k)] } {
+ set l $wokM($k)
+ set wokM($k) [list # [lindex $l 1] $p]
+ } else {
+ set wokM($k) [list + $p]
+ }
+ }
+ ;#
+ ;# 2. Parcours de wokM : impression des nouveaux et des disparus
+ ;#
+ ;#parray wokM
+ foreach e [array names wokM] {
+ switch -- [lindex $wokM($e) 0] {
+ - {
+ set file [lindex $wokM($e) 1]
+ if [file exists $file] {
+ $Fout files - [fmtclock [file mtime $file] "%d/%m/%y %R"] $e [file dirname $file]
+ } else {
+ ;#msgprint -w "Unit files list should be recomputed. (umake -o src)"
+ }
+ }
+
+ + {
+ set file [lindex $wokM($e) 1]
+ if [file exists $file] {
+ $Fout files + [fmtclock [file mtime $file] "%d/%m/%y %R"] $e [file dirname $file]
+ } else {
+ ;#msgprint -w "Unit files list should be recomputed. (umake -o src)"
+ }
+ }
+
+ # {
+ if { [lsearch $local $e] != -1 } {
+ set fpere [lindex $wokM($e) 1] ; set ffils [lindex $wokM($e) 2]
+ set date [fmtclock [file mtime $ffils] "%d/%m/%y %R"]
+ if { [file isfile $fpere] && [file isfile $ffils] } {
+ if { [wokUtils:FILES:AreSame $fpere $ffils] } {
+ $Fout files = $date $e [file dirname $ffils] [file dirname $fpere]
+ } else {
+ $Fout files # $date $e [file dirname $ffils] [file dirname $fpere]
+ }
+ }
+ }
+ }
+ }
+ }
+
+ return
+}
+#;>
+# Lit un report et charge :
+# 1. La banniere dans banner (liste de 3 elements)
+# 2. les UDs dans table ( index = name(type) )
+# 3. Les ReleasesNotes dans notes (liste de n elements)
+#;<
+proc wokPrepare:Report:Read { name table banner notes } {
+ upvar $table TLOC $banner BLOC $notes NLOC
+ set l [wokUtils:FILES:FileToList $name]
+ set BLOC [lrange $l 0 2]
+ set is [lsearch -regexp $l (^is$) ]
+ set NLOC [lrange $l [expr $is+1] [expr [llength $l]-2] ]
+ foreach x [lrange $l 5 [expr $is -1]] {
+ set uheader [wokPrepare:Report:UnitHeader decode $x]
+ if { $uheader != {} } {
+ set key $uheader
+ set TLOC($key) {}
+ } else {
+ set l $TLOC($key)
+ set TLOC($key) [lappend l $x]
+ }
+ }
+ return
+}
+#;>
+# ecrit station workshop workbench sur fileid
+#;<
+proc wokPrepare:Report:WriteInfo { station workshop workbench {fileid stdout}} {
+ puts $fileid [format "Station : %s" $station];
+ puts $fileid [format "Workshop : %s" $workshop];
+ puts $fileid [format "Workbench : %s\n" $workbench];
+ return
+}
+#;>
+# retourne station workshop workbench
+#;<
+proc wokPrepare:Report:ListInfo { station workshop workbench {fileid stdout}} {
+ return [list \
+ [format "Station : %s" $station]\
+ [format "Workshop : %s" $workshop]\
+ [format "Workbench : %s" $workbench]\
+ ]
+}
+#;>
+# decode info (liste de 3 elements ) dans les variables qui suivent
+#;<
+proc wokPrepare:Report:ReadInfo { info station workshop workbench } {
+ upvar $station staloc $workshop wsloc $workbench wbloc
+ regexp {Station : (.*)} [lindex $info 0] ignore staloc
+ regexp {Workshop : (.*)} [lindex $info 1] ignore wsloc
+ regexp {Workbench : (.*)} [lindex $info 2] ignore wbloc
+ return
+}
+
+#;>
+# Init d'une global pour utiliser simplement les types de Wok.
+# (Voir wokPrepare:Report:UnitHeader)
+#
+#;<
+proc wokPrepare:Report:InitTypes {} {
+ global WOKVC_STYPE WOKVC_LTYPE
+ set ucreateP \
+ [list {p package} {s schema} {i interface} {C client} {e engine} {x executable}\
+ {n nocdlpack} {t toolkit} {r resource} {O documentation} {c ccl} {f frontal}\
+ {d delivery} {I idl} {S server}]
+ foreach itm $ucreateP {
+ set shrt [lindex $itm 0]
+ set long [lindex $itm 1]
+ set WOKVC_STYPE($shrt) $long
+ set WOKVC_LTYPE($long) $shrt
+ }
+ return
+}
+#;>
+# Encode/decode un nom d'UD dans un report
+# code "Technos.nocdlpack" -> " * Technos (nocdlpack):"
+# decode " * Technos (nocdlpack):" -> "Technos.nocdlpack" {} si le regexp n'est pas trouvee
+# tolong "Doc.r" -> {resource Doc}
+# longto {resource Doc} -> "Doc.r"
+# stol et ltos self explan.
+# default "Technos nocdlpack" -> Technos.nocdlpack (Utilise comme index des tables)
+#;<
+proc wokPrepare:Report:UnitHeader {option string} {
+ global WOKVC_LTYPE WOKVC_STYPE
+ switch $option {
+ code {
+ set uheader [regexp {(.*)\.(.*)} $string all udname type]
+ return [format " * %s (%s):" $udname $type]
+ }
+
+ decode {
+ set uheader [regexp { \* (.*) \((.*)\):} $string all udname type]
+ if { $uheader } {
+ return ${udname}.$WOKVC_LTYPE($type)
+ } else {
+ return {}
+ }
+ }
+
+ tolong {
+ set l [split $string .]
+ return [list $WOKVC_STYPE([lindex $l 1]) [lindex $l 0]]
+ }
+
+ stol {
+ if [info exists WOKVC_STYPE($string)] {
+ return $WOKVC_STYPE($string)
+ }
+ }
+
+ ltos {
+ if [info exists WOKVC_LTYPE($string)] {
+ return $WOKVC_LTYPE($string)
+ }
+ }
+
+
+ default {
+ return ${option}.${string}
+ }
+ }
+}
+#;>
+# Ecrit un report avec le contenu de strlist
+#;<
+proc wokPrepare:Report:Skel { strlist } {
+}
+#;>
+#
+# Appele pour sortir un report sur fileid
+#
+#;<
+proc wokPrepare:Report:Output { opt args } {
+
+ global wokfileid
+ set fileid $wokfileid
+
+ switch $opt {
+
+ banner {
+ set shop [lindex $args 0]
+ set wb [lindex $args 1]
+ set buf [replicate _ 30]
+ set buf_path [replicate _ 61]
+ wokPrepare:Report:WriteInfo [id host] $shop $wb $fileid
+ puts $fileid [format " S Date Time Name"];
+ puts $fileid [format " _ ________ _____ %s %s" $buf $buf_path];
+ }
+
+ uheader {
+ puts $fileid ""
+ puts $fileid [wokPrepare:Report:UnitHeader code $args]
+ puts $fileid ""
+ }
+
+ files {
+ set flag [lindex $args 0]
+ set date [lindex $args 1]
+ set e [lindex $args 2]
+ switch -- $flag {
+ + {
+ set dfils [lindex $args 3]
+ puts $fileid [format " + %s %-30s %s" $date $e $dfils]
+ }
+ - {
+ set pnts "........................................"
+ set dpere [lindex $args 3]
+ puts $fileid [format " - %s %-30s %s %s" $date $e $pnts $dpere]
+ }
+ = {
+ set dfils [lindex $args 3]
+ set dpere [lindex $args 4]
+ puts $fileid [format " = %s %-30s %-40s %s" $date $e $dfils $dpere]
+ }
+ # {
+ set dfils [lindex $args 3]
+ set dpere [lindex $args 4]
+ puts $fileid [format " # %s %-30s %-40s %s" $date $e $dfils $dpere]
+ }
+ }
+
+ }
+
+ notes {
+ wokIntegre:Journal:ReleaseNotes $fileid
+ }
+
+ }
+}
--- /dev/null
+;#
+;# This proc is invoked by the command: wstore -trig <report>
+;# It should be placed in the Adm directory of the concerned shop,
+;# and the file should be named wstore_trigger.tcl
+;#
+proc wstore_trigger { {action put} report_path } {
+
+ set saved_wokcd [wokcd]
+
+ switch -- $action {
+
+ put {
+ ;# in this case <report_path> is the full path of the report being processed.
+ set saved_wokcd [wokcd]
+ wokcd KERNEL:Ker6
+ wstore $report_path
+ }
+
+ rm {
+ ;# in this case <report_path> is a digit: The queue index of the report being deleted.
+ }
+
+ default {
+ }
+ }
+
+ wokcd $saved_wokcd
+ wokclose -a
+ return
+}
projects / occt-wok.git / commitdiff