1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
## -*- tcl -*-
# # ## ### ##### ######## ############# #####################
## Copyright (c) 2007-2008 Andreas Kupries.
#
# This software is licensed as described in the file LICENSE, which
# you should have received as part of this distribution.
#
# This software consists of voluntary contributions made by many
# individuals. For exact contribution history, see the revision
# history and logs, available at http://fossil-scm.hwaci.com/fossil
# # ## ### ##### ######## ############# #####################
## Utilities for various things: text formatting, max, ...
# # ## ### ##### ######## ############# #####################
## Requirements
package require Tcl 8.4 ; # Required runtime
# # ## ### ##### ######## ############# #####################
##
namespace eval ::vc::tools::misc {
# # ## ### ##### ######## #############
## Public API, Methods
# Choose singular vs plural forms of a word based on a number.
proc sp {n singular {plural {}}} {
if {$n == 1} {return $singular}
if {$plural eq ""} {set plural ${singular}s}
return $plural
}
# As above, with the number automatically put in front of the
# string.
proc nsp {n singular {plural {}}} {
return "$n [sp $n $singular $plural]"
}
# Find maximum/minimum in a list.
proc max {list} {
set max -1
foreach e $list {
if {$e < $max} continue
set max $e
}
return $max
}
proc min {list} {
set min {}
foreach e $list {
if {$min == {}} {
set min $e
} elseif {$e > $min} continue
set min $e
}
return $min
}
proc max2 {a b} {
if {$a > $b} { return $a }
return $b
}
proc min2 {a b} {
if {$a < $b} { return $a }
return $b
}
proc ldelete {lv item} {
upvar 1 $lv list
set pos [lsearch -exact $list $item]
if {$pos < 0} return
set list [lreplace $list $pos $pos]
return
}
# Delete item from list by name
proc striptrailingslash {path} {
# split and rejoin gets rid of a traling / character.
return [eval [linsert [file split $path] 0 ::file join]]
}
# The windows filesystem is storing file-names case-sensitive, but
# matching is case-insensitive. That is a problem as without
# precaution the two files Attic/X,v and x,v may be mistakenly
# identified as the same file. A similar thing can happen for
# files and directories. To prevent such mistakes we need commands
# which do case-sensitive file matching even on systems which do
# not perform this natively. These are below.
if {$tcl_platform(platform) eq "windows"} {
# We use glob to get the list of files (with proper case in
# the names) to perform our own, case-sensitive matching. WE
# use 8.5 features where possible, for clarity.
if {[package vsatisfies [package present Tcl] 8.5]} {
proc fileexists_cs {path} {
set dir [::file dirname $path]
set file [::file tail $path]
return [expr {$file in [glob -nocomplain -tail -directory $dir *]}]
}
proc fileisdir_cs {path} {
set dir [::file dirname $path]
set file [::file tail $path]
return [expr {$file in [glob -nocomplain -types d -tail -directory $dir *]}]
}
} else {
proc fileexists_cs {path} {
set dir [::file dirname $path]
set file [::file tail $path]
return [expr {[lsearch [glob -nocomplain -tail -directory $dir *] $file] >= 0}]
}
proc fileisdir_cs {path} {
set dir [::file dirname $path]
set file [::file tail $path]
return [expr {[lsearch [glob -nocomplain -types d -tail -directory $dir *] $file] >= 0}]
}
}
} else {
proc fileexists_cs {path} { return [file exists $path] }
proc fileisdir_cs {path} { return [file isdirectory $path] }
}
# # ## ### ##### ######## #############
}
namespace eval ::vc::tools::misc {
namespace export sp nsp max min max2 min2 ldelete
namespace export striptrailingslash fileexists_cs fileisdir_cs
}
# -----------------------------------------------------------------------------
# Ready
package provide vc::tools::misc 1.0
return
|
