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