1# 2# compat -- 3# 4# This file provides commands compatible with older versions of Extended Tcl. 5# 6#------------------------------------------------------------------------------ 7# Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans. 8# 9# Permission to use, copy, modify, and distribute this software and its 10# documentation for any purpose and without fee is hereby granted, provided 11# that the above copyright notice appear in all copies. Karl Lehenbauer and 12# Mark Diekhans make no representations about the suitability of this 13# software for any purpose. It is provided "as is" without express or 14# implied warranty. 15#------------------------------------------------------------------------------ 16# $Id: compat.tcl,v 1.1 2001/10/24 23:31:48 hobbs Exp $ 17#------------------------------------------------------------------------------ 18# 19 20#@package: TclX-GenCompat assign_fields cexpand 21 22proc assign_fields {list args} { 23 puts stderr {**** Your program is using an obsolete TclX proc, "assign_fields".} 24 puts stderr {**** Please use the command "lassign". Compatibility support will} 25 puts stderr {**** be removed in the next release.} 26 27 proc assign_fields {list args} { 28 if [lempty $args] { 29 return 30 } 31 return [uplevel lassign [list $list] $args] 32 } 33 return [uplevel assign_fields [list $list] $args] 34} 35 36# Added TclX 7.4a 37proc cexpand str {subst -nocommands -novariables $str} 38 39#@package: TclX-ServerCompat server_open server_connect server_send \ 40 server_info server_cntl 41 42# Added TclX 7.4a 43 44proc server_open args { 45 set cmd server_connect 46 47 set buffered 1 48 while {[string match -* [lindex $args 0]]} { 49 set opt [lvarpop args] 50 if [cequal $opt -buf] { 51 set buffered 1 52 } elseif [cequal $opt -nobuf] { 53 set buffered 0 54 } 55 lappend cmd $opt 56 } 57 set handle [uplevel [concat $cmd $args]] 58 if $buffered { 59 lappend handle [dup $handle] 60 } 61 return $handle 62} 63 64# Added TclX 7.5a 65 66proc server_connect args { 67 set cmd socket 68 69 set buffered 1 70 set twoids 0 71 while {[string match -* [lindex $args 0]]} { 72 switch -- [set opt [lvarpop args]] { 73 -buf { 74 set buffered 1 75 } 76 -nobuf { 77 set buffered 0 78 } 79 -myip { 80 lappend cmd -myaddr [lvarpop args] 81 } 82 -myport { 83 lappend cmd -myport [lvarpop args] 84 } 85 -twoids { 86 set twoids 1 87 } 88 default { 89 error "unknown option \"$opt\"" 90 } 91 } 92 } 93 set handle [uplevel [concat $cmd $args]] 94 if !$buffered { 95 fconfigure $handle -buffering none 96 } 97 if $twoids { 98 lappend handle [dup $handle] 99 } 100 return $handle 101} 102 103proc server_send args { 104 set cmd puts 105 106 while {[string match -* [lindex $args 0]]} { 107 switch -- [set opt [lvarpop args]] { 108 {-dontroute} { 109 error "server_send if obsolete, -dontroute is not supported by the compatibility proc" 110 } 111 {-outofband} { 112 error "server_send if obsolete, -outofband is not supported by the compatibility proc" 113 } 114 } 115 lappend cmd $opt 116 } 117 uplevel [concat $cmd $args] 118 flush [lindex $args 0] 119} 120 121proc server_info args { 122 eval [concat host_info $args] 123} 124 125proc server_cntl args { 126 eval [concat fcntl $args] 127} 128 129#@package: TclX-ClockCompat fmtclock convertclock getclock 130 131# Added TclX 7.5a 132 133proc fmtclock {clockval {format {}} {zone {}}} { 134 lappend cmd clock format $clockval 135 if ![lempty $format] { 136 lappend cmd -format $format 137 } 138 if ![lempty $zone] { 139 lappend cmd -gmt 1 140 } 141 return [eval $cmd] 142} 143 144# Added TclX 7.5a 145 146proc convertclock {dateString {zone {}} {baseClock {}}} { 147 lappend cmd clock scan $dateString 148 if ![lempty $zone] { 149 lappend cmd -gmt 1 150 } 151 if ![lempty $baseClock] { 152 lappend cmd -base $baseClock 153 } 154 return [eval $cmd] 155} 156 157# Added TclX 7.5a 158 159proc getclock {} { 160 return [clock seconds] 161} 162 163#@package: TclX-FileCompat mkdir rmdir unlink frename 164 165# Added TclX 7.6.0 166 167proc mkdir args { 168 set path 0 169 if {[llength $args] > 1} { 170 lvarpop args 171 set path 1 172 } 173 foreach dir [lindex $args 0] { 174 if {((!$path) && [file isdirectory $dir]) || \ 175 ([file exists $dir] && ![file isdirectory $dir])} { 176 error "creating directory \"$dir\" failed: file already exists" \ 177 {} {POSIX EEXIST {file already exists}} 178 } 179 file mkdir $dir 180 } 181 return 182} 183 184# Added TclX 7.6.0 185 186proc rmdir args { 187 set nocomplain 0 188 if {[llength $args] > 1} { 189 lvarpop args 190 set nocomplain 1 191 global errorInfo errorCode 192 set saveErrorInfo $errorInfo 193 set saveErrorCode $errorCode 194 } 195 foreach dir [lindex $args 0] { 196 if $nocomplain { 197 catch {file delete $dir} 198 } else { 199 if ![file exists $dir] { 200 error "can't remove \"$dir\": no such file or directory" {} \ 201 {POSIX ENOENT {no such file or directory}} 202 } 203 if ![cequal [file type $dir] directory] { 204 error "$dir: not a directory" {} \ 205 {POSIX ENOTDIR {not a directory}} 206 } 207 file delete $dir 208 } 209 } 210 if $nocomplain { 211 set errorInfo $saveErrorInfo 212 set errorCode $saveErrorCode 213 } 214 return 215} 216 217# Added TclX 7.6.0 218 219proc unlink args { 220 set nocomplain 0 221 if {[llength $args] > 1} { 222 lvarpop args 223 set nocomplain 1 224 global errorInfo errorCode 225 set saveErrorInfo $errorInfo 226 set saveErrorCode $errorCode 227 } 228 foreach file [lindex $args 0] { 229 if {[file exists $file] && [cequal [file type $file] directory]} { 230 if !$nocomplain { 231 error "$file: not owner" {} {POSIX EPERM {not owner}} 232 } 233 } elseif $nocomplain { 234 catch {file delete $file} 235 } else { 236 if {!([file exists $file] || \ 237 ([catch {file readlink $file}] == 0))} { 238 error "can't remove \"$file\": no such file or directory" {} \ 239 {POSIX ENOENT {no such file or directory}} 240 } 241 file delete $file 242 } 243 } 244 if $nocomplain { 245 set errorInfo $saveErrorInfo 246 set errorCode $saveErrorCode 247 } 248 return 249} 250 251# Added TclX 7.6.0 252 253proc frename {old new} { 254 if {[file isdirectory $new] && ![lempty [readdir $new]]} { 255 error "rename \"foo\" to \"baz\" failed: directory not empty" {} \ 256 POSIX ENOTEMPTY {directory not empty} 257 } 258 file rename -force $old $new 259} 260 261 262#@package: TclX-CopyFileCompat copyfile 263 264# Added TclX 8.0.0 265 266# copyfile ?-bytes num | \-maxbytes num? ?\-translate? fromFileId toFileId 267 268proc copyfile args { 269 global errorInfo errorCode 270 271 set copyMode NORMAL 272 set translate 0 273 while {[string match -* [lindex $args 0]]} { 274 set opt [lvarpop args] 275 switch -exact -- $opt { 276 -bytes { 277 set copyMode BYTES 278 if {[llength $args] == 0} { 279 error "argument required for -bytes option" 280 } 281 set totalBytesToRead [lvarpop args] 282 } 283 -maxbytes { 284 set copyMode MAX_BYTES 285 if {[llength $args] == 0} { 286 error "argument required for -maxbytes option" 287 } 288 set totalBytesToRead [lvarpop args] 289 } 290 -translate { 291 set translate 1 292 } 293 default { 294 error "invalid argument \"$opt\", expected \"-bytes\",\ 295 \"-maxbytes\", or \"-translate\"" 296 } 297 } 298 } 299 if {[llength $args] != 2} { 300 error "wrong # args: copyfile ?-bytes num|-maxbytes num? ?-translate?\ 301 fromFileId toFileId" 302 } 303 lassign $args fromFileId toFileId 304 305 if !$translate { 306 set fromOptions [list \ 307 [fconfigure $fromFileId -translation] \ 308 [fconfigure $fromFileId -eofchar]] 309 set toOptions [list \ 310 [fconfigure $toFileId -translation] \ 311 [fconfigure $toFileId -eofchar]] 312 313 fconfigure $fromFileId -translation binary 314 fconfigure $fromFileId -eofchar {} 315 fconfigure $toFileId -translation binary 316 fconfigure $toFileId -eofchar {} 317 } 318 319 set cmd [list fcopy $fromFileId $toFileId] 320 if ![cequal $copyMode NORMAL] { 321 lappend cmd -size $totalBytesToRead 322 } 323 324 set stat [catch {eval $cmd} totalBytesRead] 325 if $stat { 326 set saveErrorResult $totalBytesRead 327 set saveErrorInfo $errorInfo 328 set saveErrorCode $errorCode 329 } 330 331 if !$translate { 332 # Try to restore state, even if we have an error. 333 if [catch { 334 fconfigure $fromFileId -translation [lindex $fromOptions 0] 335 fconfigure $fromFileId -eofchar [lindex $fromOptions 1] 336 fconfigure $toFileId -translation [lindex $toOptions 0] 337 fconfigure $toFileId -eofchar [lindex $toOptions 1] 338 } errorResult] { 339 # If fcopy did not get an error, we process this one 340 if !$stat { 341 set stat 1 342 set saveErrorResult $errorResult 343 set saveErrorInfo $errorInfo 344 set saveErrorCode $errorCode 345 } 346 } 347 } 348 349 if $stat { 350 error $saveErrorResult $saveErrorInfo $saveErrorCode 351 } 352 353 if {[cequal $copyMode BYTES] && ($totalBytesToRead > 0) && \ 354 ($totalBytesRead != $totalBytesToRead)} { 355 error "premature EOF, $totalBytesToRead bytes expected,\ 356 $totalBytesRead bytes actually read" 357 } 358 return $totalBytesRead 359} 360