Attachment "8.diff" to
ticket [433970ffff]
added by
andreas_kupries
2001-06-22 22:27:28.
? frinked
? modules/base64/base64.tcl.merged
? modules/md5/md5.tcl.merged
Index: ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/ChangeLog,v
retrieving revision 1.54
diff -u -r1.54 ChangeLog
--- ChangeLog 2001/06/22 14:33:07 1.54
+++ ChangeLog 2001/06/22 15:24:22
@@ -1,5 +1,10 @@
2001-06-21 Andreas Kupries <[email protected]>
+ * Ran frink and procheck over all modules and fixed the reported
+ problems. As far as they actually were problems.
+
+2001-06-21 Andreas Kupries <[email protected]>
+
* Makefile.in (MODULES): Added module 'sha1'. This is another
message digest like 'md5'.
Index: modules/base64/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/base64/ChangeLog,v
retrieving revision 1.8
diff -u -r1.8 ChangeLog
--- modules/base64/ChangeLog 2001/06/22 14:33:07 1.8
+++ modules/base64/ChangeLog 2001/06/22 15:24:23
@@ -1,3 +1,7 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * base64.tcl: Fixed dubious code reported by frink.
+
2001-06-02 Miguel Sofer <[email protected]>
* base64.tcl: Greatly increased speed, obtained by: using lists
Index: modules/base64/base64.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/base64/base64.tcl,v
retrieving revision 1.9
diff -u -r1.9 base64.tcl
--- modules/base64/base64.tcl 2001/06/22 14:33:07 1.9
+++ modules/base64/base64.tcl 2001/06/22 15:24:23
@@ -60,6 +60,14 @@
error "value for \"$arg\" missing"
}
set val [lindex $args $i]
+
+ # The name of the variable to assign the value to is extracted
+ # from the list of known options, all of which have an
+ # associated variable of the same name as the option without
+ # a leading "-". The [string range] command is used to strip
+ # of the leading "-" from the name of the option.
+ #
+ # FRINK: nocheck
set [string range [lindex $optionStrings $index] 1 end] $val
}
@@ -191,6 +199,14 @@
error "value for \"$arg\" missing"
}
set val [lindex $args $i]
+
+ # The name of the variable to assign the value to is extracted
+ # from the list of known options, all of which have an
+ # associated variable of the same name as the option without
+ # a leading "-". The [string range] command is used to strip
+ # of the leading "-" from the name of the option.
+ #
+ # FRINK: nocheck
set [string range [lindex $optionStrings $index] 1 end] $val
}
@@ -261,10 +277,10 @@
set bits [lindex $base64 $x]
if {$bits >= 0} {
if {[llength [lappend nums $bits]] == 4} {
- foreach {v w x y} $nums break
+ foreach {v w z y} $nums break
set a [expr {($v << 2) | ($w >> 4)}]
- set b [expr {(($w & 0xF) << 4) | ($x >> 2)}]
- set c [expr {(($x & 0x3) << 6) | $y}]
+ set b [expr {(($w & 0xF) << 4) | ($z >> 2)}]
+ set c [expr {(($z & 0x3) << 6) | $y}]
append output [binary format ccc $a $b $c]
set nums {}
}
@@ -275,13 +291,13 @@
# (enough for 1 8-bit output). If x!={}, we have 18 bits of
# input (enough for 2 8-bit outputs).
- foreach {v w x} $nums break
+ foreach {v w z} $nums break
set a [expr {($v << 2) | (($w & 0x30) >> 4)}]
- if {$x == {}} {
+ if {$z == {}} {
append output [binary format c $a ]
} else {
- set b [expr {(($w & 0xF) << 4) | (($x & 0x3C) >> 2)}]
+ set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}]
append output [binary format cc $a $b]
}
break
Index: modules/cmdline/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/cmdline/ChangeLog,v
retrieving revision 1.5
diff -u -r1.5 ChangeLog
--- modules/cmdline/ChangeLog 2000/06/02 18:43:53 1.5
+++ modules/cmdline/ChangeLog 2001/06/22 15:24:23
@@ -1,3 +1,8 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * typedCmdline.tcl:
+ * cmdline.tcl: Fixed dubious code reported by frink.
+
2000-05-03 Brent Welch <[email protected]>
* cmdline.tcl: Changed cmdline::getopt to set boolean arguments to
Index: modules/cmdline/cmdline.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/cmdline/cmdline.tcl,v
retrieving revision 1.6
diff -u -r1.6 cmdline.tcl
--- modules/cmdline/cmdline.tcl 2000/06/02 18:43:53 1.6
+++ modules/cmdline/cmdline.tcl 2001/06/22 15:24:25
@@ -94,6 +94,9 @@
set result -1
}
}
+ default {
+ # Skip ahead
+ }
}
}
Index: modules/cmdline/typedCmdline.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/cmdline/typedCmdline.tcl,v
retrieving revision 1.2
diff -u -r1.2 typedCmdline.tcl
--- modules/cmdline/typedCmdline.tcl 2000/06/02 18:43:53 1.2
+++ modules/cmdline/typedCmdline.tcl 2001/06/22 15:24:26
@@ -22,8 +22,8 @@
variable charclasses
catch {string is . .} charclasses
- regexp {must be (.+)$} $charclasses dummy charclasses
- regsub -all {, (or )?} $charclasses {|} charclasses
+ regexp -- {must be (.+)$} $charclasses dummy charclasses
+ regsub -all -- {, (or )?} $charclasses {|} charclasses
}
@@ -151,7 +151,7 @@
set opt [lindex $optstring $i]
set quantifier "none"
- if {[regexp {\.[^.]+([?+*])$} $opt dummy quantifier]} {
+ if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} {
set opt [string range $opt 0 end-1]
}
@@ -160,11 +160,11 @@
set retvar $opt
set argsList [lrange $argsList 1 end]
- } elseif {[regexp "\\.(arg|$charclasses)\$" $opt dummy charclass]
- || [regexp {\.\(([^)]+)\)} $opt dummy charclass]} {
- if [string equal arg $charclass] {
+ } elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass]
+ || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} {
+ if {[string equal arg $charclass]} {
set type arg
- } elseif [regexp "^($charclasses)\$" $charclass] {
+ } elseif {[regexp -- "^($charclasses)\$" $charclass]} {
set type class
} else {
set type oneof
@@ -173,7 +173,7 @@
set argsList [lrange $argsList 1 end]
set opt [file rootname $opt]
- while 1 {
+ while {1} {
if {[llength $argsList] == 0
|| [string equal "--" [lindex $argsList 0]]} {
if {[string equal "--" [lindex $argsList 0]]} {
@@ -236,7 +236,7 @@
}
set quantifier ""
}
- if {![regexp {[+*]} $quantifier]} {
+ if {![regexp -- {[+*]} $quantifier]} {
break;
}
}
@@ -250,6 +250,9 @@
set retval -1
}
}
+ default {
+ # Skip ahead
+ }
}
}
@@ -397,8 +400,8 @@
# Display something about multiple options
}
- if {[regexp "\\.(arg|$charclasses)\$" $name dummy charclass]
- || [regexp {\.\(([^)]+)\)} $opt dummy charclass]} {
+ if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass]
+ || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} {
regsub "\\..+\$" $name {} name
set comment [lindex $opt 2]
set default "<[lindex $opt 1]>"
Index: modules/counter/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/counter/ChangeLog,v
retrieving revision 1.4
diff -u -r1.4 ChangeLog
--- modules/counter/ChangeLog 2000/10/04 20:01:46 1.4
+++ modules/counter/ChangeLog 2001/06/22 15:24:26
@@ -1,3 +1,7 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * counter.tcl: Fixed dubious code reported by frink.
+
2000-10-04 Brent Welch <[email protected]>
* counter.tcl: Fixed bug in counter::MergeDay
Index: modules/counter/counter.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/counter/counter.tcl,v
retrieving revision 1.4
diff -u -r1.4 counter.tcl
--- modules/counter/counter.tcl 2000/10/04 20:01:47 1.4
+++ modules/counter/counter.tcl 2001/06/22 15:24:29
@@ -129,12 +129,12 @@
# Figure out what "hour" we are
- set delta [expr $startTime - $dayStart]
- set hourIndex [expr $delta / ($secsPerMinute * 60)]
- set day [expr $hourIndex / 24]
- set hourIndex [expr $hourIndex % 24]
+ set delta [expr {$startTime - $dayStart}]
+ set hourIndex [expr {$delta / ($secsPerMinute * 60)}]
+ set day [expr {$hourIndex / 24}]
+ set hourIndex [expr {$hourIndex % 24}]
- set hourBase [expr $dayStart + $day * $secsPerMinute * 60 * 24]
+ set hourBase [expr {$dayStart + $day * $secsPerMinute * 60 * 24}]
set minuteBase [expr {$hourBase + $hourIndex * 60 * $secsPerMinute}]
set partialHour [expr {$startTime -
@@ -300,6 +300,7 @@
}
set args [list -timehist $counter::secsPerMinute]
}
+ default {#ignore}
}
unset counter
eval {counter::init $tag} $args
@@ -404,9 +405,10 @@
}
set histogram($minute) [expr {$histogram($minute) + $delta}]
}
+ default {#ignore}
}
# }
- return ""
+ return
}
# counter::exists --
@@ -902,6 +904,7 @@
append result "<td>[html::font][clock format $time \
-format "%b %d %k:%M"]</font></td></tr>\n"
}
+ default {#ignore}
}
} else {
@@ -1112,6 +1115,7 @@
set deltaT [expr {$secsPerMinute * 60 * 24}]
set wrapDeltaT 0
}
+ default {#ignore}
}
# These are tick marks
Index: modules/csv/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/csv/ChangeLog,v
retrieving revision 1.2
diff -u -r1.2 ChangeLog
--- modules/csv/ChangeLog 2001/06/19 17:21:56 1.2
+++ modules/csv/ChangeLog 2001/06/22 15:24:29
@@ -1,3 +1,7 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * csv.tcl: Fixed dubious code reported by frink and procheck.
+
2001-06-19 Andreas Kupries <[email protected]>
* csv.n: Fixed nroff trouble.
Index: modules/csv/csv.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/csv/csv.tcl,v
retrieving revision 1.1
diff -u -r1.1 csv.tcl
--- modules/csv/csv.tcl 2001/05/01 19:01:24 1.1
+++ modules/csv/csv.tcl 2001/06/22 15:24:29
@@ -139,6 +139,7 @@
return -code error "wrong # args: ::csv::report printmatrix2channel matrix chan"
}
writematrix $matrix [lindex $args 0]
+ return ""
}
default {
return -code error "Unknown method $cmd"
@@ -164,7 +165,7 @@
\"\"\"$sepChar \"\0$sepChar \
\"\" \" \" \0 ] $line]
set end 0
- while {[regexp -indices -start $end {(\0)[^\0]*(\0)} $line -> start end]} {
+ while {[regexp -indices -start $end -- {(\0)[^\0]*(\0)} $line -> start end]} {
set start [lindex $start 0]
set end [lindex $end 0]
set range [string range $line $start $end]
@@ -262,12 +263,12 @@
# None.
proc ::csv::writequeue {q chan {sepChar ,}} {
- while {[q size] > 0} {
- puts $chan [join [q get] $sepChar]
+ while {[$q size] > 0} {
+ puts $chan [join [$q get] $sepChar]
}
# Memory intensive alternative:
- # puts $chan [joinlist [q get [q size]] $sepChar]
+ # puts $chan [joinlist [$q get [$q size]] $sepChar]
return
}
Index: modules/fileutil/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/fileutil/ChangeLog,v
retrieving revision 1.3
diff -u -r1.3 ChangeLog
--- modules/fileutil/ChangeLog 2001/03/26 16:50:21 1.3
+++ modules/fileutil/ChangeLog 2001/06/22 15:24:29
@@ -1,3 +1,7 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * fileutil.tcl: Fixed dubious code reported by frink.
+
2001-03-20 Andreas Kupries <[email protected]>
* fileutil.tcl: [Bug #410104, Patch #410106]
Index: modules/fileutil/fileutil.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/fileutil/fileutil.tcl,v
retrieving revision 1.5
diff -u -r1.5 fileutil.tcl
--- modules/fileutil/fileutil.tcl 2001/03/26 16:50:21 1.5
+++ modules/fileutil/fileutil.tcl 2001/06/22 15:24:30
@@ -33,7 +33,7 @@
set lnum 0
while {[gets stdin line] >= 0} {
incr lnum
- if {[regexp $pattern $line]} {
+ if {[regexp -- $pattern $line]} {
lappend result "${lnum}:${line}"
}
}
@@ -43,7 +43,7 @@
set lnum 0
while {[gets $file line] >= 0} {
incr lnum
- if {[regexp $pattern $line]} {
+ if {[regexp -- $pattern $line]} {
lappend result "${filename}:${lnum}:${line}"
}
}
Index: modules/ftp/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/ftp/ChangeLog,v
retrieving revision 1.8
diff -u -r1.8 ChangeLog
--- modules/ftp/ChangeLog 2000/10/02 02:23:44 1.8
+++ modules/ftp/ChangeLog 2001/06/22 15:24:30
@@ -1,3 +1,7 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * ftpdemo.tcl:
+ * ftp.tcl: Fixed dubious code reported by frink.
2000-10-01 Dan Kuchler <[email protected]>
Index: modules/ftp/ftp.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/ftp/ftp.tcl,v
retrieving revision 1.10
diff -u -r1.10 ftp.tcl
--- modules/ftp/ftp.tcl 2000/10/02 02:23:44 1.10
+++ modules/ftp/ftp.tcl 2001/06/22 15:24:34
@@ -242,7 +242,7 @@
# get return code, check for multi-line text
- regexp "(^\[0-9\]+)( |-)?(.*)$" $bufline all rc multi_line msgtext
+ regexp -- "(^\[0-9\]+)( |-)?(.*)$" $bufline all rc multi_line msgtext
set buffer $bufline
# multi-line format detected ("-"), get all the lines
@@ -252,7 +252,7 @@
set number [gets $sock bufline]
if { $number > 0 } {
append buffer \n "$bufline"
- regexp "(^\[0-9\]+)( |-)?(.*)$" $bufline all rc multi_line
+ regexp -- "(^\[0-9\]+)( |-)?(.*)$" $bufline all rc multi_line
}
}
} elseif { [eof $ftp(CtrlSock)] } {
@@ -287,7 +287,7 @@
}
# use only the first digit
- regexp "^\[0-9\]?" $rc rc
+ regexp -- "^\[0-9\]?" $rc rc
switch -exact -- $ftp(State) {
user {
@@ -522,7 +522,7 @@
size_sent {
switch -exact -- $rc {
2 {
- regexp "^\[0-9\]+ (.*)$" $buffer all ftp(FileSize)
+ regexp -- "^\[0-9\]+ (.*)$" $buffer all ftp(FileSize)
set complete_with 1
set nextState 1
Command $ftp(Command) size $ftp(File) $ftp(FileSize)
@@ -541,7 +541,7 @@
modtime_sent {
switch -exact -- $rc {
2 {
- regexp "^\[0-9\]+ (.*)$" $buffer all ftp(DateTime)
+ regexp -- "^\[0-9\]+ (.*)$" $buffer all ftp(DateTime)
set complete_with 1
set nextState 1
Command $ftp(Command) modtime $ftp(File) [ModTimePostProcess $ftp(DateTime)]
@@ -560,7 +560,7 @@
pwd_sent {
switch -exact -- $rc {
2 {
- regexp "^.*\"(.*)\"" $buffer temp ftp(Dir)
+ regexp -- "^.*\"(.*)\"" $buffer temp ftp(Dir)
set complete_with 1
set nextState 1
Command $ftp(Command) pwd $ftp(Dir)
@@ -735,7 +735,7 @@
switch -exact -- $rc {
1 {
# Keep going
- return {}
+ return
}
2 {
set complete_with 1
@@ -979,6 +979,9 @@
}
}
}
+ default {
+ error "Unknown state \"$ftp(State)\""
+ }
}
# finish waiting
@@ -2147,6 +2150,7 @@
catch {close $ftp(CtrlSock)}
catch {unset ftp}
+ return 1
}
proc ftp::LazyClose {s } {
@@ -2162,7 +2166,7 @@
set connections($ftp(User),$ftp(Passwd),$ftp(RemoteHost),afterid) \
[after 5000 [list ftp::Close $s]]
}
- return
+ return 1
}
#############################################################################
@@ -2252,7 +2256,7 @@
if { $DEBUG } {
DisplayMsg $s " $option = $value"
}
- regexp {^-(.?)(.*)$} $option all first rest
+ regexp -- {^-(.?)(.*)$} $option all first rest
set option "[string toupper $first]$rest"
set ftp($option) $value
}
@@ -2374,7 +2378,7 @@
# create local file for ftp::Get
- if { [regexp "^get" $ftp(State)] && (!$ftp(inline))} {
+ if { [regexp -- "^get" $ftp(State)] && (!$ftp(inline))} {
set rc [catch {set ftp(DestCI) [open $ftp(LocalFilename) w]} msg]
if { $rc != 0 } {
DisplayMsg $s "$msg" error
@@ -2390,7 +2394,7 @@
# append local file for ftp::Reget
- if { [regexp "^reget" $ftp(State)] } {
+ if { [regexp -- "^reget" $ftp(State)] } {
set rc [catch {set ftp(DestCI) [open $ftp(LocalFilename) a]} msg]
if { $rc != 0 } {
DisplayMsg $s "$msg" error
@@ -2409,7 +2413,7 @@
set ftp(Total) 0
set ftp(Start_Time) [clock seconds]
fcopy $ftp(SourceCI) $ftp(DestCI) -command [list [namespace current]::CopyNext $s] -size $ftp(Blocksize)
- return
+ return 1
}
#############################################################################
@@ -2605,6 +2609,9 @@
set ftp(DestCI) $sock
}
}
+ default {
+ error "Unknown state \"$ftp(State)\""
+ }
}
if { $VERBOSE } {
@@ -2667,7 +2674,7 @@
proc ftp::OpenPassiveConn {s buffer} {
upvar ::ftp::ftp$s ftp
- if { [regexp {([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)} $buffer all a1 a2 a3 a4 p1 p2] } {
+ if { [regexp -- {([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+),([0-9]+)} $buffer all a1 a2 a3 a4 p1 p2] } {
set ftp(LocalAddr) "$a1.$a2.$a3.$a4"
set ftp(DataPort) "[expr {$p1 * 256 + $p2}]"
Index: modules/ftp/ftpdemo.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/ftp/ftpdemo.tcl,v
retrieving revision 1.2
diff -u -r1.2 ftpdemo.tcl
--- modules/ftp/ftpdemo.tcl 2000/07/09 20:13:34 1.2
+++ modules/ftp/ftpdemo.tcl 2001/06/22 15:24:36
@@ -259,7 +259,7 @@
set state ""
}
- switch $state {
+ switch -exact -- $state {
data {.msg.f.f2.text insert end "$msg\n" data}
control {.msg.f.f2.text insert end "$msg\n" control}
error {.msg.f.f2.text insert end "$msg\n" error; incr test(errors)}
@@ -327,7 +327,7 @@
proc ProgressBar {state {bytes 0} {total {}} {filename {}}} {
global progress
set w .progress
- switch $state {
+ switch -exact -- $state {
init {
set progress(percent) "0%"
set progress(total) $total
@@ -378,6 +378,9 @@
destroy $w
update
}
+ default {
+ error "Unknown state \"$state\""
+ }
}
}
@@ -691,7 +694,7 @@
set cnf(debug) 0
set cnf(verbose) 1
- if {[file exist $cnf(configfile)]} {
+ if {[file exists $cnf(configfile)]} {
set f [open $cnf(configfile) r]
array set cnf [read $f]
close $f
Index: modules/ftpd/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/ftpd/ChangeLog,v
retrieving revision 1.4
diff -u -r1.4 ChangeLog
--- modules/ftpd/ChangeLog 2000/11/22 17:28:49 1.4
+++ modules/ftpd/ChangeLog 2001/06/22 15:24:36
@@ -1,3 +1,7 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * ftpd.tcl: Fixed dubious code reported by frink.
+
2000-11-22 Eric Melski <[email protected]>
* Integrated patch from Mark O'Conner. Patch fixed file translation
Index: modules/ftpd/ftpd.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/ftpd/ftpd.tcl,v
retrieving revision 1.7
diff -u -r1.7 ftpd.tcl
--- modules/ftpd/ftpd.tcl 2000/11/22 17:28:49 1.7
+++ modules/ftpd/ftpd.tcl 2001/06/22 15:24:40
@@ -513,7 +513,7 @@
Finish $sock
return
}
- switch $data(state) {
+ switch -exact -- $data(state) {
command {
gets $sock command
set parts [split $command]
@@ -539,6 +539,9 @@
puts $sock "500 Unknown command $cmd"
}
}
+ default {
+ error "Unknown state \"$data(state)\""
+ }
}
return
}
@@ -1115,6 +1118,7 @@
::ftpd::Log note "Closed $sock"
puts $sock "221 Goodbye."
close $sock
+ # FRINK: nocheck
unset ::ftpd::$sock
return
}
@@ -1646,7 +1650,7 @@
} else {
set docRoot $dir
}
- return
+ return ""
}
# ::ftpd::fsFile::fs --
@@ -1869,8 +1873,11 @@
puts $outchan "213 [file size $path]"
}
}
+ default {
+ error "Unknown command \"$command\""
+ }
}
- return
+ return ""
}
# ::ftpd::fsFile::PermBits --
Index: modules/htmlparse/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/htmlparse/ChangeLog,v
retrieving revision 1.1
diff -u -r1.1 ChangeLog
--- modules/htmlparse/ChangeLog 2001/03/26 16:50:21 1.1
+++ modules/htmlparse/ChangeLog 2001/06/22 15:24:40
@@ -1,3 +1,7 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * htmlparse.tcl: Fixed dubious code reported by frink.
+
2001-03-23 Andreas Kupries <[email protected]>
* htmlparse.tcl: Changed the implementation to allow incremental
Index: modules/htmlparse/htmlparse.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/htmlparse/htmlparse.tcl,v
retrieving revision 1.1
diff -u -r1.1 htmlparse.tcl
--- modules/htmlparse/htmlparse.tcl 2001/03/26 16:50:21 1.1
+++ modules/htmlparse/htmlparse.tcl 2001/06/22 15:24:43
@@ -235,6 +235,8 @@
if {[string length $arg] == 0} {
return -code error "::htmlparse::parse : -$opt illegal argument (empty)"
}
+ # Each option has an variable with the same name associated with it.
+ # FRINK: nocheck
set $opt $arg
}
split {
@@ -243,6 +245,7 @@
}
set split $arg
}
+ default {# Can't happen}
}
}
@@ -257,13 +260,13 @@
# Handle incomplete HTML
- if {[regexp {[^<]*(<[^>]*)$} [lindex "\{$html\}" end] -> trailer]} {
+ if {[regexp -- {[^<]*(<[^>]*)$} [lindex "\{$html\}" end] -> trailer]} {
if {$incvar == {}} {
return -code error "::htmlparse::parse : HTML is incomplete, option -incvar is missing"
}
upvar $incvar incomplete
set incomplete $trailer
- set html [string range $html 0 [expr [string last "<" $html] - 1]]
+ set html [string range $html 0 [expr {[string last "<" $html] - 1}]]
}
# Convert the HTML string into a script.
@@ -415,7 +418,7 @@
proc ::htmlparse::mapEscapes {html} {
# Find HTML escape characters of the form &xxx;
- if {![regexp & $html]} {
+ if {![regexp -- & $html]} {
# HTML not containing escape sequences is returned unchanged.
return $html
}
@@ -769,6 +772,9 @@
# Removes this node and everything below it.
$tree delete $node
}
+ default {
+ # Ignore tag
+ }
}
}
@@ -792,6 +798,9 @@
form {
$tree delete $node
}
+ default {
+ # Ignore tag
+ }
}
}
@@ -829,6 +838,9 @@
}
$tree move $node end $sibling
}
+ }
+ default {
+ # Ignore tag
}
}
}
Index: modules/math/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/math/ChangeLog,v
retrieving revision 1.7
diff -u -r1.7 ChangeLog
--- modules/math/ChangeLog 2000/10/06 21:10:41 1.7
+++ modules/math/ChangeLog 2001/06/22 15:24:43
@@ -1,3 +1,7 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * math.tcl: Fixed dubious code reported by frink.
+
2000-10-06 Eric Melski <[email protected]>
* math.test:
Index: modules/math/math.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/math/math.tcl,v
retrieving revision 1.7
diff -u -r1.7 math.tcl
--- modules/math/math.tcl 2000/10/06 21:10:41 1.7
+++ modules/math/math.tcl 2001/06/22 15:24:44
@@ -93,12 +93,12 @@
}
;## are we dealing with x,y pairs?
- if { [ expr $length % 2 ] } {
+ if { [ expr {$length % 2} ] } {
return -code error "unmatched xy pair in input"
}
;## are there an even number of pairs? Augment.
- if { ! [ expr $length % 4 ] } {
+ if { ! [ expr {$length % 4} ] } {
set xy_pairs [ concat [ lindex $xy_pairs 0 ] 0 $xy_pairs ]
}
set x0 [ lindex $xy_pairs 0 ]
Index: modules/md5/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/md5/ChangeLog,v
retrieving revision 1.4
diff -u -r1.4 ChangeLog
--- modules/md5/ChangeLog 2001/06/22 14:33:07 1.4
+++ modules/md5/ChangeLog 2001/06/22 15:24:44
@@ -1,3 +1,7 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * md5.tcl: Fixed dubious code reported by frink.
+
2001-06-19 Andreas Kupries <[email protected]>
* md5.n: Fixed nroff trouble.
Index: modules/md5/md5.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/md5/md5.tcl,v
retrieving revision 1.3
diff -u -r1.3 md5.tcl
--- modules/md5/md5.tcl 2001/06/22 14:33:07 1.3
+++ modules/md5/md5.tcl 2001/06/22 15:24:46
@@ -123,7 +123,7 @@
proc ::md5::time {} {
foreach len {10 50 100 500 1000 5000 10000} {
set time [::time {md5 [format %$len.0s ""]} 100]
- regexp "\[0-9]*" $time msec
+ regexp -- "\[0-9]*" $time msec
puts "input length $len: [expr {$msec/1000}] milliseconds per interation"
}
}
@@ -325,7 +325,7 @@
regsub -all {\[ *I +(\$.) +(\$.) +(\$.) *\]} $md5body {(\2 ^ (\1 | (~\3)))} md5body
# bitwise left-rotate
- if 0 {
+ if {0} {
proc md5pure::<<< {x i} {
# This works by bitwise-ORing together right piece and left
# piece so that the (original) right piece becomes the left
Index: modules/mime/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/mime/ChangeLog,v
retrieving revision 1.9
diff -u -r1.9 ChangeLog
--- modules/mime/ChangeLog 2001/02/04 08:28:35 1.9
+++ modules/mime/ChangeLog 2001/06/22 15:24:46
@@ -1,3 +1,8 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * smtp.tcl:
+ * mime.tcl: Fixed dubious code reported by frink and procheck.
+
2001-01-30 Eric Melski <[email protected]>
* mime.tcl: Applied patch from Peter MacDonald to correct problem
Index: modules/mime/mime.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/mime/mime.tcl,v
retrieving revision 1.12
diff -u -r1.12 mime.tcl
--- modules/mime/mime.tcl 2001/02/04 08:28:35 1.12
+++ modules/mime/mime.tcl 2001/06/22 15:24:52
@@ -238,7 +238,7 @@
variable mime
set token [namespace current]::[incr mime(uid)]
-
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -274,7 +274,7 @@
proc mime::initializeaux {token args} {
global errorCode errorInfo
-
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -418,6 +418,7 @@
}
}
}
+ default {# Go ahead}
}
if {[lsearch -exact $state(lowerL) content-id] < 0} {
@@ -449,6 +450,7 @@
if {[set fileP [info exists state(file)]]} {
if {[set openP [info exists state(root)]]} {
+ # FRINK: nocheck
variable $state(root)
upvar 0 $state(root) root
@@ -492,6 +494,7 @@
# otherwise it just sets up the appropriate variables.
proc mime::parsepart {token} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -631,6 +634,7 @@
}
if {[string match message/* $state(content)]} {
+ # FRINK: nocheck
variable [set child $token-[incr state(cid)]]
set state(value) parts
@@ -674,7 +678,7 @@
if {$pos > $last} {
# error "termination string missing in $state(content)"
set line "--$boundary--"
- } {
+ } else {
if {[set x [gets $state(fd) line]] < 0} {
error "end-of-file encountered while parsing $state(content)"
}
@@ -734,7 +738,7 @@
}
continue
}
-
+ # FRINK: nocheck
variable [set child $token-[incr state(cid)]]
lappend state(parts) $child
@@ -773,7 +777,7 @@
proc mime::parsetype {token string} {
global errorCode errorInfo
-
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -815,6 +819,7 @@
# tcl list.
proc mime::parsetypeaux {token string} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -904,6 +909,7 @@
# Returns an empty string.
proc mime::finalize {token args} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -936,6 +942,7 @@
foreach name [array names state] {
unset state($name)
}
+ # FRINK: nocheck
unset $token
}
@@ -971,6 +978,7 @@
# Returns the properties of a MIME part
proc mime::getproperty {token {property ""}} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -1033,6 +1041,7 @@
# Returns the size in bytes of the MIME token.
proc mime::getsize {token} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -1063,6 +1072,9 @@
string/1 {
return [string length $state(string)]
}
+ default {
+ error "Unknown combination \"$state(value)/$state(canonicalP)\""
+ }
}
if {![string compare $state(encoding) base64]} {
@@ -1097,6 +1109,7 @@
# Returns the header of a MIME part.
proc mime::getheader {token {key ""}} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -1155,6 +1168,7 @@
# Returns previous value associated with the specified key.
proc mime::setheader {token key value args} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -1171,6 +1185,7 @@
mime-version {
error "key $key may not be set"
}
+ default {# Skip key}
}
array set header $state(header)
@@ -1248,7 +1263,7 @@
proc mime::getbody {token args} {
global errorCode errorInfo
-
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -1280,7 +1295,7 @@
}
incr pos [set len \
[string length [set chunk [read $fd $cc]]]]
- switch -- $state(encoding) {
+ switch -exact -- $state(encoding) {
base64
-
quoted-printable {
@@ -1292,6 +1307,12 @@
set chunk [$state(encoding) -mode decode \
-- $chunk]
}
+ "" {
+ # Go ahead, leave chunk alone
+ }
+ default {
+ error "Can't handle content encoding \"$state(encoding)\""
+ }
}
append fragment $chunk
@@ -1371,7 +1392,10 @@
} result]
set ecode $errorCode
set einfo $errorInfo
- }
+ }
+ default {
+ error "Unknown combination \"$state(value)/$state(canonicalP)\""
+ }
}
set code [catch {
@@ -1405,12 +1429,14 @@
# error if it is called with the reason of 'error'.
proc mime::getbodyaux {token reason {fragment ""}} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
switch -- $reason {
data {
append state(getbody) $fragment
+ return ""
}
end {
@@ -1428,6 +1454,10 @@
catch { unset state(getbody) }
error $reason
}
+
+ default {
+ error "Unknown reason \"$reason\""
+ }
}
}
@@ -1448,7 +1478,7 @@
proc mime::copymessage {token channel} {
global errorCode errorInfo
-
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -1481,6 +1511,7 @@
# is being written to the channel.
proc mime::copymessageaux {token channel} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -1527,6 +1558,12 @@
quoted-printable {
set converter $encoding
}
+ "" {
+ # Go ahead
+ }
+ default {
+ error "Can't handle content encoding \"$encoding\""
+ }
}
}
} elseif {([string match multipart/* $state(content)]) \
@@ -1552,6 +1589,7 @@
file {
set closeP 1
if {[info exists state(root)]} {
+ # FRINK: nocheck
variable $state(root)
upvar 0 $state(root) root
@@ -1644,6 +1682,9 @@
puts $channel $state(string)
}
}
+ default {
+ error "Unknown value \"$state(value)\""
+ }
}
flush $channel
@@ -1672,7 +1713,7 @@
proc mime::buildmessage {token} {
global errorCode errorInfo
-
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -1707,6 +1748,7 @@
# Returns the message that has been built up in memory.
proc mime::buildmessageaux {token} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -1754,6 +1796,12 @@
quoted-printable {
set converter $encoding
}
+ "" {
+ # Go ahead
+ }
+ default {
+ error "Can't handle content encoding \"$encoding\""
+ }
}
}
} elseif {([string match multipart/* $state(content)]) \
@@ -1779,6 +1827,7 @@
file {
set closeP 1
if {[info exists state(root)]} {
+ # FRINK: nocheck
variable $state(root)
upvar 0 $state(root) root
@@ -1864,6 +1913,9 @@
append result "$state(string)\n"
}
}
+ default {
+ error "Unknown value \"$state(value)\""
+ }
}
if {[info exists state(error)]} {
@@ -1884,6 +1936,7 @@
# or quoted-printable).
proc mime::encoding {token} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -1901,6 +1954,7 @@
multipart/* {
return ""
}
+ default {# Skip}
}
set asciiP 1
@@ -1942,6 +1996,9 @@
}
}
}
+ default {
+ error "Unknown value \"$state(value)\""
+ }
}
switch -glob -- $state(content) {
@@ -2043,6 +2100,7 @@
#
proc mime::fcopy {token count {error ""}} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -2069,6 +2127,7 @@
# copied to the specified channel.
proc mime::scopy {token channel offset len blocksize} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -2157,7 +2216,7 @@
foreach line [split $string \n] {
while {[string length $line] > 72} {
set chunk [string range $line 0 72]
- if {[regexp (=|=.)$ $chunk dummy end]} {
+ if {[regexp -- (=|=.)$ $chunk dummy end]} {
# Don't break in the middle of a code
@@ -2273,7 +2332,7 @@
variable mime
set token [namespace current]::[incr mime(uid)]
-
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -2284,6 +2343,7 @@
foreach name [array names state] {
unset state($name)
}
+ # FRINK: nocheck
catch { unset $token }
return -code $code -errorinfo $einfo -errorcode $ecode $result
@@ -2324,6 +2384,7 @@
# specified in the argument.
proc mime::parseaddressaux {token string} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -2435,7 +2496,7 @@
proc mime::addr_next {token} {
global errorCode errorInfo
-
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -2511,6 +2572,7 @@
# Returns 1 if there is another address, and 0 if there is not.
proc mime::addr_specification {token} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -2624,6 +2686,7 @@
# Returns 1 if there is another address, and 0 if there is not.
proc mime::addr_routeaddr {token {checkP 1}} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -2678,6 +2741,7 @@
# syntax is found.
proc mime::addr_route {token} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -2753,6 +2817,7 @@
# syntax is found.
proc mime::addr_domain {token} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -2799,6 +2864,7 @@
# syntax is found.
proc mime::addr_local {token} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -2843,6 +2909,7 @@
proc mime::addr_phrase {token} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -2893,6 +2960,7 @@
# syntax is found.
proc mime::addr_group {token} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -2936,6 +3004,7 @@
# syntax is found.
proc mime::addr_end {token} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -2970,7 +3039,7 @@
proc mime::addr_x400 {mbox key} {
if {[set x [string first "/$key=" [string toupper $mbox]]] < 0} {
- return
+ return ""
}
set mbox [string range $mbox [expr {$x+[string length $key]+2}] end]
@@ -3184,6 +3253,7 @@
# Returns the next token found by the parser.
proc mime::parselexeme {token} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -3399,14 +3469,19 @@
}
set result "=?$encodings($charset)?"
- switch -exact $method {
+ switch -exact -- $method {
base64 {
- append result "B?[base64::encode $string]?="
+ append result "B?[string trimright [base64 -mode encode -- $string] \n]?="
}
-
quoted-printable {
append result "Q?[qp_encode $string 1]?="
}
+ "" {
+ # Go ahead
+ }
+ default {
+ error "Can't handle content encoding \"$method\""
+ }
}
return $result
@@ -3426,7 +3501,7 @@
variable reversemap
- if {[regexp {=\?([^?]+)\?(.)\?([^?]*)\?=} $encoded \
+ if {[regexp -- {=\?([^?]+)\?(.)\?([^?]*)\?=} $encoded \
- charset method string] != 1} {
error "malformed word-encoded expression '$encoded'"
}
@@ -3435,7 +3510,7 @@
error "unknown charset '$charset'"
}
- switch $method {
+ switch -exact -- $method {
B {
set method base64
}
@@ -3447,14 +3522,19 @@
}
}
- switch -exact $method {
+ switch -exact -- $method {
base64 {
- set result [base64::decode $string]
+ set result [base64 -mode decode -- $string]
}
-
quoted-printable {
set result [qp_decode $string 1]
}
+ "" {
+ # Go ahead
+ }
+ default {
+ error "Can't handle content encoding \"$method\""
+ }
}
return [list $reversemap($charset) $method $result]
@@ -3478,7 +3558,7 @@
set field [join $field]
set result ""
- while {[regexp -indices {=\?([^?]+)\?(.)\?([^?]*)\?=} $field indices]} {
+ while {[regexp -indices -- {=\?([^?]+)\?(.)\?([^?]*)\?=} $field indices]} {
# get the indices
Index: modules/mime/smtp.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/mime/smtp.tcl,v
retrieving revision 1.10
diff -u -r1.10 smtp.tcl
--- modules/mime/smtp.tcl 2000/09/20 18:32:58 1.10
+++ modules/mime/smtp.tcl 2001/06/22 15:24:55
@@ -206,7 +206,9 @@
foreach mixed {From Sender To cc Dcc Bcc Date Message-ID} {
set lower [string tolower $mixed]
+ # FRINK: nocheck
set ${lower}L $prefixL$lower
+ # FRINK: nocheck
set ${lower}M $prefixM$mixed
}
@@ -576,7 +578,7 @@
variable smtp
set token [namespace current]::[incr smtp(uid)]
-
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -711,7 +713,7 @@
proc smtp::finalize {token args} {
global errorCode errorInfo
-
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -751,6 +753,7 @@
foreach name [array names state] {
unset state($name)
}
+ # FRINK: nocheck
unset $token
return -code $code -errorinfo $einfo -errorcode $ecode $result
@@ -774,6 +777,7 @@
# error occurs, throw an exception.
proc smtp::winit {token originator {mode MAIL}} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -808,6 +812,7 @@
# error occurs, throw an exception.
proc smtp::waddr {token recipient} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -841,6 +846,7 @@
# error occurs, throw an exception.
proc smtp::wtext {token part} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -887,6 +893,7 @@
proc smtp::wtextaux {token part} {
global errorCode errorInfo
variable trf
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -939,6 +946,7 @@
# value.
proc smtp::wdata {token command buffer} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -1005,7 +1013,12 @@
incr state(size) [string length $result]
return $result
}
+ default {
+ error "Unknown command \"$command\""
+ }
}
+
+ return ""
}
# smtp::talk --
@@ -1022,6 +1035,7 @@
# an exception.
proc smtp::talk {token secs command} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -1038,7 +1052,7 @@
}
if {$secs == 0} {
- return
+ return ""
}
return [smtp::hear $token $secs]
@@ -1056,6 +1070,7 @@
# Response is returned.
proc smtp::hear {token secs} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -1142,6 +1157,7 @@
# 1 if reading from socket was successful
proc smtp::readable {token} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
@@ -1185,6 +1201,7 @@
# Sets state(readable) to -1 and state(error) to an error message.
proc smtp::timer {token} {
+ # FRINK: nocheck
variable $token
upvar 0 $token state
Index: modules/ncgi/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/ncgi/ChangeLog,v
retrieving revision 1.10
diff -u -r1.10 ChangeLog
--- modules/ncgi/ChangeLog 2001/06/16 01:26:36 1.10
+++ modules/ncgi/ChangeLog 2001/06/22 15:24:55
@@ -1,3 +1,7 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * ncgi.tcl: Fixed dubious code reported by frink.
+
2001-06-15 Melissa Chawla <[email protected]>
* ncgi.tcl: Applied George Wu's patch ([email protected]) to the
Index: modules/ncgi/ncgi.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/ncgi/ncgi.tcl,v
retrieving revision 1.17
diff -u -r1.17 ncgi.tcl
--- modules/ncgi/ncgi.tcl 2001/06/16 01:26:36 1.17
+++ modules/ncgi/ncgi.tcl 2001/06/22 15:24:58
@@ -148,6 +148,7 @@
variable urlStub
if {[string length $url]} {
set urlStub $url
+ return ""
} elseif {[info exist urlStub]} {
return $urlStub
} elseif {[info exist env(SCRIPT_NAME)]} {
@@ -303,7 +304,7 @@
foreach {x} [split [string trim $query] &] {
# Turns out you might not get an = sign,
# especially with <isindex> forms.
- if {![regexp (.*)=(.*) $x dummy varname val]} {
+ if {![regexp -- (.*)=(.*) $x dummy varname val]} {
set varname anonymous
set val $x
}
@@ -379,7 +380,7 @@
if {!$exists} {
lappend varlist $name
}
- if {[regexp List$ $name]} {
+ if {[regexp -- List$ $name]} {
# Accumulate a list of values for this name
lappend value($name) $val
} elseif {$exists} {
@@ -614,7 +615,7 @@
proc ncgi::redirect {url} {
global env
- if {![regexp {^[^:]+://} $url]} {
+ if {![regexp -- {^[^:]+://} $url]} {
# The url is relative (no protocol/server spec in it), so
# here we create a canonical URL.
@@ -650,13 +651,13 @@
# URL. Otherwise use SERVER_NAME. These could be different, e.g.,
# "pop.scriptics.com" vs. "pop"
- if {![regexp {^https?://([^/:]*)} $env(REQUEST_URI) x server]} {
+ if {![regexp -- {^https?://([^/:]*)} $env(REQUEST_URI) x server]} {
set server $env(SERVER_NAME)
}
if {[string match /* $url]} {
set url $proto://$server$port$url
} else {
- regexp {^(.*/)[^/]*$} $request_uri match dirname
+ regexp -- {^(.*/)[^/]*$} $request_uri match dirname
set url $proto://$server$port$dirname$url
}
}
@@ -713,12 +714,12 @@
set results [list [string trim [lindex $parts 0]]]
set paramList [list]
foreach sub [lrange $parts 1 end] {
- if {[regexp {([^=]+)=(.+)} $sub match key val]} {
+ if {[regexp -- {([^=]+)=(.+)} $sub match key val]} {
set key [string trim [string tolower $key]]
set val [string trim $val]
# Allow single as well as double quotes
- if {[regexp {^["']} $val quote]} { ;# need a " for balance
- if {[regexp ^${quote}(\[^$quote\]*)$quote $val x val2]} {
+ if {[regexp -- {^["']} $val quote]} { ;# need a " for balance
+ if {[regexp -- ^${quote}(\[^$quote\]*)$quote $val x val2]} {
# Trim quotes and any extra crap after close quote
set val $val2
}
@@ -842,7 +843,7 @@
set headers [list]
set formName ""
foreach line [split [string range $query $offset $off2] $lineDelim] {
- if {[regexp {([^: ]+):(.*)$} $line x hdrname value]} {
+ if {[regexp -- {([^: ]+):(.*)$} $line x hdrname value]} {
set hdrname [string tolower $hdrname]
set valueList [parseMimeValue $value]
if {[string equal $hdrname "content-disposition"]} {
Index: modules/nntp/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/nntp/ChangeLog,v
retrieving revision 1.3
diff -u -r1.3 ChangeLog
--- modules/nntp/ChangeLog 2000/06/20 22:23:56 1.3
+++ modules/nntp/ChangeLog 2001/06/22 15:24:58
@@ -1,3 +1,6 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * nntp.tcl: Fixed dubious code reported by frink.
2000-06-20 Dan Kuchler <[email protected]>
Index: modules/nntp/nntp.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/nntp/nntp.tcl,v
retrieving revision 1.2
diff -u -r1.2 nntp.tcl
--- modules/nntp/nntp.tcl 2000/06/20 22:23:56 1.2
+++ modules/nntp/nntp.tcl 2001/06/22 15:24:59
@@ -388,7 +388,7 @@
set data(cmnd) "fetch"
if {![::nntp::command $name "IHAVE $msgid"]} {
- return
+ return ""
}
return [::nntp::squirt $name "$args"]
}
@@ -474,7 +474,7 @@
upvar 0 ::nntp::${name}data data
if {$group != ""} {
- if {[regexp {^[\w\.\-]+$} $group] == 0} {
+ if {[regexp -- {^[\w\.\-]+$} $group] == 0} {
set since $group
set group ""
}
@@ -534,7 +534,7 @@
proc ::nntp::_post {name args} {
if {![::nntp::command $name "POST"]} {
- return
+ return ""
}
return [::nntp::squirt $name "$args"]
}
@@ -645,7 +645,7 @@
proc ::nntp::_xhdr {name {header "message-id"} {list ""} {last ""}} {
upvar 0 ::nntp::${name}data data
- if {![regexp {\d+-\d+} $list]} {
+ if {![regexp -- {\d+-\d+} $list]} {
if {"$last" != ""} {
set list "$list-$last"
} else {
@@ -679,7 +679,7 @@
proc ::nntp::_xover {name {list ""} {last ""}} {
upvar 0 ::nntp::${name}data data
- if {![regexp {\d+-\d+} $list]} {
+ if {![regexp -- {\d+-\d+} $list]} {
if {"$last" != ""} {
set list "$list-$last"
} else {
@@ -695,7 +695,7 @@
set patterns ""
- if {![regexp {\d+-\d+} $list]} {
+ if {![regexp -- {\d+-\d+} $list]} {
if {("$last" != "") && ([string is digit $last])} {
set list "$list-$last"
}
@@ -725,7 +725,7 @@
proc ::nntp::_xsearch {name args} {
set res [::nntp::command $name "XSEARCH"]
if {!$res} {
- return
+ return ""
}
return [::nntp::squirt $name "$args"]
}
@@ -771,7 +771,7 @@
set res [::nntp::okprint $name]
if {!$res} {
- return
+ return ""
}
return $data(mesg)
}
@@ -781,10 +781,11 @@
set data(group) ""
- if {[::nntp::okprint $name] && [regexp {(\d+)\s+(\d+)\s+(\d+)\s+([\w\.]+)} \
+ if {[::nntp::okprint $name] && [regexp -- {(\d+)\s+(\d+)\s+(\d+)\s+([\w\.]+)} \
$data(mesg) match count first last data(group)]} {
return [list $count $first $last $data(group)]
}
+ return ""
}
proc ::nntp::msgid {name} {
@@ -804,7 +805,7 @@
set result ""
if {[::nntp::okprint $name] && \
- [regexp {\d+\s+<[^>]+>} $data(mesg) result]} {
+ [regexp -- {\d+\s+<[^>]+>} $data(mesg) result]} {
return $result
} else {
return ""
@@ -817,7 +818,7 @@
set eol "\012"
if {![::nntp::okprint $name]} {
- return
+ return ""
}
set sock $data(sock)
@@ -826,7 +827,7 @@
gets $sock line
regsub {\015?\012$} $line $data(eol) line
- if {[regexp {^\.$} $line]} {
+ if {[regexp -- {^\.$} $line]} {
break
}
regsub {^\.\.} $line {.} line
@@ -852,12 +853,12 @@
regsub {\015?\012$} $line "" line
- set result [regexp {^((\d\d)(\d))\s*(.*)} $line match \
+ set result [regexp -- {^((\d\d)(\d))\s*(.*)} $line match \
data(code) val1 val2 data(mesg)]
if {$result == 0} {
puts stderr "nntp garbled response: $line\n";
- return
+ return ""
}
if {$val1 == 20} {
Index: modules/pop3/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/pop3/ChangeLog,v
retrieving revision 1.5
diff -u -r1.5 ChangeLog
--- modules/pop3/ChangeLog 2001/05/02 15:03:33 1.5
+++ modules/pop3/ChangeLog 2001/06/22 15:24:59
@@ -1,3 +1,7 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * pop3.tcl: Fixed dubious code reported by frink.
+
2001-01-24 Scott Redman <[email protected]>
* pop3.tcl: Fixed a bug when getting the "." back
Index: modules/pop3/pop3.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/pop3/pop3.tcl,v
retrieving revision 1.9
diff -u -r1.9 pop3.tcl
--- modules/pop3/pop3.tcl 2001/05/02 15:03:33 1.9
+++ modules/pop3/pop3.tcl 2001/06/22 15:25:01
@@ -295,7 +295,7 @@
set popRet [string trim [gets $chan]]
if {[string first "+OK" $popRet] == -1} {
- error [string range $popRet [expr 3 + 1] end]
+ error [string range $popRet 4 end]
}
return [string range $popRet 3 end]
Index: modules/profiler/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/profiler/ChangeLog,v
retrieving revision 1.8
diff -u -r1.8 ChangeLog
--- modules/profiler/ChangeLog 2000/09/20 17:23:14 1.8
+++ modules/profiler/ChangeLog 2001/06/22 15:25:01
@@ -1,3 +1,7 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * profilertcl: Fixed dubious code reported by frink.
+
2000-09-20 Eric Melski <[email protected]>
* profiler.tcl: Corrected some non-Tcl-style-guide conforming
Index: modules/profiler/profiler.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/profiler/profiler.tcl,v
retrieving revision 1.12
diff -u -r1.12 profiler.tcl
--- modules/profiler/profiler.tcl 2000/09/20 17:23:14 1.12
+++ modules/profiler/profiler.tcl 2001/06/22 15:25:02
@@ -29,6 +29,7 @@
set ms [ clock clicks -milliseconds ]
set us [ clock clicks ]
regsub -all {:} $tag {} tag
+ # FRINK: nocheck
set ::profiler::T$tag [ list $us $ms ]
return
}
@@ -49,7 +50,16 @@
set ut [ clock clicks ]
set mt [ clock clicks -milliseconds ]
regsub -all {:} $tag {} tag
+
+ # Per tag a variable was created within the profiler
+ # namespace. But we should check if the tag does ecxist.
+
+ if {![info exists ::profiler::T$tag]} {
+ error "Unknown tag \"$tag\""
+ }
+ # FRINK: nocheck
set ust [ lindex [ set ::profiler::T$tag ] 0 ]
+ # FRINK: nocheck
set mst [ lindex [ set ::profiler::T$tag ] 1 ]
set udt [ expr { ($ut-$ust) } ]
set mdt [ expr { ($mt-$mst) } ]000
@@ -170,11 +180,11 @@
# have an absolute namespace qualifier, we have to prepend the current
# namespace to the command name
if { ![string equal $ns "::"] } {
- if { ![regexp "^::" $name] } {
+ if { ![regexp -- "^::" $name] } {
set name "${ns}::${name}"
}
}
- if { ![regexp "^::" $name] } {
+ if { ![regexp -- "^::" $name] } {
set name "::$name"
}
Index: modules/report/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/report/ChangeLog,v
retrieving revision 1.2
diff -u -r1.2 ChangeLog
--- modules/report/ChangeLog 2001/06/19 17:21:57 1.2
+++ modules/report/ChangeLog 2001/06/22 15:25:02
@@ -1,3 +1,7 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * report.tcl: Fixed dubious code reported by frink.
+
2001-06-19 Andreas Kupries <[email protected]>
* report.n: Fixed nroff trouble.
Index: modules/report/report.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/report/report.tcl,v
retrieving revision 1.1
diff -u -r1.1 report.tcl
--- modules/report/report.tcl 2001/05/01 19:01:24 1.1
+++ modules/report/report.tcl 2001/06/22 15:25:05
@@ -241,6 +241,9 @@
2 {
set def 1
}
+ default {
+ error "Illegal length of value \"$v\""
+ }
}
}
if {[string equal args [lindex $arguments end]]} {
@@ -548,8 +551,10 @@
}
return $column
}
+ default {
+ return -code error "column: syntax error in index \"$column\""
+ }
}
- return -code error "column: syntax error in index \"$column\""
}
# ::report::CheckVerticals --
@@ -737,13 +742,14 @@
upvar ::report::report${name}::enabled enabled
return $enabled($template)
}
+ default {error "Can't happen, panic, run, shout"}
}
}
default {
return -code error "Unknown template command \"$cmd\""
}
}
- return
+ return ""
}
# ::report::_tcaption --
@@ -772,7 +778,7 @@
}
if {$size == $tcaption} {
# No change, nothing to do
- return
+ return ""
}
if {($size > 0) && ($tcaption == 0)} {
# Perform a consistency check after the assignment, the
@@ -782,7 +788,7 @@
} else {
set tcaption $size
}
- return
+ return ""
}
# ::report::_bcaption --
@@ -811,7 +817,7 @@
}
if {$size == $bcaption} {
# No change, nothing to do
- return
+ return ""
}
if {($size > 0) && ($bcaption == 0)} {
# Perform a consistency check after the assignment, the
@@ -821,7 +827,7 @@
} else {
set bcaption $size
}
- return
+ return ""
}
# ::report::_size --
@@ -848,7 +854,7 @@
}
if {[string equal $size dyn]} {
set csize($column) $size
- return
+ return ""
}
if {![string is integer $size]} {
return -code error "expected integer greater than zero, got \"$size\""
@@ -857,7 +863,7 @@
return -code error "expected integer greater than zero, got \"$size\""
}
set csize($column) $size
- return
+ return ""
}
# ::report::_sizes --
@@ -903,7 +909,7 @@
set csize($i) $s
incr i
}
- return
+ return ""
}
# ::report::_pad --
@@ -945,7 +951,7 @@
return -code error "where: expected left, right, or both, got \"$where\""
}
}
- return
+ return ""
}
# ::report::_justify --
@@ -973,10 +979,12 @@
switch -exact -- $jvalue {
left - right - center {
set cjust($column) $jvalue
- return
+ return ""
+ }
+ default {
+ return -code error "justification: expected, left, right, or center, got \"$jvalue\""
}
}
- return -code error "justification: expected, left, right, or center, got \"$jvalue\""
}
# ::report::_printmatrix --
@@ -1360,6 +1368,9 @@
set rcut [expr {$cut - $lcut}]
return [string range $value $lcut end-$rcut]
+ }
+ default {
+ error "Can't happen, panic, run, shout"
}
}
}
Index: modules/sha1/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/sha1/ChangeLog,v
retrieving revision 1.1
diff -u -r1.1 ChangeLog
--- modules/sha1/ChangeLog 2001/06/22 14:33:07 1.1
+++ modules/sha1/ChangeLog 2001/06/22 15:25:05
@@ -1,3 +1,7 @@
+2001-06-22 Andreas Kupries <[email protected]>
+
+ * md5.tcl: Fixed dubious code reported by frink.
+
2001-06-21 Andreas Kupries <[email protected]>
* New module, 'sha1'. The code is Don Libes's <[email protected]>
Index: modules/sha1/sha1.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/sha1/sha1.tcl,v
retrieving revision 1.1
diff -u -r1.1 sha1.tcl
--- modules/sha1/sha1.tcl 2001/06/22 14:33:07 1.1
+++ modules/sha1/sha1.tcl 2001/06/22 15:25:05
@@ -142,7 +142,7 @@
proc sha1::time {} {
foreach len {10 50 100 500 1000 5000 10000} {
set time [::time {sha1 [format %$len.0s ""]} 10]
- regexp "\[0-9]*" $time msec
+ regexp -- "\[0-9]*" $time msec
puts "input length $len: [expr {$msec/1000}] milliseconds per interation"
}
}
Index: modules/stats/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/stats/ChangeLog,v
retrieving revision 1.9
diff -u -r1.9 ChangeLog
--- modules/stats/ChangeLog 2000/10/02 16:24:15 1.9
+++ modules/stats/ChangeLog 2001/06/22 15:25:06
@@ -1,3 +1,7 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * stats.tcl: Fixed dubious code reported by frink.
+
2000-10-02 Brent Welch <[email protected]>
* modules/stats/stats.tcl: Added stats::htmlHistDisplayRow
Index: modules/stats/stats.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/stats/stats.tcl,v
retrieving revision 1.14
diff -u -r1.14 stats.tcl
--- modules/stats/stats.tcl 2000/10/03 18:01:46 1.14
+++ modules/stats/stats.tcl 2001/06/22 15:25:08
@@ -131,12 +131,12 @@
# Figure out what "hour" we are
- set delta [expr $startTime - $dayStart]
- set hourIndex [expr $delta / ($secsPerMinute * 60)]
- set day [expr $hourIndex / 24]
- set hourIndex [expr $hourIndex % 24]
+ set delta [expr {$startTime - $dayStart}]
+ set hourIndex [expr {$delta / ($secsPerMinute * 60)}]
+ set day [expr {$hourIndex / 24}]
+ set hourIndex [expr {$hourIndex % 24}]
- set hourBase [expr $dayStart + $day * $secsPerMinute * 60 * 24]
+ set hourBase [expr {$dayStart + $day * $secsPerMinute * 60 * 24}]
set minuteBase [expr {$hourBase + $hourIndex * 60 * $secsPerMinute}]
set partialHour [expr {$startTime -
@@ -302,6 +302,9 @@
}
set args [list -timehist $stats::secsPerMinute]
}
+ default {
+ error "Unknown counter type \"$counter(type)\""
+ }
}
unset counter
eval {stats::countInit $tag} $args
@@ -406,9 +409,12 @@
}
set histogram($minute) [expr {$histogram($minute) + $delta}]
}
+ default {
+ error "Unknown counter type \"$counter(type)\""
+ }
}
# }
- return ""
+ return
}
# stats::countExists --
@@ -903,6 +909,9 @@
append result "<td>[html::font][clock format $time \
-format "%b %d %k:%M"]</font></td></tr>\n"
}
+ default {
+ error "Unknown unit of time \"$options(-unit)\""
+ }
}
} else {
@@ -1106,6 +1115,9 @@
}
set deltaT [expr {$secsPerMinute * 60 * 24}]
set wrapDeltaT 0
+ }
+ default {
+ error "Unknown unit of time \"$options(-unit)\""
}
}
# These are tick marks
Index: modules/struct/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/struct/ChangeLog,v
retrieving revision 1.12
diff -u -r1.12 ChangeLog
--- modules/struct/ChangeLog 2001/06/19 17:21:57 1.12
+++ modules/struct/ChangeLog 2001/06/22 15:25:09
@@ -1,3 +1,8 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * tree.tcl:
+ * graph.tcl: Fixed dubious code reported by frink.
+
2001-06-19 Andreas Kupries <[email protected]>
* matrix.n: Fixed nroff trouble.
Index: modules/struct/graph.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/struct/graph.tcl,v
retrieving revision 1.2
diff -u -r1.2 graph.tcl
--- modules/struct/graph.tcl 2000/06/02 18:43:56 1.2
+++ modules/struct/graph.tcl 2001/06/22 15:25:10
@@ -206,6 +206,7 @@
foreach {source target} $arcNodes($arc) break ; # lassign
unset arcNodes($arc)
+ # FRINK: nocheck
unset ::struct::graph::graph${name}::arc$arc
# Remove arc from the arc lists of source and target nodes.
@@ -598,6 +599,7 @@
}
}
}
+ default {error "Can't happen, panic"}
}
return $arcs
@@ -708,6 +710,9 @@
set opt [lindex $args 0]
set node [lindex $args 1]
}
+ default {
+ error "Wrong # arguments given to 'degree'"
+ }
}
# Validate the option.
@@ -756,6 +761,7 @@
}
}
}
+ default {error "Can't happen, panic"}
}
return $result
@@ -800,6 +806,7 @@
unset inArcs($node)
unset outArcs($node)
+ # FRINK: nocheck
unset ::struct::graph::graph${name}::node$node
}
@@ -1172,6 +1179,7 @@
}
}
}
+ default {error "Can't happen, panic"}
}
return $nodes
@@ -1513,7 +1521,7 @@
# set list representing the union of the argument lists.
proc ::struct::graph::Union {args} {
- switch [llength $args] {
+ switch -- [llength $args] {
0 {
return {}
}
Index: modules/struct/tree.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/struct/tree.tcl,v
retrieving revision 1.13
diff -u -r1.13 tree.tcl
--- modules/struct/tree.tcl 2000/06/02 18:43:56 1.13
+++ modules/struct/tree.tcl 2001/06/22 15:25:13
@@ -205,6 +205,7 @@
# Remove all record of $node
unset parent($node)
unset children($node)
+ # FRINK: nocheck
unset ::struct::tree::tree${name}::node$node
return
@@ -250,6 +251,7 @@
unset children($node)
unset parent($node)
+ # FRINK: nocheck
unset ::struct::tree::tree${name}::node$node
while { [llength $st] > 0 } {
@@ -260,6 +262,7 @@
}
unset children($node)
unset parent($node)
+ # FRINK: nocheck
unset ::struct::tree::tree${name}::node$node
}
return
@@ -640,6 +643,7 @@
if { ![_exists $name $node] } {
error "node \"$node\" does not exist in tree \"$name\""
}
+ # FRINK: nocheck
return [set ::struct::tree::tree${name}::parent($node)]
}
Index: modules/textutil/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/textutil/ChangeLog,v
retrieving revision 1.4
diff -u -r1.4 ChangeLog
--- modules/textutil/ChangeLog 2001/03/26 16:50:21 1.4
+++ modules/textutil/ChangeLog 2001/06/22 15:25:13
@@ -1,3 +1,9 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * split.tcl:
+ * adjust.tcl:
+ * trim.tcl: Fixed dubious code reported by frink.
+
2001-03-23 Andreas Kupries <[email protected]>
* textutil.tcl: Reworked the implementation of 'StrRepeat', made
Index: modules/textutil/adjust.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/textutil/adjust.tcl,v
retrieving revision 1.2
diff -u -r1.2 adjust.tcl
--- modules/textutil/adjust.tcl 2001/03/26 16:50:21 1.2
+++ modules/textutil/adjust.tcl 2001/06/22 15:25:13
@@ -244,6 +244,7 @@
return "${line}"
}
+ error "Illegal justification key \"$justify\""
}
proc ::textutil::adjust::SortList { list dir index } {
Index: modules/textutil/split.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/textutil/split.tcl,v
retrieving revision 1.1
diff -u -r1.1 split.tcl
--- modules/textutil/split.tcl 2000/11/02 19:38:13 1.1
+++ modules/textutil/split.tcl 2001/06/22 15:25:13
@@ -39,12 +39,12 @@
proc ::textutil::split::splitx [list str [list regexp "\[\t \r\n\]+"]] {
set list {}
while {[regexp -indices -- $regexp $str match submatch]} {
- lappend list [string range $str 0 [expr [lindex $match 0] -1]]
+ lappend list [string range $str 0 [expr {[lindex $match 0] -1}]]
if {[lindex $submatch 0]>=0} {
lappend list [string range $str [lindex $submatch 0]\
[lindex $submatch 1]]
}
- set str [string range $str [expr [lindex $match 1]+1] end]
+ set str [string range $str [expr {[lindex $match 1]+1}] end]
}
lappend list $str
return $list
Index: modules/textutil/trim.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/textutil/trim.tcl,v
retrieving revision 1.1
diff -u -r1.1 trim.tcl
--- modules/textutil/trim.tcl 2000/11/02 19:38:14 1.1
+++ modules/textutil/trim.tcl 2001/06/22 15:25:13
@@ -68,4 +68,5 @@
return $StrR
}
+ error "Panic, illegal position key \"$pos\""
}
Index: modules/uri/ChangeLog
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/uri/ChangeLog,v
retrieving revision 1.4
diff -u -r1.4 ChangeLog
--- modules/uri/ChangeLog 2000/09/07 06:09:51 1.4
+++ modules/uri/ChangeLog 2001/06/22 15:25:13
@@ -1,3 +1,7 @@
+2001-06-21 Andreas Kupries <[email protected]>
+
+ * uri.tcl: Fixed dubious code reported by frink.
+
2000-09-06 Brent Welch <[email protected]>
* uri.tcl:
Index: modules/uri/uri.tcl
===================================================================
RCS file: /cvsroot/tcllib/tcllib/modules/uri/uri.tcl,v
retrieving revision 1.4
diff -u -r1.4 uri.tcl
--- modules/uri/uri.tcl 2000/09/07 06:09:51 1.4
+++ modules/uri/uri.tcl 2001/06/22 15:25:14
@@ -132,7 +132,7 @@
"//${login}(/${path}(${typepart})?)?"
variable url "ftp:${schemepart}"
-
+ # FRINK: nocheck
lappend [namespace current]::schemes ftp
}
@@ -143,7 +143,7 @@
variable schemepart "//(${host}|localhost)?/${path}"
variable url "file:${schemepart}"
-
+ # FRINK: nocheck
lappend [namespace current]::schemes file
}
@@ -162,7 +162,7 @@
"//${hostOrPort}(/${path}(\\?${search})?)?"
variable url "http:${schemepart}"
-
+ # FRINK: nocheck
lappend [namespace current]::schemes http
}
@@ -178,7 +178,7 @@
variable schemepart \
"//${hostOrPort}(/(${type}(${selector}(%09${search}(%09${string})?)?)?)?)?"
variable url "gopher:${schemepart}"
-
+ # FRINK: nocheck
lappend [namespace current]::schemes gopher
}
@@ -189,7 +189,7 @@
variable schemepart "$xChar+(@${host})?"
variable url "mailto:${schemepart}"
-
+ # FRINK: nocheck
lappend [namespace current]::schemes mailto
}
@@ -206,7 +206,7 @@
variable article "${aChar}+@${host}"
variable schemepart "\\*|${group}|${article}"
variable url "news:${schemepart}"
-
+ # FRINK: nocheck
lappend [namespace current]::schemes news
}
@@ -232,7 +232,7 @@
"//${hostOrPort}/${db}((\\?${search})|(/${type}/${path}))?"
variable url "wais:${schemepart}"
-
+ # FRINK: nocheck
lappend [namespace current]::schemes wais
}
@@ -251,7 +251,7 @@
variable schemepart "//${hostOrPort}/${path}(${fieldspec})*"
variable url "prospero:$schemepart"
-
+ # FRINK: nocheck
lappend [namespace current]::schemes prospero
}
@@ -264,7 +264,9 @@
variable url2part
foreach scheme $schemes {
+ # FRINK: nocheck
append url "(${scheme}:[set ${scheme}::schemepart])|"
+ # FRINK: nocheck
set url2part($scheme) "${scheme}:[set ${scheme}::schemepart]"
}
set url [string trimright $url |]
@@ -290,7 +292,7 @@
set scheme {}
# RFC 1738: scheme = 1*[ lowalpha | digit | "+" | "-" | "." ]
- regexp {^([a-z0-9+-.][a-z0-9+-.]*):} $url dummy scheme
+ regexp -- {^([a-z0-9+-.][a-z0-9+-.]*):} $url dummy scheme
if {$scheme == {}} {
set scheme http
@@ -335,7 +337,7 @@
# slash off possible type specification
- if {[regexp -indices "${ftptype}$" $url dummy ftype]} {
+ if {[regexp -indices -- "${ftptype}$" $url dummy ftype]} {
set from [lindex $ftype 0]
set to [lindex $ftype 1]
@@ -418,7 +420,7 @@
# slash off possible query
- if {[regexp -indices $searchPattern $url match query]} {
+ if {[regexp -indices -- $searchPattern $url match query]} {
set from [lindex $query 0]
set to [lindex $query 1]
@@ -429,7 +431,7 @@
# slash off possible fragment
- if {[regexp -indices $fragmentPattern $url match fragment]} {
+ if {[regexp -indices -- $fragmentPattern $url match fragment]} {
set from [lindex $fragment 0]
set to [lindex $fragment 1]
@@ -490,7 +492,7 @@
set url [string range $url 2 end]
set hostPattern "^($hostname|$hostnumber)"
- switch $::tcl_platform(platform) {
+ switch -exact -- $::tcl_platform(platform) {
windows {
# Catch drive letter
append hostPattern :?
@@ -500,7 +502,7 @@
}
}
- if {[regexp -indices $hostPattern $url match host]} {
+ if {[regexp -indices -- $hostPattern $url match host]} {
set fh [lindex $host 0]
set th [lindex $host 1]
@@ -524,7 +526,7 @@
}
array set components $args
- switch $::tcl_platform(platform) {
+ switch -exact -- $::tcl_platform(platform) {
windows {
if {[string length $components(host)]} {
return file://$components(host):$components(path)
@@ -543,7 +545,7 @@
# @a url: The url to split, without! scheme specification.
# @r List containing the constituents, suitable for 'array set'.
- if {[regexp @ $url]} {
+ if {[regexp -- @ $url]} {
set url [::split $url @]
return [list user [lindex $url 0] host [lindex $url 1]]
} else {
@@ -584,7 +586,7 @@
set upPattern "^(${user})(:(${password}))?@"
- if {[regexp -indices $upPattern $url dummy theUser c d thePassword]} {
+ if {[regexp -indices -- $upPattern $url dummy theUser c d thePassword]} {
set fu [lindex $theUser 0]
set tu [lindex $theUser 1]
@@ -602,7 +604,7 @@
set hpPattern "^($hostname|$hostnumber)(:($port))?"
- if {[regexp -indices $hpPattern $url match theHost c d e f g h thePort]} {
+ if {[regexp -indices -- $hpPattern $url match theHost c d e f g h thePort]} {
set fh [lindex $theHost 0]
set th [lindex $theHost 1]
@@ -636,7 +638,7 @@
set pattern "^(${hostname}|${hostnumber})(:(${port}))?"
- if {[regexp -indices $pattern $url match host c d e f g h thePort]} {
+ if {[regexp -indices -- $pattern $url match host c d e f g h thePort]} {
set fromHost [lindex $host 0]
set toHost [lindex $host 1]
@@ -715,7 +717,7 @@
# Returns 1 if the URL is relative, 0 otherwise
proc uri::isrelative url {
- return [expr ![regexp {^[a-z0-9+-.][a-z0-9+-.]*:} $url]]
+ return [expr {![regexp -- {^[a-z0-9+-.][a-z0-9+-.]*:} $url]}]
}
# geturl --
@@ -818,10 +820,10 @@
# Remove single dots (.) => pwd not changing
# Remove double dots (..) => gobble previous segment of path
- while {[regexp {/\./} $uri]} {
+ while {[regexp -- {/\./} $uri]} {
regsub -all {/\./} $uri {/} uri
}
- while {[regexp {/\.\./} $uri]} {
+ while {[regexp -- {/\.\./} $uri]} {
if {![regsub {/[^./]*/\.\./} $uri {/} uri]} {
# The regexp found 'foo://bar.com/../baz', but this
# cannot be handled by the regsub. Simply remove the
