19 lines
458 B
Tcl
19 lines
458 B
Tcl
package require Tcl 8.5
|
|
proc pop {varname} {
|
|
upvar 1 $varname var
|
|
set var [lassign $var head]
|
|
return $head
|
|
}
|
|
|
|
proc common_prefix {dirs {separator "/"}} {
|
|
set parts [split [pop dirs] $separator]
|
|
while {[llength $dirs]} {
|
|
set r {}
|
|
foreach cmp $parts elt [split [pop dirs] $separator] {
|
|
if {$cmp ne $elt} break
|
|
lappend r $cmp
|
|
}
|
|
set parts $r
|
|
}
|
|
return [join $parts $separator]
|
|
}
|