#
# compat --
#
# This file provides commands compatible with older versions of Extended Tcl.
#
#------------------------------------------------------------------------------
# Copyright 1992-1999 Karl Lehenbauer and Mark Diekhans.
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted, provided
# that the above copyright notice appear in all copies. Karl Lehenbauer and
# Mark Diekhans make no representations about the suitability of this
# software for any purpose. It is provided "as is" without express or
# implied warranty.
#------------------------------------------------------------------------------
# $Id: compat.tcl,v 1.1 2001/10/24 23:31:48 hobbs Exp $
#------------------------------------------------------------------------------
#
#@package: TclX-GenCompat assign_fields cexpand
proc assign_fields {list args} {
puts stderr {**** Your program is using an obsolete TclX proc, "assign_fields".}
puts stderr {**** Please use the command "lassign". Compatibility support will}
puts stderr {**** be removed in the next release.}
proc assign_fields {list args} {
if [lempty $args] {
return
}
return [uplevel lassign [list $list] $args]
}
return [uplevel assign_fields [list $list] $args]
}
# Added TclX 7.4a
proc cexpand str {subst -nocommands -novariables $str}
#@package: TclX-ServerCompat server_open server_connect server_send \
server_info server_cntl
# Added TclX 7.4a
proc server_open args {
set cmd server_connect
set buffered 1
while {[string match -* [lindex $args 0]]} {
set opt [lvarpop args]
if [cequal $opt -buf] {
set buffered 1
} elseif [cequal $opt -nobuf] {
set buffered 0
}
lappend cmd $opt
}
set handle [uplevel [concat $cmd $args]]
if $buffered {
lappend handle [dup $handle]
}
return $handle
}
# Added TclX 7.5a
proc server_connect args {
set cmd socket
set buffered 1
set twoids 0
while {[string match -* [lindex $args 0]]} {
switch -- [set opt [lvarpop args]] {
-buf {
set buffered 1
}
-nobuf {
set buffered 0
}
-myip {
lappend cmd -myaddr [lvarpop args]
}
-myport {
lappend cmd -myport [lvarpop args]
}
-twoids {
set twoids 1
}
default {
error "unknown option \"$opt\""
}
}
}
set handle [uplevel [concat $cmd $args]]
if !$buffered {
fconfigure $handle -buffering none
}
if $twoids {
lappend handle [dup $handle]
}
return $handle
}
proc server_send args {
set cmd puts
while {[string match -* [lindex $args 0]]} {
switch -- [set opt [lvarpop args]] {
{-dontroute} {
error "server_send if obsolete, -dontroute is not supported by the compatibility proc"
}
{-outofband} {
error "server_send if obsolete, -outofband is not supported by the compatibility proc"
}
}
lappend cmd $opt
}
uplevel [concat $cmd $args]
flush [lindex $args 0]
}
proc server_info args {
eval [concat host_info $args]
}
proc server_cntl args {
eval [concat fcntl $args]
}
#@package: TclX-ClockCompat fmtclock convertclock getclock
# Added TclX 7.5a
proc fmtclock {clockval {format {}} {zone {}}} {
lappend cmd clock format $clockval
if ![lempty $format] {
lappend cmd -format $format
}
if ![lempty $zone] {
lappend cmd -gmt 1
}
return [eval $cmd]
}
# Added TclX 7.5a
proc convertclock {dateString {zone {}} {baseClock {}}} {
lappend cmd clock scan $dateString
if ![lempty $zone] {
lappend cmd -gmt 1
}
if ![lempty $baseClock] {
lappend cmd -base $baseClock
}
return [eval $cmd]
}
# Added TclX 7.5a
proc getclock {} {
return [clock seconds]
}
#@package: TclX-FileCompat mkdir rmdir unlink frename
# Added TclX 7.6.0
proc mkdir args {
set path 0
if {[llength $args] > 1} {
lvarpop args
set path 1
}
foreach dir [lindex $args 0] {
if {((!$path) && [file isdirectory $dir]) || \
([file exists $dir] && ![file isdirectory $dir])} {
error "creating directory \"$dir\" failed: file already exists" \
{} {POSIX EEXIST {file already exists}}
}
file mkdir $dir
}
return
}
# Added TclX 7.6.0
proc rmdir args {
set nocomplain 0
if {[llength $args] > 1} {
lvarpop args
set nocomplain 1
global errorInfo errorCode
set saveErrorInfo $errorInfo
set saveErrorCode $errorCode
}
foreach dir [lindex $args 0] {
if $nocomplain {
catch {file delete $dir}
} else {
if ![file exists $dir] {
error "can't remove \"$dir\": no such file or directory" {} \
{POSIX ENOENT {no such file or directory}}
}
if ![cequal [file type $dir] directory] {
error "$dir: not a directory" {} \
{POSIX ENOTDIR {not a directory}}
}
file delete $dir
}
}
if $nocomplain {
set errorInfo $saveErrorInfo
set errorCode $saveErrorCode
}
return
}
# Added TclX 7.6.0
proc unlink args {
set nocomplain 0
if {[llength $args] > 1} {
lvarpop args
set nocomplain 1
global errorInfo errorCode
set saveErrorInfo $errorInfo
set saveErrorCode $errorCode
}
foreach file [lindex $args 0] {
if {[file exists $file] && [cequal [file type $file] directory]} {
if !$nocomplain {
error "$file: not owner" {} {POSIX EPERM {not owner}}
}
} elseif $nocomplain {
catch {file delete $file}
} else {
if {!([file exists $file] || \
([catch {file readlink $file}] == 0))} {
error "can't remove \"$file\": no such file or directory" {} \
{POSIX ENOENT {no such file or directory}}
}
file delete $file
}
}
if $nocomplain {
set errorInfo $saveErrorInfo
set errorCode $saveErrorCode
}
return
}
# Added TclX 7.6.0
proc frename {old new} {
if {[file isdirectory $new] && ![lempty [readdir $new]]} {
error "rename \"foo\" to \"baz\" failed: directory not empty" {} \
POSIX ENOTEMPTY {directory not empty}
}
file rename -force $old $new
}
#@package: TclX-CopyFileCompat copyfile
# Added TclX 8.0.0
# copyfile ?-bytes num | \-maxbytes num? ?\-translate? fromFileId toFileId
proc copyfile args {
global errorInfo errorCode
set copyMode NORMAL
set translate 0
while {[string match -* [lindex $args 0]]} {
set opt [lvarpop args]
switch -exact -- $opt {
-bytes {
set copyMode BYTES
if {[llength $args] == 0} {
error "argument required for -bytes option"
}
set totalBytesToRead [lvarpop args]
}
-maxbytes {
set copyMode MAX_BYTES
if {[llength $args] == 0} {
error "argument required for -maxbytes option"
}
set totalBytesToRead [lvarpop args]
}
-translate {
set translate 1
}
default {
error "invalid argument \"$opt\", expected \"-bytes\",\
\"-maxbytes\", or \"-translate\""
}
}
}
if {[llength $args] != 2} {
error "wrong # args: copyfile ?-bytes num|-maxbytes num? ?-translate?\
fromFileId toFileId"
}
lassign $args fromFileId toFileId
if !$translate {
set fromOptions [list \
[fconfigure $fromFileId -translation] \
[fconfigure $fromFileId -eofchar]]
set toOptions [list \
[fconfigure $toFileId -translation] \
[fconfigure $toFileId -eofchar]]
fconfigure $fromFileId -translation binary
fconfigure $fromFileId -eofchar {}
fconfigure $toFileId -translation binary
fconfigure $toFileId -eofchar {}
}
set cmd [list fcopy $fromFileId $toFileId]
if ![cequal $copyMode NORMAL] {
lappend cmd -size $totalBytesToRead
}
set stat [catch {eval $cmd} totalBytesRead]
if $stat {
set saveErrorResult $totalBytesRead
set saveErrorInfo $errorInfo
set saveErrorCode $errorCode
}
if !$translate {
# Try to restore state, even if we have an error.
if [catch {
fconfigure $fromFileId -translation [lindex $fromOptions 0]
fconfigure $fromFileId -eofchar [lindex $fromOptions 1]
fconfigure $toFileId -translation [lindex $toOptions 0]
fconfigure $toFileId -eofchar [lindex $toOptions 1]
} errorResult] {
# If fcopy did not get an error, we process this one
if !$stat {
set stat 1
set saveErrorResult $errorResult
set saveErrorInfo $errorInfo
set saveErrorCode $errorCode
}
}
}
if $stat {
error $saveErrorResult $saveErrorInfo $saveErrorCode
}
if {[cequal $copyMode BYTES] && ($totalBytesToRead > 0) && \
($totalBytesRead != $totalBytesToRead)} {
error "premature EOF, $totalBytesToRead bytes expected,\
$totalBytesRead bytes actually read"
}
return $totalBytesRead
}