set wbtop $tabarg(-root)
msgprint -c WOKVC -i "Using $wbtop as target workbench."
} else {
- set wbtop [wokIntegre:RefCopy:GetWB]
+ set wbtop [wokIntegre:RefCopy:GetWB $fshop]
}
if { [info exists tabarg(-all)] } {
return -1
}
- set vc [file join [wokinfo -pAdmDir:. $fshop] VC.tcl]
- if [file exists $vc] {
- source $vc
- } else {
- msgprint -c WOKVC -e "Pas de fichier VC.tcl dans adm de ${fshop} ."
- return -1
- }
-
- set ros [wokIntegre:RefCopy:OpenWB]
- set los [wokIntegre:RefCopy:OpenUD]
-
if { "$BTYPE" == "NOBASE" } {
wokIntegrenobase
} else {
return
}
#;>
+# Traitement des bazes ClearCase
+#;<
+proc wokIntegreClearCase { } {
+ uplevel {
+ puts "Integre dans bases ClearCase"
+ foreach REPORT $LISTREPORT {
+ if { $VERBOSE } { msgprint -c WOKVC -i "Processing report in $REPORT" }
+ set comment ""
+ ;#
+ ;# Lecture du report
+ ;#
+ set mode normal
+ if { $refer } { set mode ref }
+ catch {unset table}
+ set stat [wokStore:Report:Process $mode $REPORT table info notes]
+
+ foreach UD [lsort [array names table]] {
+ puts stdout [format "echo Processing unit : %s" $UD]
+ set root [wokIntegre:BASE:GetVOBName [Sinfo -f] $shop $wbtop $UD]
+ if { $root != {} } {
+ foreach ELM $table($UD) {
+ set F [lindex $ELM 1]
+ set name [file tail $F]
+ set sfl $root/$name
+ if [file exists $sfl] {
+ set cmdco "cleartool co -nda -nc $sfl"
+ if { [lindex [set resco [wokUtils:EASY:command $cmdco 1 0]] 0] == 1 } {
+ } else {
+ msgprint -c WOKVC -e "ClearCase checkout failed for $sfl"
+ }
+ set cmdci "cleartool ci -c $comment -from $F $sfl"
+ if { [lindex [set resci [wokUtils:EASY:command $cmdci 1 0]] 0] == 1 } {
+ } else {
+ msgprint -c WOKVC -e "ClearCase checkin failed for $sfl"
+ }
+ } else {
+ set cmdco "cleartool co -nc $root";# check out directory
+ if { [lindex [set resco [wokUtils:EASY:command $cmdco 1 0]] 0] == 1 } {
+ } else {
+ msgprint -c WOKVC -e "ClearCase checkout failed for $sfl"
+ }
+ wokUtils:FILES:copy $F $sfl ;# copy element dans la base
+ set cmdmk "cleartool mkelem -ci -c $comment $sfl" ;# creation elem
+ if { [lindex [set resmk [wokUtils:EASY:command $cmdmk 1 0]] 0] == 1 } {
+ } else {
+ msgprint -c WOKVC -e "ClearCase checkout failed for $sfl"
+ }
+ set cmdci "cleartool ci -c $comment $root"
+ }
+ }
+ } else {
+ msgprint -c WOKVC -e "The unit $UD has no entry in the VOB $wbtop"
+ }
+ }
+ }
+ }
+ return
+}
+#;>
+# retourne le path de la vob associee a fact-shop-wb-UD.
+#:<
+proc wokIntegre:BASE:GetVOBName { fact shop wb UD } {
+ return /vobs/GRIV/k1dev/k1dev/V3d/src
+ set ud [lindex [split $UD .] 0]
+ if [wokinfo -x ${wb}:${ud}] {
+ return [wokinfo -p source:. ${wb}:${ud}]
+ } else {
+ return {}
+ }
+}
+#;>
# Miscellaneous: Assemblage traitement avec base
#;<
proc wokIntegrebase { } {
;# 1 bis. Tester [id user] peut ecrire dans le workbench qui sert de REFCOPY
;#
if { $refcopy == 1 } {
- set write_ok [wokIntegre:RefCopy:Writable $fshop table $wbtop $ros $los]
+ set write_ok [wokIntegre:RefCopy:Writable $fshop table $wbtop]
if { $write_ok == -1 } {
msgprint -c WOKVC -e "You cannot write or create units in the workbench $wbtop"
wokIntegreCleanup $broot table [list $cmdid $jnlid] $dirtmp
if { $refcopy == 1 } {
catch {unset table}
wokIntegre:Journal:PickReport $jnltmp table notes $num
- wokIntegre:RefCopy:GetPathes $fshop table $wbtop $ros $los
+ wokIntegre:RefCopy:GetPathes $fshop table $wbtop
set dirtmpu /tmp/wintegrecreateunits[id process]
catch {
rmdir -nocomplain $dirtmpu
wokIntegre:RefCopy:FillRef $fshop table $chkid
wokIntegre:BASE:EOF $chkid
close $chkid
- msgprint -c WOKVC -i "Updating units in target workbench(es) $wbtop $ros"
+ msgprint -c WOKVC -i "Updating units in workbench $wbtop"
set statx [wokIntegre:BASE:Execute $VERBOSE $chkout]
if { $statx != 1 } {
msgprint -c WOKVC -e "during checkout(Get). The report has not been removed."
return -1
}
- set write_ok [wokIntegre:RefCopy:Writable $fshop table $wbtop $ros $los]
+ set write_ok [wokIntegre:RefCopy:Writable $fshop table $wbtop]
if { $write_ok == -1 } {
msgprint -c WOKVC -e "You cannot write or create units in the workbench $wbtop"
wokIntegreCleanup $broot table [list $jnlid] $dirtmp
return -1
}
- set pathes_ok [wokIntegre:RefCopy:GetPathes $fshop table $wbtop $ros $los]
+ set pathes_ok [wokIntegre:RefCopy:GetPathes $fshop table $wbtop]
if { $write_ok == -1 } {
wokIntegreCleanup $broot table [list $jnlid] $dirtmp
return -1
break
}
}
- puts $fshop
msgprint -c WOKVC -i "Repository root : [wokparam -e %VC_ROOT $fshop]"
msgprint -c WOKVC -i "Repository type : [wokparam -e %VC_TYPE $fshop]"
- msgprint -c WOKVC -i "Attached to : [wokIntegre:RefCopy:GetWB]"
+ msgprint -c WOKVC -i "Attached to : [wokIntegre:RefCopy:GetWB $fshop]"
}
return [wokparam -e %VC_TYPE $fshop]
} else {
#;>
# Check owner et fait ucreate si necessaire des UDs de table
# 1. ucreate -p workbench:NTD si owner OK
-# workbench est celui dans lequel on integre sauf si UD est dans
-# la liste $los auquel cas l'integration se fait dans ros
-#;<
-proc wokIntegre:RefCopy:Writable { fshop table workbench ros los} {
+#;<
+proc wokIntegre:RefCopy:Writable { fshop table workbench } {
upvar $table TLOC
-
foreach UD [array names TLOC] {
regexp {(.*)\.(.*)} $UD ignore name type
- if { [lsearch $los $name] != -1 } {
- set destwb $ros
- } else {
- set destwb $workbench
+ if { [lsearch [w_info -l ${fshop}:${workbench}] $name ] == -1 } {
+ ;# if workbench is writable ..
+ ;#msgprint -c WOKVC -i "Creating unit ${fshop}:${workbench}:${name}"
+ ucreate -$type ${fshop}:${workbench}:${name}
}
- if { [lsearch [w_info -l ${fshop}:${destwb}] $name ] == -1 } {
- ucreate -$type ${fshop}:${destwb}:${name}
- }
- set dirsrc [wokinfo -p source:. ${fshop}:${destwb}:${name}]
- ;#puts " writable dirsrc = $dirsrc"
+ set dirsrc [wokinfo -p source:. ${fshop}:${workbench}:${name}]
if ![file writable $dirsrc] {
- msgprint -c WOKVC -e "You cannot write in workbench $destwb ($dirsrc)"
+ msgprint -c WOKVC -e "You cannot write in directory $dirsrc"
return -1
}
}
# Input: table(NTD.p) = { {toto.c 2.1} {titi.c 4.3} }
# Output: table(NTD.p) = { /home/wb/qqchose/NTD/src {toto.c 2.1} {titi.c 4.3} }
#;<
-proc wokIntegre:RefCopy:GetPathes { fshop table workbench ros los} {
+proc wokIntegre:RefCopy:GetPathes { fshop table workbench } {
upvar $table TLOC
- ;#puts "-------------AVANT getpathes ----------------"
- ;#parray TLOC
foreach UD [array names TLOC] {
regexp {(.*)\.(.*)} $UD ignore name type
- if { [lsearch $los $name] != -1 } {
- set destwb $ros
- } else {
- set destwb $workbench
- }
- if { [lsearch [w_info -l ${fshop}:$destwb] $name ] != -1 } {
+ if { [lsearch [w_info -l ${fshop}:$workbench] $name ] != -1 } {
set lsf $TLOC($UD)
- set TLOC($UD) [linsert $lsf 0 [wokparam -e %${name}_Src ${fshop}:${destwb}:${name}]]
+ set TLOC($UD) [linsert $lsf 0 [wokparam -e %${name}_Src ${fshop}:${workbench}:${name}]]
} else {
- msgprint -c WOKVC -e "(GetPathes) Unit $name not found in $destwb"
+ msgprint -c WOKVC -e "(GetPathes) Unit $name not found in $workbench"
return -1
}
}
- ;#puts "-------------APRES----------------"
- ;#parray TLOC
+ return 1
+}
+#;>
+# Modifie si c'est possible les protections des elements de table (liste)
+# si ils appartiennent a <user>
+# Utilise par wget en reference
+# Input: table(NTD.p) = { /home/wb/qqchose/NTD/src {toto.c 2.1} {titi.c 4.3} }
+#;<
+proc wokIntegre:RefCopy:SetWritable { table user } {
+ upvar $table TLOC
+ foreach UD [array names TLOC] {
+ set dirsrc [lindex $TLOC($UD) 0]
+ foreach e [lrange $TLOC($UD) 1 end] {
+ set file $dirsrc/[lindex $e 0]
+ if [file owned $file] {
+ chmod u+w $file
+ } else {
+ msgprint -c WOKVC -e "Protection of $file cannot be modified (File not found or not owner)."
+ return -1
+ }
+ }
+ }
return 1
}
#;>
}
return
}
+#;>
+# Retourne le nom du ou des workbench qu'il faut alimenter apres l'integration
+# Valeur d'un param si il existe sinon workbench racine de l'ilot
+#
+#;<
+proc wokIntegre:RefCopy:GetWB { fshop } {
+ if { [wokparam -t %VC_WBROOT $fshop] == 0 } {
+ foreach wb [sinfo -w $fshop] {
+ if [expr { ( [llength [w_info -A ${fshop}:${wb}]] > 1 ) ? 0 : 1 }] {
+ return $wb
+ }
+ }
+ return {}
+ } else {
+ return [wokparam -e %VC_WBROOT $fshop]
+ }
+}
#
# ((((((((((((((((VERSION))))))))))))))))
#
if [info exists tabarg(-from)] {
set fromwb $tabarg(-from)
} else {
- set fromwb [wokIntegre:RefCopy:GetWB]
+ set fromwb [wokIntegre:RefCopy:GetWB $fshop]
}
}
}
- if { [wokIntegre:RefCopy:Writable $fshop table $workbench {} {}] == -1 } {
+ if { [wokIntegre:RefCopy:Writable $fshop table $workbench] == -1 } {
return -1
}
- wokIntegre:RefCopy:GetPathes $fshop table $workbench {} {}
+ wokIntegre:RefCopy:GetPathes $fshop table $workbench
if { [llength [w_info -A ${fshop}:$workbench]] == 1 } {
msgprint -c WOKVC -w "You are working in the reference area."
- return -1
+ wokIntegre:RefCopy:SetWritable table [id user]
+ set forced 1
}
if { [wokUtils:FILES:dirtmp [set dirtmp /tmp/wintegrecreateunits[id process]]] == -1 } {
regexp {(.*)\.(.*)} $UD ignore name type
if { [lsearch [w_info -l $workbench] $name ] == -1 } {
;# if workbench is writable ..
- ;#msgprint -c WOKVC -i "Creating unit ${workbench}:${name}"
+ msgprint -c WOKVC -i "Creating unit ${workbench}:${name}"
ucreate -$type ${workbench}:${name}
}
set dirsrc [wokinfo -p source:. ${workbench}:${name}]
}
return
}
+#
+# Base ClearCase
+#
+proc wokGetClearCase { } {
+ uplevel {
+ ;#puts "wget pour clearcase:"
+ ;# workbench racine de l'ilot ??
+ foreach wb [sinfo -w $shop] {
+ if {[wokUtils:WB:IsRoot $wb]} {
+ set root $wb
+ break
+ }
+ }
+
+ set listfileinbase [wokUtils:FILES:ls [wokinfo -p source:. ${root}:${ud}]]
+
+ if [info exists listbase] {
+ set laff [wokUtils:LIST:GM $listfileinbase $param]
+ foreach f $laff {
+ puts $f
+ }
+ return
+ }
+
+ if [info exists ID] {
+ msgprint -c WOKVC -w "Value $ID for option -r ignored in this context (NOBASE)."
+ return
+ } else {
+ if { $param == {} } {
+ foreach f $listfileinbase {
+ puts $f
+ }
+ return
+ }
+ if { [set RES [wokUtils:LIST:GM $listfileinbase $param]] == {} } {
+ msgprint -c WOKVC -e "No match for $param in unit $ud."
+ }
+ set locud [woklocate -u $ud]
+ if { $locud != {} } {
+ set table(${ud}.[uinfo -c $locud]) $RES
+ } else {
+ msgprint -c WOKVC -e "Unit $ud not found. Unknown type for creation."
+ return -1
+ }
+ }
+
+ foreach UD [array names table] {
+ regexp {(.*)\.(.*)} $UD ignore name type
+ if { [lsearch [w_info -l $workbench] $name ] == -1 } {
+ ;# if workbench is writable ..
+ msgprint -c WOKVC -i "Creating unit ${workbench}:${name}"
+ ucreate -$type ${workbench}:${name}
+ }
+ set dirsrc [wokinfo -p source:. ${workbench}:${name}]
+ if ![file writable $dirsrc] {
+ msgprint -c WOKVC -e "You cannot write in directory $dirsrc"
+ return -1
+ }
+
+ set fromsrc [wokIntegre:BASE:GetVOBName [Sinfo -f] $shop $wb ${name}]
+ set table($UD) [list $fromsrc $dirsrc $table($UD)]
+ }
+
+ ;#parray table
+ ;# VOB ?? directory arrivee
+ ;#table(WOKTclLib.r) =
+ ;#/adv_23/WOK/k2dev/ref/src/WOKTclLib/. /adv_23/WOK/k2dev/iwok2/src/WOKTclLib/. upack.tcl
+
+ foreach UD [array names table] {
+ set from [lindex $table($UD) 0]
+ set dest [lindex $table($UD) 1]
+ foreach file [lindex $table($UD) 2] {
+ if [file exists $dest/$file] {
+ if { $forced } {
+ if { [file writable $dest/$file] } {
+ frename $dest/$file $dest/${file}-sav
+ msgprint -c WOKVC -i "File $dest/$file renamed ${file}-sav"
+ wokUtils:FILES:copy $from/$file $dest/$file
+ chmod 0644 $dest/$file
+ } else {
+ msgprint -c WOKVC -e "File $dest/$file is not writable. Cannot be overwritten."
+ return -1
+ }
+ } else {
+ msgprint -c WOKVC -e "File $dest/$file already exists. Not overwritten."
+ }
+ } else {
+ wokUtils:FILES:copy $from/$file $dest/$file
+ chmod 0644 $dest/$file
+ }
+ }
+ }
+ }
+
+ return
+}
+#############################################################################
+#
+# W P U T
+# _______
+#
+#############################################################################
+#
+# Usage
+#
+proc wokPutUsage { } {
+ return
+}
+
+proc wput { args } {
+ puts "No longer supported."
+ return
+}
return [convertclock "$day $dt($mth) $yea $hour"]
}
#
-# Convert a date 08-Jan-94.12:05:43 to seconds
-# clock scan "Sun Nov 24 12:30 1996"
+# Returs the list of files in dir newer than date
#
-proc wokUtils:TIME:clr { e } {
- if {[regsub {(..)\-(...)\-(..)\.(........)} $e {\1 \2 \3 \4} f] != 0 } {
- return [clock scan $f]
- }
-}
-#
-# Sort 2 dates in ClearCase format.
-#
-proc wokUtils:TIME:clrsort { e1 e2 } {
- if {[regsub {(..)\-(...)\-(..)\.(........)} $e1 {\1 \2 \3 \4} f1] != 0 } {
- if {[regsub {(..)\-(...)\-(..)\.(........)} $e2 {\1 \2 \3 \4} f2] != 0 } {
- if { [clock scan $f1] <= [clock scan $f2] } {
- return -1
- } else {
- return 1
- }
+proc wokUtils:FILES:Since { dir {date "00:00:00" }} {
+ set lim [clock scan $date]
+ set l {}
+ foreach file [ readdir $dir ] {
+ if { [file mtime $dir/$file] > $lim } {
+ lappend l $file
}
}
-}
-#
-# Returs the list of files in dirlist using gblist as pattern newer than lim
-#
-proc wokUtils:FILES:Since { dirlist gblist lim } {
- set result {}
- set recurse {}
- foreach dir $dirlist {
- foreach ptn $gblist {
- set ll {}
- foreach fle [glob -nocomplain -- $dir/$ptn] {
- if { [file mtime $fle] > $lim } {
- lappend ll $fle
- }
- }
- set result [concat $result $ll]
- }
- foreach file [readdir $dir] {
- set file $dir/$file
- if [file isdirectory $file] {
- set fileTail [file tail $file]
- if {!(($fileTail == ".") || ($fileTail == ".."))} {
- lappend recurse $file
- }
- }
- }
- }
- if ![lempty $recurse] {
- set result [concat $result [wokUtils:FILES:Since $recurse $gblist $lim]]
- }
- return $result
+ return $l
}
#
# returns a list:
}
return
}
-;#
-;# Put a list of strings in a map indexed by the n first field.
-;# if sep = "/" then strings may represent pathes.
-;# Hence if n = 1 => 2 first fields of the path are used for indexing.
-;# The value is (a list) of the remainder path.
-;# All the pathes in lpathes must contains at least n fields.
-;# Example: n=1 a/b/c => map(a/b) = c
-;# a/b/d => map(a/b) = {c d } and so on.
-;# if n = -1 then automatically search the longuest string index
-;#
-proc wokUtils:LIST:ListOfPathesToMap { lpath nf map {sep /} } {
- upvar $map TLOC
-
- if { $nf < 0 } {
- puts "???
- } else {
- set n $nf
- }
-
-
- set np [expr $n + 1]
-
- foreach p $lpath {
- set ll [split $p $sep]
- set k [join [lrange $ll 0 $n] $sep]
- if [info exists TLOC($k)] {
- set l $TLOC($k)
- lappend l [join [lrange $ll $np end] $sep]
- set TLOC($k) $l
- } else {
- set TLOC($k) [join [lrange $ll $np end] $sep]
- }
- }
-}
#
# Returns 1 if name does not begin with -
#
;#
;# Write in map all directories under d. Each index is a directory name ( trimmed by d).
;# Contents of index is the list of files in that directory
-;# "Error regsub --" peut arriver si d se termine par un slache
;#
proc wokUtils:FILES:DirToMap { d map {tail 0} } {
upvar $map TLOC
return
}
;#
-;# Returns a list of Tcl statements that should be
-;# used for checking existence of files in lpath.
-;# Invoked later on, procname will return elements in lpath
-;# that no longer exists.
-;#
-proc wokUtils:FILES:WasThere { lpath procname } {
- lappend l [format "proc $procname { } {"]
- lappend l [format "set l {}"]
- foreach f $lpath {
- set fmt [format "if { !\[file exists %s\] } {lappend l %s }" $f $f]
- lappend l $fmt
- }
- lappend l [format "return \$l\n}"]
-}
-;#
-;# Returns a list of Tcl statements that should be
-;# used for checking date of files in lpath.
-;# Invoked later on, procname will return elements in lpath
-;# that have been modified and their original date.
-;#
-proc wokUtils:FILES:Remember { lpath procname } {
- lappend l [format "proc $procname { } {"]
- lappend l [format "set l {}"]
- foreach f $lpath {
- set d [file mtime $f]
- set fmt \
-[format "if { \[file mtime %s\] != %s } {lappend l [list %s %s]}" $f $d $f $d]
- lappend l $fmt
- }
- lappend l [format "return \$l\n}"]
-}
-;#
-;# used to sort MAP created by wokUtils:FILES:DirToMap
-;# so that tree directory is traversed "en largeur daborrhe'
-;#
-proc wokUtils:FILES:Depth { d1 d2 } {
- set n1 [regsub -all / $d1 {} nil]
- set n2 [regsub -all / $d2 {} nil]
- if { $n1 > $n2 } {
- return 1
- } else {
- return -1
- }
-}
-;#
;# Same as above but write a Tcl proc to perform it. Proc has 1 argument. the name of the map.
;#
proc wokUtils:FILES:DirMapToProc { d TclFile ProcName } {
return -1
}
}
-#
-# Same as above but also returns a ordonned list of directories names
-# Use it as follow
-# set treelist [wokUtils:FILES:DirToTree $dir]
-# wokUtils:FILES:DirToH MAP root "" $treelist
-#
-proc wokUtils:FILES:DirToH { var node label info } {
- upvar #0 $var data
- set data($node-label) $label
- set data($node-children) ""
- set num 0
- foreach rec $info {
- set subnode "$node-[incr num]"
- lappend data($node-children) $subnode
- set sublabel [lindex $rec 0]
- set subinfo [lindex $rec 1]
- wokUtils:FILES:DirToH $var $subnode $sublabel $subinfo
- }
-}
+
#
# Concat all files in lsfiles. Writes the result in result
#
}
}
#
+# l1 U l2
#
+proc wokUtils:LIST:union { l1 l2 } {
+ set l {}
+ foreach e [concat $l1 $l2] {
+ if { [lsearch $l $e] == -1 } {
+ lappend l $e
+ }
+ }
+ return $l
+}
#
-proc wokUtils:FILES:AppendListToFile { liste path } {
- if [ catch { set id [ open $path a ] } ] {
- return 0
- } else {
- foreach e $liste {
- puts $id $e
+# l1 - l2
+#
+proc wokUtils:LIST:moins { l1 l2 } {
+ set l {}
+ foreach e $l1 {
+ if { [lsearch $l2 $e] == -1 } {
+ lappend l $e
}
- close $id
- return 1
- }
+ }
+ return $l
}
-
#
-# Compares 2 full pathes for TEXT ASCII files. Returs 1 if identicals 0 ifnot
+# Do something i cannot remenber,
+#
+proc wokUtils:LIST:subls { list } {
+ set l {}
+ set len [llength $list]
+ for {set i 0} {$i < $len} {incr i 1} {
+ lappend l [lrange $list 0 $i]
+ }
+ return $l
+}
#
-proc wokUtils:FILES:AreSame { f1 f2 } {
- set ls1 [file size $f1]
- set ls2 [file size $f2]
- if { $ls1 == $ls2 } {
- set id1 [open $f1 r]
- set id2 [open $f2 r]
- set s1 [read $id1 $ls1]
- set s2 [read $id2 $ls2]
- close $id1
- close $id2
- if { $s1 == $s2 } {
- return 1
- } else {
- return 0
- }
-
+# { 1 2 3 } => { 3 2 1 }
+#
+proc wokUtils:LIST:reverse { list } {
+ set ll [llength $list]
+ if { $ll == 0 } {
+ return
+ } elseif { $ll == 1 } {
+ return $list
} else {
- return 0
+ return [concat [wokUtils:LIST:reverse [lrange $list 1 end]] [list [lindex $list 0]]]
}
}
#
-# Copy file
+# flat a list: { a {b c} {{{{d}}}e } etc..
+# => { a b c d e }
#
-proc wokUtils:FILES:copy { fin fout } {
- if { [catch { set in [ open $fin r ] } errin] == 0 } {
- if { [catch { set out [ open $fout w ] } errout] == 0 } {
- set nb [copyfile $in $out]
- close $in
- close $out
- return $nb
- } else {
- puts stderr "Error: $errout"
- return -1
- }
- } else {
- puts stderr "Error: $errin"
- return -1
+proc wokUtils:LIST:flat { list } {
+ if { [llength $list] == 0 } {
+ return {}
+ } elseif { [llength [lindex $list 0]] == 1 } {
+ return [concat [lindex $list 0] [wokUtils:LIST:flat [lrange $list 1 end]]]
+ } elseif { [llength [lindex $list 0]] > 1 } {
+ return [concat [wokUtils:LIST:flat [lindex $list 0]] [wokUtils:LIST:flat [lrange $list 1 end]]]
}
}
#
-# Delete file. Tcl 7.5 or later.
+# returns 3 lists l1-l2 l1-inter-l2 l2-l1
#
-proc wokUtils:FILES:delete { f } {
- global tcl_version
- if [file exists $f] {
- if { "$tcl_version" == "7.5" } {
- unlink $f
- } else {
- file delete $f
- }
+proc wokUtils:LIST:i3 { l1 l2 } {
+ set a1(0) {} ; unset a1(0)
+ set a2(0) {} ; unset a2(0)
+ set a3(0) {} ; unset a3(0)
+ foreach v $l1 {
+ set a1($v) {}
+ }
+ foreach v $l2 {
+ 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]]
}
#
-# Returns a list of selected files
+# returns all elements of list matching of the expr in lexpr
+# Ex: GM [glob *] [list *.tcl *.cxx A*.c]
#
-proc wokUtils:FILES:ls { dir {select all} } {
+proc wokUtils:LIST:GM { list lexpr } {
set l {}
- if { [file exists $dir] } {
- foreach f [readdir $dir] {
- set e [file extension $f]
- switch -- $select {
- all {
- if {![regexp {[^~]~$} $f] && ![string match *.*-sav* $e]} {
- lappend l $f
- }
- }
-
- cdl {
- if { [string compare $e .cdl] == 0 } {
- lappend l $f
- }
- }
-
- cxx {
- if { [string compare $e .cxx] == 0 } {
- lappend l $f
- }
- }
-
- others {
- if { [string compare $e .cdl] !=0 && [string compare $e .cxx] != 0 } {
- lappend l $f
- }
+ foreach expr $lexpr {
+ foreach e $list {
+ if [string match $expr $e] {
+ if { [lsearch $l $e] == -1 } {
+ lappend l $e
}
-
}
}
}
- return [lsort $l]
+ return $l
}
-;#
-;#
-;#
-proc wokUtils:FILES:FindFile { startDir namePat } {
- set pwd [pwd]
- if [catch {cd $startDir} err] {
- puts stderr $err
- return
- }
- foreach match [glob -nocomplain -- $namePat] {
- puts stdout [file join $startDir $match]
- }
- foreach file [glob -nocomplain *] {
- if [file isdirectory $file] {
- wokUtils:FILES:FindFile [file join $startDir $file] $namePat
+#
+# returns the longer prefix that begin with str in inlist ( Completion purpose.)
+#
+proc wokUtils:LIST:POF { str inlist } {
+ set list {}
+ foreach e $inlist {
+ if {[string match $str* $e]} {
+ lappend list $e
}
}
- cd $pwd
-}
-;#
-;# Copy src in dest and translate to native format
-;# src qnd dest can be directory.
-;# at least Tcl 7.6 (file mkdir ..) if not uses Tclx
-;# Basic use wokUtils:FILES:NatCopy pth1 pth2
-;#
-proc wokUtils:FILES:NatCopy { src dest {verbose 0} {YesOrNo wokUtils:EASY:NatCopy} } {
- global tcl_version
- if [file isdirectory $src] {
- if { "$tcl_version" == "7.6" } {
- file mkdir $dest
- } else {
- mkdir -path $dest
+ if { $list == {} } {
+ return [list {} {}]
+ }
+ set l [expr [string length $str] -1]
+ set miss 0
+ set e1 [lindex $list 0]
+ while {!$miss} {
+ incr l
+ if {$l == [string length $e1]} {
+ break
}
- foreach f [glob -nocomplain [file join $src *]] {
- wokUtils:FILES:NatCopy $f [file join $dest [file tail $f]] $verbose $YesOrNo
+ set new [string range $e1 0 $l]
+ foreach f $list {
+ if ![string match $new* $f] {
+ set miss 1
+ incr l -1
+ break
+ }
}
- return
- }
-
- if [file isdirectory $dest] {
- set dest [file join $dest [file tail $src]]
}
-
- if [$YesOrNo $src] {
- if { $verbose } { puts stderr "Converting $src" }
- set in [open $src]
- set ws [read $in]
- close $in
- set out [open $dest w]
- puts -nonewline $out $ws
- close $out
+ set match [string range $e1 0 $l]
+ set newlist {}
+ foreach e $list {
+ if {[string match $match* $e]} {
+ lappend newlist $e
+ }
}
+ return [list $match $newlist]
}
#
-# Compress /decompress fullpath
-#
-proc wokUtils:FILES:compress { fullpath } {
- if [catch {exec compress -f $fullpath} status] {
- puts stderr "Error while compressing ${fullpath}: $status"
- return -1
- } else {
- return 1
- }
-}
-proc wokUtils:FILES:uncompress { fullpath } {
- if [catch {exec uncompress -f $fullpath} status] {
- puts stderr "Error while uncompressing ${fullpath}: $status"
- return -1
- } else {
- return 1
- }
-}
-
-#
-# Uncompresse if applicable Zin in dirout, returns the full path of uncompressed file
-# ( if Zin is not compresses returns Zin)
-# returns -1 if an error occured
+# pos = 1 {{a b c } x} => { {x a} {x b} {x c} } default
+# pos = 2 {{a b c } x} => { {a x} {a x} {a x} }
#
-proc wokUtils:FILES:SansZ { Zin } {
- if { [file exists $Zin] } {
- if {[string compare [file extension $Zin] .Z] == 0 } {
- set dirout [wokUtils:FILES:tmpname {}]
- set bnaz [file tail $Zin]
- if { [string compare $Zin $dirout/$bnaz] != 0 } {
- wokUtils:FILES:copy $Zin $dirout/$bnaz
- }
- if { [wokUtils:FILES:uncompress $dirout/$bnaz] != -1 } {
- return $dirout/[file root $bnaz]
- } else {
- return -1
- }
- } else {
- return $Zin
+proc wokUtils:LIST:pair { l e {pos 1}} {
+ set r {}
+ if { $pos == 1 } {
+ foreach x $l {
+ lappend r [list $e $x ]
}
} else {
- puts stderr "Error: $Zin does not exists."
- return -1
+ foreach x $l {
+ lappend r [list $x $e ]
+ }
}
+
+ return $r
}
#
-# uuencode
+# { {x a} {x b} {x c} } => {a b c}
#
-proc wokUtils:FILES:uuencode { fullpathin fullpathout {codename noname}} {
- if {[string compare $codename noname] == 0} {
- set codename [file tail $fullpathin]
- }
- if [catch {exec uuencode $fullpathin $codename > $fullpathout } status] {
- puts stderr "Error while encoding ${fullpathin}: $status"
- return -1
- } else {
- return 1
+proc wokUtils:LIST:unpair { ll } {
+ set r {}
+ foreach x $ll {
+ lappend r [lindex $x 1]
}
+ return $r
}
#
-# uudecode
+# keep in list of form ll = { {x a} {x b} {x c} } all elements which "cdr lisp" is in l
#
-proc wokUtils:FILES:uudecode { fullpathin {dirout noname}} {
- if {[string compare $dirout noname] == 0} {
- set dirout [file dirname $fullpathin]
- }
- set savpwd [pwd]
- cd $dirout
- if [catch {exec uudecode $fullpathin} status] {
- set ret -1
- } else {
- set ret 1
+proc wokUtils:LIST:selectpair { ll l } {
+ set rr {}
+ foreach x $ll {
+
+ if { [lsearch $l [lindex $x 1]] != -1 } {
+ lappend rr $x
+ }
}
- cd $savpwd
- return $ret
+ return $rr
}
#
-# Returns something != -1 if file must be uuencoded
+# sort a list of pairs
#
-proc wokUtils:FILES:Encodable { file } {
- return [lsearch {.xwd .rgb .o .exe .a .so .out .Z .tar} [file extension $file]]
-}
-#
-# remove a directory. One level. Very ugly procedure. Do not use.
-# Bricolage pour que ca marche sur NT.
-#
-proc wokUtils:FILES:removedir { d } {
- global env
- global tcl_platform
- if { "$tcl_platform(platform)" == "unix" } {
- if { [file exists $d] } {
- foreach f [readdir $d] {
- unlink -nocomplain $d/$f
- }
- rmdir -nocomplain $d
+proc wokUtils:LIST:Sort2 { ll } {
+ catch { unset tw }
+ foreach x $ll {
+ set e [lindex $x 0]
+ if [info exists tw($e)] {
+ set lw $tw($e)
+ lappend lw [lindex $x 1]
+ set tw($e) $lw
+ } else {
+ set tw($e) [lindex $x 1]
}
- } elseif { "$tcl_platform(platform)" == "windows" } {
- if { [file exists $d] } {
- foreach f [readdir $d] {
- file delete $d/$f
- }
- file delete $d
-
+ }
+ set l {}
+ foreach x [lsort [array names tw]] {
+ foreach y [lsort $tw($x)] {
+ lappend l [list $x $y]
}
}
- return
+ return $l
}
#
-# returns a string used for temporary directory name
+# Purge a list. Dont modify order
#
-proc wokUtils:FILES:tmpname { name } {
- global env
- global tcl_platform
- if { "$tcl_platform(platform)" == "unix" } {
- return [file join /tmp $name]
- } elseif { "$tcl_platform(platform)" == "windows" } {
- return [file join $env(TMP) $name]
- }
- return {}
+proc wokUtils:LIST:Purge { l } {
+ set r {}
+ foreach e $l {
+ if ![info exist tab($e)] {
+ lappend r $e
+ set tab($e) {}
+ }
+ }
+ return $r
}
#
-# userid.
+# trim a list
#
-proc wokUtils:FILES:Userid { file } {
- global env
- global tcl_platform
- if { "$tcl_platform(platform)" == "unix" } {
- file stat $file myT
- if ![ catch { id convert userid $myT(uid) } result ] {
- return $result
- } else {
- return unknown
+proc wokUtils:LIST:Trim { l } {
+ set r {}
+ foreach e $l {
+ if { $e != {} } {
+ set r [ concat $r $e]
}
- } elseif { "$tcl_platform(platform)" == "windows" } {
- return unknown
}
+ return $r
}
#
-# Try to supply a nice diff utility name
-#
-proc wokUtils:FILES:MoreDiff { } {
- global tcl_platform
- if { "$tcl_platform(platform)" == "unix" } {
- if [wokUtils:EASY:INPATH xdiff] {
- return xdiff
+# truncates all strings in liststr which length exceed nb char
+#
+proc wokUtils:LIST:cut { liststr {nb 10} } {
+ set l {}
+ foreach str $liststr {
+ set len [string length $str]
+ if { $len <= [expr $nb + 2 ]} {
+ lappend l $str
} else {
- return {}
+ lappend l [string range $str 0 $nb]..
}
- } elseif { "$tcl_platform(platform)" == "windows" } {
- return windiff
- } else {
- return {}
}
+ return $l
}
#
-# dirtmp one level
+# compares 2 lists of fulls pathes (master and revision) and fill table with the following format
+# table(simple.nam) {flag path1 path2}
+# flag = + => simple.nam in master but not in revision
+# flag = ? => simple.nam in master and in revision (files should be further compared)
+# flag = - => simple.nam in revision but not in master
#
-proc wokUtils:FILES:dirtmp { tmpnam } {
- if [file exist $tmpnam] {
- wokUtils:FILES:removedir $tmpnam
- }
- mkdir $tmpnam
- return
-}
-;#
-;# Recursive copy of dir in dest .
-;# Date of files in dest are modified since they are newly created.
-;# FunCopy is the function called to perform the copy.
-;# It receives 2 arguments :
-;# 1. Full path of the source file.
-;# 2. Full path of the destination file.
-;#
-proc wokUtils:FILES:recopy { dir dest {verbose 0} {FunCopy wokUtils:FILES:copy} } {
- wokUtils:FILES:DirToMap $dir MAP
- foreach odir [lsort -command wokUtils:FILES:Depth [array names MAP]] {
- regsub {^/} $odir {} sd
- set did [file join $dest $sd]
- if { ![file exists $did] } {
- if { $verbose } { puts stderr "Creating directory $did" }
- mkdir -path $did
- } else {
- if { $verbose } { puts stderr "Directory $did already exists. " }
- }
- foreach f $MAP($odir) {
- if { $verbose } { puts stderr "Creating file [file join $did [file tail $f]]" }
- $FunCopy $f [file join $did [file tail $f]]
+proc wokUtils:LIST:SimpleDiff { table master revision {gblist {}} } {
+ upvar $table TLOC
+ catch {unset TLOC}
+ foreach e $master {
+ set key [file tail $e]
+ if { $gblist == {} } {
+ set TLOC($key) [list - [file dirname $e]]
+ } elseif { [lsearch $gblist [file extension $key]] != -1 } {
+ set TLOC($key) [list - [file dirname $e]]
}
}
- return
-}
-;#
-;#
-;#
-proc wokUtils:FILES:html { file } {
- global tcl_platform
- if { "$tcl_platform(platform)" == "unix" } {
- set cmd "exec netscape -remote \"openFile($file)\""
- if { [catch $cmd] != 0 } {
- exec netscape &
- while { [catch $cmd] != 0 } {
- after 500
+ foreach e $revision {
+ set key [file tail $e]
+ set dir [file dirname $e]
+ if { $gblist == {} } {
+ if { [expr { ( [lsearch -exact [array names TLOC] $key] == -1 ) ? 0 : 1 }] } {
+ set TLOC($key) [list ? [lindex $TLOC($key) 1] $dir]
+ } else {
+ set TLOC($key) [list + $dir]
}
- }
- } elseif { "$tcl_platform(platform)" == "windows" } {
- set cmd [list exec netscape $file &]
- if { [catch $cmd] != 0 } {
- set prog [tk_getOpenFile -title "Where is Netscape ?"]
- if { $prog != "" } {
- puts $prog
- exec $prog $file &
+ } elseif { [lsearch $gblist [file extension $key]] != -1 } {
+ if { [expr { ( [lsearch -exact [array names TLOC] $key] == -1 ) ? 0 : 1 }] } {
+ set TLOC($key) [list ? [lindex $TLOC($key) 1] $dir]
+ } else {
+ set TLOC($key) [list + $dir]
}
}
}
- return
-}
-#
-# l1 U l2
-#
-proc wokUtils:LIST:union { l1 l2 } {
- set l {}
- foreach e [concat $l1 $l2] {
- if { [lsearch $l $e] == -1 } {
- lappend l $e
- }
- }
- return $l
+ return
}
#
-# l1 - l2
+# modify table ( created by wokUtils:LIST:SimpleDiff) as follows:
+# substitues flag ? by = if function(path1,path2) returns 1 , by # if not
+# all indexes in tbale are processed.
#
-proc wokUtils:LIST:moins { l1 l2 } {
- set l {}
- foreach e $l1 {
- if { [lsearch $l2 $e] == -1 } {
- lappend l $e
+proc wokUtils:LIST:CompareAllKey { table function } {
+ upvar $table TLOC
+ foreach e [array names TLOC] {
+ set flag [lindex $TLOC($e) 0]
+ set f1 [lindex $TLOC($e) 1]/$e
+ set f2 [lindex $TLOC($e) 2]/$e
+ if { [string compare $flag ?] == 0 } {
+ if { [$function $f1 $f2] == 1 } {
+ set TLOC($e) [list = $f1 $f2]
+ } else {
+ set TLOC($e) [list # $f1 $f2]
+ }
}
}
- return $l
}
#
-# Do something i cannot remenber,
-#
-proc wokUtils:LIST:subls { list } {
- set l {}
- set len [llength $list]
- for {set i 0} {$i < $len} {incr i 1} {
- lappend l [lrange $list 0 $i]
+# Same as above but only indexex in keylist are processed.
+# This proc to avoid testing each key in the above procedure
+#
+proc wokUtils:LIST:CompareTheseKey { table function keylist } {
+ upvar $table TLOC
+ foreach e [array names TLOC] {
+ if { [expr { ([lsearch -exact $keylist $e] != -1) ? 1 : 0}] } {
+ set flag [lindex $TLOC($e) 0]
+ set f1 [lindex $TLOC($e) 1]/$e
+ set f2 [lindex $TLOC($e) 2]/$e
+ if { [string compare $flag ?] == 0 } {
+ if { [$function $f1 $f2] == 1 } {
+ set TLOC($e) [list = $f1 $f2]
+ } else {
+ set TLOC($e) [list # $f1 $f2]
+ }
+ }
+ } else {
+ unset TLOC($e)
+ }
}
- return $l
+ return
}
#
-# { 1 2 3 } => { 3 2 1 }
+# same as array set, i guess
#
-proc wokUtils:LIST:reverse { list } {
- set ll [llength $list]
- if { $ll == 0 } {
- return
- } elseif { $ll == 1 } {
- return $list
- } else {
- return [concat [wokUtils:LIST:reverse [lrange $list 1 end]] [list [lindex $list 0]]]
+proc wokUtils:LIST:ListToMap { name list2 } {
+ upvar $name TLOC
+ foreach f $list2 {
+ set TLOC([lindex $f 0]) [lindex $f 1]
}
+ return
}
#
-# flat a list: { a {b c} {{{{d}}}e } etc..
-# => { a b c d e }
+# reverse
#
-proc wokUtils:LIST:flat { list } {
- if { [llength $list] == 0 } {
- return {}
- } elseif { [llength [lindex $list 0]] == 1 } {
- return [concat [lindex $list 0] [wokUtils:LIST:flat [lrange $list 1 end]]]
- } elseif { [llength [lindex $list 0]] > 1 } {
- return [concat [wokUtils:LIST:flat [lindex $list 0]] [wokUtils:LIST:flat [lrange $list 1 end]]]
+proc wokUtils:LIST:MapToList { name {reg *}} {
+ upvar $name TLOC
+ set l {}
+ foreach f [array names TLOC $reg] {
+ lappend l [list $f $TLOC($f)]
}
+ return $l
}
#
-# returns 3 lists l1-l2 l1-inter-l2 l2-l1
+# Same as wokUtils:LIST:ListToMap. For spurious reason
#
-proc wokUtils:LIST:i3 { l1 l2 } {
- set a1(0) {} ; unset a1(0)
- set a2(0) {} ; unset a2(0)
- set a3(0) {} ; unset a3(0)
- foreach v $l1 {
- set a1($v) {}
- }
- foreach v $l2 {
- if [info exists a1($v)] {
- set a2($v) {} ; unset a1($v)
- } {
- set a3($v) {}
- }
+proc wokUtils:LIST:MapList { name list2 } {
+ upvar $name TLOC
+ foreach f $list2 {
+ set TLOC([lindex $f 0]) [lindex $f 1]
}
- list [lsort [array names a1]] [lsort [array names a2]] [lsort [array names a3]]
+ return
}
+
+#
+# Applique le test Func sur l'element index de list
#
-# returns all elements of list matching of the expr in lexpr
-# Ex: GM [glob *] [list *.tcl *.cxx A*.c]
-#
-proc wokUtils:LIST:GM { list lexpr } {
+proc wokUtils:LIST:Filter { list Func {index 0} } {
set l {}
- foreach expr $lexpr {
- foreach e $list {
- if [string match $expr $e] {
- if { [lsearch $l $e] == -1 } {
- lappend l $e
- }
- }
+ foreach e $list {
+ if { [$Func [lindex $e $index]] } {
+ lappend l $e
}
}
return $l
}
#
-# returns the longer prefix that begin with str in inlist ( Completion purpose.)
+# Compares 2 full pathes for TEXT ASCII files. Returs 1 if identicals 0 ifnot
#
-proc wokUtils:LIST:POF { str inlist } {
- set list {}
- foreach e $inlist {
- if {[string match $str* $e]} {
- lappend list $e
- }
- }
- if { $list == {} } {
- return [list {} {}]
- }
- set l [expr [string length $str] -1]
- set miss 0
- set e1 [lindex $list 0]
- while {!$miss} {
- incr l
- if {$l == [string length $e1]} {
- break
- }
- set new [string range $e1 0 $l]
- foreach f $list {
- if ![string match $new* $f] {
- set miss 1
- incr l -1
- break
- }
- }
- }
- set match [string range $e1 0 $l]
- set newlist {}
- foreach e $list {
- if {[string match $match* $e]} {
- lappend newlist $e
+proc wokUtils:FILES:AreSame { f1 f2 } {
+ set ls1 [file size $f1]
+ set ls2 [file size $f2]
+ if { $ls1 == $ls2 } {
+ set id1 [open $f1 r]
+ set id2 [open $f2 r]
+ set s1 [read $id1 $ls1]
+ set s2 [read $id2 $ls2]
+ close $id1
+ close $id2
+ if { $s1 == $s2 } {
+ return 1
+ } else {
+ return 0
}
+
+ } else {
+ return 0
}
- return [list $match $newlist]
}
#
-# Split l in to p list of max n elements.
-# then llength(l) = p*n + r
+# Renvoie 1 si wb est une racine 0 sinon
#
-proc wokUtils:LIST:split { l n } {
- set i 0
- foreach e $l {
- incr i
- if { $i <= $n } {
- lappend bf $e
- } else {
- set i 1
- if [info exists bf] {
- lappend res $bf
- set bf $e
- }
- }
- }
- lappend res $bf
- return $res
+proc wokUtils:WB:IsRoot { wb } {
+ return [expr { ( [llength [w_info -A $wb]] > 1 ) ? 0 : 1 }]
}
#
-# pos = 1 {{a b c } x} => { {x a} {x b} {x c} } default
-# pos = 2 {{a b c } x} => { {a x} {a x} {a x} }
+# Copy file
#
-proc wokUtils:LIST:pair { l e {pos 1}} {
- set r {}
- if { $pos == 1 } {
- foreach x $l {
- lappend r [list $e $x ]
+proc wokUtils:FILES:copy { fin fout } {
+ if { [catch { set in [ open $fin r ] } errin] == 0 } {
+ if { [catch { set out [ open $fout w ] } errout] == 0 } {
+ set nb [copyfile $in $out]
+ close $in
+ close $out
+ return $nb
+ } else {
+ puts stderr "Error: $errout"
+ return -1
}
} else {
- foreach x $l {
- lappend r [list $x $e ]
- }
- }
-
- return $r
-}
-#
-# { {x a} {x b} {x c} } => {a b c}
-#
-proc wokUtils:LIST:unpair { ll } {
- set r {}
- foreach x $ll {
- lappend r [lindex $x 1]
+ puts stderr "Error: $errin"
+ return -1
}
- return $r
}
#
-# keep in list of form ll = { {x a} {x b} {x c} } all elements which "cdr lisp" is in l
+# Returns a list of selected files
#
-proc wokUtils:LIST:selectpair { ll l } {
- set rr {}
- foreach x $ll {
-
- if { [lsearch $l [lindex $x 1]] != -1 } {
- lappend rr $x
+proc wokUtils:FILES:ls { dir {select all} } {
+ set l {}
+ if { [file exists $dir] } {
+ foreach f [readdir $dir] {
+ set e [file extension $f]
+ switch -- $select {
+ all {
+ if {![regexp {[^~]~$} $f] && ![string match *.*-sav* $e]} {
+ lappend l $f
+ }
+ }
+
+ cdl {
+ if { [string compare $e .cdl] == 0 } {
+ lappend l $f
+ }
+ }
+
+ cxx {
+ if { [string compare $e .cxx] == 0 } {
+ lappend l $f
+ }
+ }
+
+ others {
+ if { [string compare $e .cdl] !=0 && [string compare $e .cxx] != 0 } {
+ lappend l $f
+ }
+ }
+
+ }
}
}
- return $rr
+ return [lsort $l]
}
#
-# sort elements of l, according to key
-# key is the field number of an element considered as a string
-# command is invoked and receive the 2 fields.
+# Compress /decompress fullpath
#
-proc wokUtils:LIST:sort { l key {sep " "} {mode -ascii} {order -increasing}} {
- foreach e $l {
- puts $e
- set x [split $e $sep]
- puts "x = $x"
- set map([lindex $x $key]) $e
+proc wokUtils:FILES:compress { fullpath } {
+ if [catch {exec compress -f $fullpath} status] {
+ puts stderr "Error while compressing ${fullpath}: $status"
+ return -1
+ } else {
+ return 1
}
- parray map
- set le_tour_est_joue {}
- foreach e [lsort $mode $order [array names map]] {
- lappend le_tour_est_joue $map($e)
+}
+proc wokUtils:FILES:uncompress { fullpath } {
+ if [catch {exec uncompress -f $fullpath} status] {
+ puts stderr "Error while uncompressing ${fullpath}: $status"
+ return -1
+ } else {
+ return 1
}
- return $le_tour_est_joue
}
+
#
-# sort a list of pairs
+# Uncompresse if applicable Zin in dirout, returns the full path of uncompressed file
+# ( if Zin is not compresses returns Zin)
+# returns -1 if an error occured
#
-proc wokUtils:LIST:Sort2 { ll } {
- catch { unset tw }
- foreach x $ll {
- set e [lindex $x 0]
- if [info exists tw($e)] {
- set lw $tw($e)
- lappend lw [lindex $x 1]
- set tw($e) $lw
+proc wokUtils:FILES:SansZ { Zin } {
+ if { [file exists $Zin] } {
+ if {[string compare [file extension $Zin] .Z] == 0 } {
+ set dirout [wokUtils:FILES:tmpname {}]
+ set bnaz [file tail $Zin]
+ if { [string compare $Zin $dirout/$bnaz] != 0 } {
+ wokUtils:FILES:copy $Zin $dirout/$bnaz
+ }
+ if { [wokUtils:FILES:uncompress $dirout/$bnaz] != -1 } {
+ return $dirout/[file root $bnaz]
+ } else {
+ return -1
+ }
} else {
- set tw($e) [lindex $x 1]
- }
- }
- set l {}
- foreach x [lsort [array names tw]] {
- foreach y [lsort $tw($x)] {
- lappend l [list $x $y]
+ return $Zin
}
+ } else {
+ puts stderr "Error: $Zin does not exists."
+ return -1
}
- return $l
}
#
-# Purge a list. Dont modify order
+# uuencode
#
-proc wokUtils:LIST:Purge { l } {
- set r {}
- foreach e $l {
- if ![info exist tab($e)] {
- lappend r $e
- set tab($e) {}
- }
- }
- return $r
+proc wokUtils:FILES:uuencode { fullpathin fullpathout {codename noname}} {
+ if {[string compare $codename noname] == 0} {
+ set codename [file tail $fullpathin]
+ }
+ if [catch {exec uuencode $fullpathin $codename > $fullpathout } status] {
+ puts stderr "Error while encoding ${fullpathin}: $status"
+ return -1
+ } else {
+ return 1
+ }
}
#
-# Purge and sort a list.
+# uudecode
#
-proc wokUtils:LIST:SortPurge { l } {
- foreach e $l {
- set tab($e) {}
- }
- return [lsort [array names tab]]
+proc wokUtils:FILES:uudecode { fullpathin {dirout noname}} {
+ if {[string compare $dirout noname] == 0} {
+ set dirout [file dirname $fullpathin]
+ }
+ set savpwd [pwd]
+ cd $dirout
+ if [catch {exec uudecode $fullpathin} status] {
+ set ret -1
+ } else {
+ set ret 1
+ }
+ cd $savpwd
+ return $ret
}
#
+# Returns something != -1 if file must be uuencoded
#
-# trim a list
-#
-proc wokUtils:LIST:Trim { l } {
- set r {}
- foreach e $l {
- if { $e != {} } {
- set r [ concat $r $e]
- }
- }
- return $r
+proc wokUtils:FILES:Encodable { file } {
+ return [lsearch {.xwd .rgb .o .exe .a .so .out .Z .tar} [file extension $file]]
}
-#
-# truncates all strings in liststr which length exceed nb char
#
-proc wokUtils:LIST:cut { liststr {nb 10} } {
- set l {}
- foreach str $liststr {
- set len [string length $str]
- if { $len <= [expr $nb + 2 ]} {
- lappend l $str
- } else {
- lappend l [string range $str 0 $nb]..
+# remove a directory. One level. Very ugly procedure. Do not use.
+# Bricolage pour que ca marche sur NT.
+#
+proc wokUtils:FILES:removedir { d } {
+ global env
+ global tcl_platform
+ if { "$tcl_platform(platform)" == "unix" } {
+ if { [file exists $d] } {
+ foreach f [readdir $d] {
+ unlink -nocomplain $d/$f
+ }
+ rmdir -nocomplain $d
+ }
+ } elseif { "$tcl_platform(platform)" == "windows" } {
+ if { [file exists $d] } {
+ foreach f [readdir $d] {
+ file delete $d/$f
+ }
+ file delete $d
+
}
}
- return $l
+ return
}
#
-# compares 2 lists of fulls pathes (master and revision) and fill table with the following format
-# table(simple.nam) {flag path1 path2}
-# flag = + => simple.nam in master but not in revision
-# flag = ? => simple.nam in master and in revision (files should be further compared)
-# flag = - => simple.nam in revision but not in master
+# returns a string used for temporary directory name
#
-proc wokUtils:LIST:SimpleDiff { table master revision {gblist {}} } {
- upvar $table TLOC
- catch {unset TLOC}
- foreach e $master {
- set key [file tail $e]
- if { $gblist == {} } {
- set TLOC($key) [list - [file dirname $e]]
- } elseif { [lsearch $gblist [file extension $key]] != -1 } {
- set TLOC($key) [list - [file dirname $e]]
- }
- }
- foreach e $revision {
- set key [file tail $e]
- set dir [file dirname $e]
- if { $gblist == {} } {
- if { [expr { ( [lsearch -exact [array names TLOC] $key] == -1 ) ? 0 : 1 }] } {
- set TLOC($key) [list ? [lindex $TLOC($key) 1] $dir]
- } else {
- set TLOC($key) [list + $dir]
- }
- } elseif { [lsearch $gblist [file extension $key]] != -1 } {
- if { [expr { ( [lsearch -exact [array names TLOC] $key] == -1 ) ? 0 : 1 }] } {
- set TLOC($key) [list ? [lindex $TLOC($key) 1] $dir]
- } else {
- set TLOC($key) [list + $dir]
- }
- }
+proc wokUtils:FILES:tmpname { name } {
+ global env
+ global tcl_platform
+ if { "$tcl_platform(platform)" == "unix" } {
+ return [file join /tmp $name]
+ } elseif { "$tcl_platform(platform)" == "windows" } {
+ return [file join $env(TMP) $name]
}
- return
+ return {}
}
#
-# modify table ( created by wokUtils:LIST:SimpleDiff) as follows:
-# substitues flag ? by = if function(path1,path2) returns 1 , by # if not
-# all indexes in tbale are processed.
+# userid.
#
-proc wokUtils:LIST:CompareAllKey { table function } {
- upvar $table TLOC
- foreach e [array names TLOC] {
- set flag [lindex $TLOC($e) 0]
- set f1 [lindex $TLOC($e) 1]/$e
- set f2 [lindex $TLOC($e) 2]/$e
- if { [string compare $flag ?] == 0 } {
- if { [$function $f1 $f2] == 1 } {
- set TLOC($e) [list = $f1 $f2]
- } else {
- set TLOC($e) [list # $f1 $f2]
- }
+proc wokUtils:FILES:Userid { file } {
+ global env
+ global tcl_platform
+ if { "$tcl_platform(platform)" == "unix" } {
+ file stat $file myT
+ if ![ catch { id convert userid $myT(uid) } result ] {
+ return $result
+ } else {
+ return unknown
}
+ } elseif { "$tcl_platform(platform)" == "windows" } {
+ return unknown
}
}
#
-# Same as above but only indexex in keylist are processed.
-# This proc to avoid testing each key in the above procedure
-#
-proc wokUtils:LIST:CompareTheseKey { table function keylist } {
- upvar $table TLOC
- foreach e [array names TLOC] {
- if { [expr { ([lsearch -exact $keylist $e] != -1) ? 1 : 0}] } {
- set flag [lindex $TLOC($e) 0]
- set f1 [lindex $TLOC($e) 1]/$e
- set f2 [lindex $TLOC($e) 2]/$e
- if { [string compare $flag ?] == 0 } {
- if { [$function $f1 $f2] == 1 } {
- set TLOC($e) [list = $f1 $f2]
- } else {
- set TLOC($e) [list # $f1 $f2]
- }
- }
+# Try to supply a nice diff utility name
+#
+proc wokUtils:FILES:MoreDiff { } {
+ global tcl_platform
+ if { "$tcl_platform(platform)" == "unix" } {
+ if [wokUtils:EASY:INPATH xdiff] {
+ return xdiff
} else {
- unset TLOC($e)
+ return {}
}
+ } elseif { "$tcl_platform(platform)" == "windows" } {
+ return windiff
+ } else {
+ return {}
}
- return
}
#
-# same as array set, i guess
+# dirtmp one level
#
-proc wokUtils:LIST:ListToMap { name list2 } {
- upvar $name TLOC
- foreach f $list2 {
- set TLOC([lindex $f 0]) [lindex $f 1]
+proc wokUtils:FILES:dirtmp { tmpnam } {
+ if [file exist $tmpnam] {
+ wokUtils:FILES:removedir $tmpnam
}
- return
-}
+ mkdir $tmpnam
+ return
+}
#
-# reverse
+# Doc
#
-proc wokUtils:LIST:MapToList { name {reg *}} {
- upvar $name TLOC
+proc wokH { reg } {
+ global auto_index
+ set maxl 0
set l {}
- foreach f [array names TLOC $reg] {
- lappend l [list $f $TLOC($f)]
+ foreach name [lsort [array names auto_index $reg]] {
+ lappend l $name
+ if {[string length $name] > $maxl} {
+ set maxl [string length $name]
+ }
}
- return $l
-}
-#
-# Same as wokUtils:LIST:ListToMap. For spurious reason
-#
-proc wokUtils:LIST:MapList { name list2 } {
- upvar $name TLOC
- foreach f $list2 {
- set TLOC([lindex $f 0]) [lindex $f 1]
+ foreach name [lsort $l] {
+ puts stdout [format "%-*s = %s" $maxl $name [lindex $auto_index($name) 1]]
}
return
}
-
-#
-# Applique le test Func sur l'element index de list
#
-proc wokUtils:LIST:Filter { list Func {index 0} } {
- set l {}
- foreach e $list {
- if { [$Func [lindex $e $index]] } {
- lappend l $e
- }
+# Easy 1. Stupid. Dont use
+#
+proc wokUtils:EASY:Apply { f l } {
+ if { $l != {} } {
+ $f [lindex $l 0]
+ wokUtils:EASY:Apply $f [lrange $l 1 end]
+ return
}
- return $l
}
-
#
-# not Very,very,very,very,very useful
+# Very,very,very,very,very useful
#
proc wokUtils:EASY:GETOPT { prm table tablereq usage listarg } {
return
}
;#
-;# Answer Yes or No to convert file ( full path /ordinary file )
-;# Here is a quite bestial/brutal version to convert automatically about 70 percent of text files
;#
-proc wokUtils:EASY:NatCopy { file } {
- set glob_style_patterns {*.cxx *.C *.h *.c *.f *.ll *.cdl *.edl *.tcl *.ld *.idl *.ccl}
- set bf [file tail $file]
- foreach ptn $glob_style_patterns {
- if [string match $ptn $bf] {
- return 1
- }
- }
- return 0
-}
-# fait la substitution de / par \\ sur NT
-# sur Unix ne fait rien
-#
-proc wokUtils:EASY:stobs2 { l } {
- global tcl_platform
- switch -- $tcl_platform(platform) {
- unix {
- return $l
- }
- windows {
- return [wokUtils:EASY:lbs2 $l]
+;#
+proc wokUtils:EASY:Check_auto_path { auto_path } {
+ foreach d [wokUtils:LIST:Purge $auto_path] {
+ if [file exists $d/tclIndex] {
+ puts "tclIndex in $d"
+ } elseif [file exists $d/pkgIndex.tcl] {
+ puts "pkgIndex.tcl in $d"
+ } else {
+ puts "ERROR: $d"
}
}
+ return
}
-#
-proc wokUtils:EASY:lbs1 { ls } {
- set lr {}
- foreach s $ls {
- regsub -all {/} $s {\\} r
- lappend lr $r
- }
- return $lr
-}
-#
-proc wokUtils:EASY:lbs2 { ls } {
- set lr {}
- foreach s $ls {
- regsub -all {/} $s {\\\\} r
- lappend lr $r
- }
- return $lr
-}
+
#
# string trim does not work. Do it
#
}
}
#
+# Exec command. VERBOSE = 1 et WATCHONLY 1 => display but dont execute
+#
+proc wokUtils:EASY:command { command {VERBOSE 0} {WATCHONLY 0} } {
+ if { $VERBOSE } {
+ puts stderr "Exec: $command"
+ }
+ if { $WATCHONLY } {
+ return [list 1 1]
+ }
+ if [catch {eval exec $command} status] {
+ puts stderr "Error in command: $command"
+ puts stderr "Status : $status"
+ return [list -1 $status]
+ } else {
+ return [list 1 $status]
+ }
+}
+#
# tar
# Examples:
#
return $statutar
}
-#
-# Send a mail on unix platform.
-#
-proc wokUtils:EASY:mail { to from cc subject text {option send} } {
- global tcl_platform
- if { "$tcl_platform(platform)" == "unix" } {
- switch -- $option {
- send {
- set cmd {wokUtils:EASY:mail $to $from $cc $subject $text command}
- if {[catch $cmd result] != 0} {
- puts $result
- return {}
- } else {
- return 1
- }
- }
-
- command {
- set fid [open "| /usr/lib/sendmail -oi -t" "w"]
- puts $fid "To: $to"
- if {[string length $from] > 0} {
- puts $fid "From: $from"
- }
- if {[string length $cc] > 0} {
- puts $fid "Cc: $cc"
- }
- puts $fid "Subject: $subject"
- puts $fid "Date: [clock format [clock seconds]]"
- puts $fid ""
- puts $fid $text
- close $fid
- return 1
- }
- }
- }
-}
;#
;# topological sort. returns a list.
;#wokUtils:EASY:tsort { {a h} {b g} {c f} {c h} {d i} }
;# => { d a b c i g f h }
-;#
proc wokUtils:EASY:tsort { listofpairs } {
foreach x $listofpairs {
set e1 [lindex $x 0]
return $str[replicate " " [expr { $len - [string length $str] }]]
}
#
-# Execute lcmd : a list of commands
-# return the list of commqnd to execute in case of error.
-# that is returns {}if everything's OK.
-# verbose 1 exec 0 => just print. dont execute.
-# verbose 1 exec 1 => print command then execute.
-# verbose 0 exec 1 => just execute
-# verbose 0 exec 0 => do nothing.
-# continue 0 => return if error.
-# continue 1 => try do end execution of list.
-#
-proc wokUtils:EASY:Command { lcmd {verbose 0} {exec 1} {continue 1} } {
- foreach command $lcmd {
- if { $verbose } { puts stdout "Ex: $command" }
- if { $exec } {
- if [catch { eval exec $command } status ] {
- puts "$status"
- if { $continue == 0 } {
- return -1
- }
- }
- }
- }
- return 1
-}
-;#
-;# Same as above without exec
-;#
-proc wokUtils:EASY:TclCommand { lcmd {verbose 0} {exec 1} {continue 1} } {
- foreach command $lcmd {
- if { $verbose } { puts stdout "Ex: $command" }
- if { $exec } {
- eval $command
- }
- }
- return 1
-}
-#
-# Execute command_file as a whole. Default send exec.
-# Can use package Expect on Unix platform. => shell is expect:ShellName
-# Send a exec command on WNT platform
+# Sho call stack
#
-proc wokUtils:EASY:Execute { command_file {shell sh} {fileid stdout} {timeout -1} {V 0} } {
- global tcl_platform
- if { "$shell" == "noexec" } {
- foreach l [wokUtils:FILES:FileToList $command_file] {
- puts "$l"
- }
- return
- } elseif { "$shell" == "expect:sh" } {
- set shell sh
- spawn -noecho $shell $command_file
- set LOCID $spawn_id
- log_user 0
- exp_internal $V
- set timeout $timeout
- expect {
- -i $LOCID -indices -re "(\[^\r]*)\r\n" {
- ;#puts stdout $expect_out(1,string)
- puts $fileid $expect_out(1,string)
- exp_continue
- }
- -i $LOCID eof {
- puts $fileid "Received eof. Bye"
- return
- }
- -i $LOCID timeout {
- puts $fileid "Timeout excedeed ($timeout) from spawned process."
- }
- }
- return
- } else {
- foreach command [wokUtils:FILES:FileToList $command_file] {
- puts "Ex: $command"
- if ![catch { eval exec $command } status ] {
- puts $fileid $status
- } else {
- puts "Ex ERROR: $status"
- }
- }
- return
+proc wokUtils:EASY:ShowCall {{file stdout}} {
+ puts $file "Tcl call trace"
+ for { set l [expr [info level]-1] } { $l > 0 } { incr l -1 } {
+ puts $file "$l : [info level $l]"
}
}
+
;#
;# search for each element in dfile if it belongs to a directory of dlist
;#
}
return $ret
}
-;#
-;# Write a Tcl proc to return the contents of map. Proc will have 1 argument: the name of the map.
-;#
-proc wokUtils:EASY:MapToProc { map TclFile ProcName } {
- upvar $map TLOC
- if ![ catch { set id [ open $TclFile w ] } errout ] {
- puts $id "proc $ProcName { map } {"
- puts $id "upvar \$map TLOC"
- foreach x [array names TLOC] {
- puts $id "set TLOC($x) {$TLOC($x)}"
- }
- puts $id "return"
- puts $id "}"
- close $id
- return 1
- } else {
- puts stderr "$errout"
- return -1
- }
-}
-;#
-;# Write a Tcl proc to return the contents of list. Proc will has no argument.
-;#
-proc wokUtils:EASY:ListToProc { list TclFile ProcName } {
- if ![ catch { set id [ open $TclFile w ] } errout ] {
- puts $id "proc $ProcName { } {"
- puts $id "set l {$list}"
- puts $id {return $l}
- puts $id "}"
- close $id
- return 1
- } else {
- puts stderr "$errout"
- return -1
- }
-}
-;#
-;# Returns the list of all "revision" files in map that is:
-;#
-proc wokUtils:EASY:RevFiles { map } {
- upvar $map TLOC
- set l {}
- foreach x [array names TLOC] {
- foreach e $TLOC($x) {
- if [regexp {[ ]*#[ ]*([^ ]*)[ ]*([^ ]*)[ ]*([^ ]*)} $e all basn elem from] {
- lappend l [file join $from $basn]
- } elseif [regexp {[ ]*\+[ ]*([^ ]*)[ ]*([^ ]*)} $e all basn from] {
- lappend l [file join $from $basn]
+
+proc wokUtils:FILES:html { file } {
+ global tcl_platform
+ if { "$tcl_platform(platform)" == "unix" } {
+ set cmd "exec netscape -remote \"openFile($file)\""
+ if { [catch $cmd] != 0 } {
+ exec netscape &
+ while { [catch $cmd] != 0 } {
+ after 500
}
}
- }
- return $l
-}
-;#
-;# Write a map. map(.ext) = { list of files in lpath with this extension)
-;#
-proc wokUtils:EASY:ext { lpath map } {
- upvar $map TLOC
- catch { unset TLOC }
- foreach f $lpath {
- lappend TLOC([file extension $f]) $f
- }
- return
-}
-;#
-;# Compares 2 maps created by DirToMap.
-;# Writes in res the result of comparison in res
-;# res is a map indexed by :
-;#
-;# ##,d where d was found both in the 2 maps imas and irev.
-;# Element res(##,d) contains the comparaison of the 2 directories.
-;# --,d where d was found in imas and not in irev
-;#
-;#
-proc wokUtils:EASY:Compare { imas irev res {CompareFunc wokUtils:FILES:AreSame} {hidee 0} {gblist *} } {
- upvar $imas mas $irev rev $res TLOC
- if { [array exists mas] } {
- set lmas [array names mas]
- } else {
- set lmas {}
- }
- set lcom [wokUtils:LIST:i3 $lmas [array names rev]]
- set pnts " "
- foreach dir [lsort [lindex $lcom 1]] {
- wokUtils:LIST:SimpleDiff COMP $mas($dir) $rev($dir) $gblist
- if { [array exists COMP] } {
- set lapp {}
- foreach e [lsort [array names COMP]] {
- set flag [lindex $COMP($e) 0]
- set f1 [set d1 [lindex $COMP($e) 1]]/$e
- set f2 [set d2 [lindex $COMP($e) 2]]/$e
- if { [string compare $flag ?] == 0 } {
- if { [$CompareFunc $f1 $f2] == 1 } {
- if { $hidee == 0 } {
- lappend lapp [format " = %-30s %-40s %s" $e $d1 $d2]
- }
- } else {
- lappend lapp [format " # %-30s %-40s %s" $e $d1 $d2]
- }
- } elseif { "$flag" == "+" } {
- lappend lapp [format " + %-30s %s %s" $e $pnts $d1]
- } elseif { "$flag" == "-" } {
- lappend lapp [format " - %-30s %s %s" $e $d1 $pnts]
- }
+ } elseif { "$tcl_platform(platform)" == "windows" } {
+ set cmd [list exec netscape $file &]
+ if { [catch $cmd] != 0 } {
+ set prog [tk_getOpenFile -title "Where is Netscape ?"]
+ if { $prog != "" } {
+ puts $prog
+ exec $prog $file &
}
- set TLOC(##,$dir) $lapp
- }
- }
-
- foreach dir [lindex $lcom 0] {
- set lapp {}
- foreach f $mas($dir) {
- lappend lapp [format " - %-30s %s %s" [file tail $f] $f $pnts]
}
- set TLOC(--,$dir) $lapp
}
- foreach dir [lindex $lcom 2] {
- set lapp {}
- foreach f $rev($dir) {
- lappend lapp [format " + %-30s %s %s" [file tail $f] $pnts [file dirname $f]]
- }
- set TLOC(++,$dir) $lapp
- }
- return
+ return
}
-;#
-;# lit une map cree par wokUtils:EASY:Compare et imprime dans l'ordre.
-;#
-proc wokUtils:EASY:WriteCompare { dir1 dir2 map {fileid stdout} } {
- upvar $map TLOC
-
- foreach dir [lsort [array names TLOC ##,*]] {
- puts $fileid "\n Directory $dir\n"
- foreach l $TLOC($dir) {
- puts $fileid $l
- }
- }
-
- foreach dir [array names TLOC --,*] {
- puts $fileid "\n Directory $dir\n"
- foreach l $TLOC($dir) {
- puts $fileid $l
- }
- }
+;# essais
+;#
+;#proc wokUtils:FILES:lcprp { listorig target } {
+;# foreach r $listorig {
+;# puts "Copying $r onto $target"
+;# catch { exec cp -rp $r $target} status
+;# puts "$status"
+;# }
+;#}
- foreach dir [lsort -command wokUtils:FILES:Depth [array names TLOC ++,*]] {
- puts $fileid "\n Directory $dir\n"
- foreach l $TLOC($dir) {
- puts $fileid $l
- }
- }
-}
-;#
-;# lit sur fileid un report cree par wokUtils:EASY:WriteCompare et genere une map avec comme index:
-;# ##,x Contient la liste des operations a faire sur le sous dir x qui n'est que modifie
-;# ++,x Contient la liste des operations (ajout) a faire sur le sous dir x qui est nouveau
-;# --,x Contient la liste des operations (rm) a faire sur le sous dir x qui a disparu.
-;# Pour l'appelant Ca s'est bien passe si [array exists map]
-;# Arrete la lecture a la premiere ligne contenant un caractere en 1 er colonne.
-;#
-proc wokUtils:EASY:ReadCompare { map fileid } {
- upvar $map TLOC
- catch { unset TLOC }
- while {[gets $fileid x] >= 0} {
- if { $x != {} } {
- if { [string range $x 0 0] == " " } {
- if { [regexp { Directory (.*)} $x all comdir] } {
- set TLOC($comdir) {}
- } else {
- if [info exists comdir] {
- if [info exists TLOC($comdir)] {
- set l $TLOC($comdir)
- lappend l $x
- set TLOC($comdir) $l
- }
- } else {
- puts stderr "Format error: $x"
- return
- }
- }
- } else {
- return
- }
- }
- }
-}
-;#
-;# sert a trier les index ++ d'une map cree ci dessus de facon a obtenir une liste de directories
-;# triee "de la racine vers le bas". Pas bokou plus que wokUtils:FILES:Depth
-;# donc inx1 et inx2 de la forme ++,dirname
-;#
-proc wokUtils:EASY:SortCompare++ { inx1 inx2 } {
- regsub -all {\+\+,} $inx1 {} d1
- regsub -all {\+\+,} $inx2 {} d2
- return [wokUtils:FILES:Depth $d1 $d2]
-}
-;#
-;# returns 1 if map has no entry concerning regx
-;#
-proc wokUtils:EASY:MapEmpty { map {regx *} } {
- upvar $map TLOC
- if [array exists TLOC] {
- set ll 0
- foreach x [array names TLOC $regx] {
- set ll [expr { $ll + [llength $TLOC($x)]} ]
- }
- if { $ll == 0 } {
- return 1
- } else {
- return 0
- }
- } else {
- return 1
- }
-}
-;#
-;# a stack with an array ; push
-;#
-proc wokUtils:STACK:push { stack value } {
- upvar $stack TLOC
- if ![info exists TLOC(top)] {
- set TLOC(top) 0
- }
- set TLOC($TLOC(top)) $value
- incr TLOC(top)
-}
-;#
-;# a stack with an array ; pop returns {} if empty
-;#
-proc wokUtils:STACK:pop { stack } {
- upvar $stack TLOC
- if ![info exists TLOC(top)] {
- return {}
- }
- if { $TLOC(top) == 0 } {
- return {}
- } else {
- incr TLOC(top) -1
- set x $TLOC($TLOC(top))
- unset TLOC($TLOC(top))
- return $x
- }
-}
-#
-# Renvoie 1 si wb est une racine 0 sinon
-#
-proc wokUtils:WB:IsRoot { wb } {
- return [expr { ( [llength [w_info -A $wb]] > 1 ) ? 0 : 1 }]
-}
-;#
-;# Create directory.
-;#
-proc wokUtils:DIR:create { dir } {
- global tcl_version
- if { "$tcl_version" == "7.6" || "$tcl_version" == "8.0"} {
- set command "file mkdir $dir"
- } else {
- set command "mkdir -path $dir"
- }
- catch { eval $command } status
- if { "$status" == "" } {
- return 1
- } else {
- puts "$status"
- return -1
- }
-}
-;#
-;# lnames is a list of names, returns a map indexed with the lowered name and as value the original name
-;# used to copy file from Windows to Unix system.
-;#
-proc wokUtils:EASY:u2l { lnames map } {
- upvar $map TLOC
- foreach name $lnames {
- set TLOC([string tolower $name]) $name
- }
- return
-}
+;#proc wokUtils:FILES:cprp { d1 d2 } {
+;# set cmd "tar cf - . | ( cd $d2 ; tar xf - )"
+;# return
+;#}
projects / occt-wok.git / commitdiff