diff options
| -rw-r--r-- | array.tcl | 104 | ||||
| -rw-r--r-- | glob.tcl | 133 | ||||
| -rw-r--r-- | jim-file.c | 2 | ||||
| -rw-r--r-- | stdio.tcl | 71 | ||||
| -rw-r--r-- | tcl6.tcl | 100 |
5 files changed, 409 insertions, 1 deletions
diff --git a/array.tcl b/array.tcl new file mode 100644 index 0000000..a1298c0 --- /dev/null +++ b/array.tcl @@ -0,0 +1,104 @@ +# (c) 2008 Steve Bennett <steveb@workware.net.au>
+#
+# Implements a Tcl-compatible array command based on dict
+#
+# The FreeBSD license
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+#
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above
+# copyright notice, this list of conditions and the following
+# disclaimer in the documentation and/or other materials
+# provided with the distribution.
+#
+# THIS SOFTWARE IS PROVIDED BY THE JIM TCL PROJECT ``AS IS'' AND ANY
+# EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
+# THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+# JIM TCL PROJECT OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+# ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+#
+# The views and conclusions contained in the software and documentation
+# are those of the authors and should not be interpreted as representing
+# official policies, either expressed or implied, of the Jim Tcl Project.
+
+package provide array 1.0
+
+proc array {subcmd arrayname args} {
+ # $name is the name of the array in the caller's context
+ upvar $arrayname name
+
+ if {$subcmd eq "exists"} {
+ return [info exists name]
+ }
+
+ if {![info exists name]} {
+ set name [dict create]
+ }
+
+ switch $subcmd {
+ set {
+ # The argument should be a list, but we also
+ # support name value pairs
+ if {[llength $args] == 1} {
+ set args [lindex $args 0]
+ }
+ foreach {key value} $args {
+ dict set name $key $value
+ }
+ return $name
+ }
+ size {
+ return [/ [llength $name] 2]
+ }
+ }
+
+ # The remaining options take a pattern
+ if {[llength $args] > 0} {
+ set pattern [lindex $args 0]
+ } else {
+ set pattern *
+ }
+
+ switch $subcmd {
+ names {
+ set keys {}
+ foreach {key value} $name {
+ if {[string match $pattern $key]} {
+ lappend keys $key
+ }
+ }
+ return $keys
+ }
+ get {
+ set list {}
+ foreach {key value} $name {
+ if {[string match $pattern $key]} {
+ lappend list $key $value
+ }
+ }
+ return $list
+ }
+ unset {
+ foreach {key value} $args {
+ if {[string match $pattern $key]} {
+ dict unset name $key
+ }
+ }
+ return
+ }
+ }
+
+ # Tcl-compatible error message
+ error "bad option \"$subcmd\": must be exists, get, names, set, size, or unset"
+}
diff --git a/glob.tcl b/glob.tcl new file mode 100644 index 0000000..9529df0 --- /dev/null +++ b/glob.tcl @@ -0,0 +1,133 @@ +# (c) 2008 Steve Bennett <steveb@workware.net.au>
+#
+# Implements a Tcl-compatible glob command based on readdir
+#
+# The FreeBSD license
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+#
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above
+# copyright notice, this list of conditions and the following
+# disclaimer in the documentation and/or other materials
+# provided with the distribution.
+#
+# THIS SOFTWARE IS PROVIDED BY THE JIM TCL PROJECT ``AS IS'' AND ANY
+# EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
+# THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+# JIM TCL PROJECT OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+# ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+#
+# The views and conclusions contained in the software and documentation
+# are those of the authors and should not be interpreted as representing
+# official policies, either expressed or implied, of the Jim Tcl Project.
+
+package provide glob 1.0
+package require readdir 1.0
+
+# If $dir is a directory, return a list of all entries
+# it contains which match $pattern
+#
+proc _glob_readdir_pattern {dir pattern} {
+ set result {}
+
+ # readdir doesn't return . or .., so simulate it here
+ if {$pattern eq "." || $pattern eq ".."} {
+ return $pattern
+ }
+ # Use -nocomplain here to return nothing if $dir is not a directory
+ foreach name [readdir -nocomplain $dir] {
+ if {[string match $pattern $name]} {
+ lappend result $name
+ }
+ }
+
+ return $result
+}
+
+# glob entries in directory $dir and pattern $rem
+#
+proc _glob_do {dir rem} {
+ # Take one level from rem
+ # Avoid regexp here
+ set i [string first / $rem]
+ if {$i < 0} {
+ set pattern $rem
+ set rempattern ""
+ } else {
+ set j $i
+ incr j
+ incr i -1
+ set pattern [string range $rem 0 $i]
+ set rempattern [string range $rem $j end]
+ }
+
+ # Determine the appropriate separator and globbing dir
+ set sep /
+ set globdir $dir
+ if {[string match "*/" $dir]} {
+ set sep ""
+ } elseif {$dir eq ""} {
+ set globdir .
+ set sep ""
+ }
+
+ set result {}
+
+ # Use readdir and select all files which match the pattern
+ foreach f [_glob_readdir_pattern $globdir $pattern] {
+ if {$rempattern eq ""} {
+ # This is a terminal entry, so add it
+ lappend result $dir$sep$f
+ } else {
+ # Expany any entries at this level and add them
+ lappend result {expand}[_glob_do $dir$sep$f $rempattern]
+ }
+ }
+ return $result
+}
+
+# Implements the Tcl glob command
+#
+# Usage: glob ?-nocomplain? pattern ...
+#
+# Patterns use string match pattern matching for each
+# directory level.
+#
+# e.g. glob te[a-e]*/*.tcl
+#
+proc glob {args} {
+ set nocomplain 0
+
+ if {[lindex $args 0] eq "-nocomplain"} {
+ set nocomplain 1
+ set args [lrange $args 1 end]
+ }
+
+ set result {}
+ foreach pattern $args {
+ if {$pattern eq "/"} {
+ lappend result /
+ } elseif {[string match "/*" $pattern]} {
+ lappend result {expand}[_glob_do / [string range $pattern 1 end]]
+ } else {
+ lappend result {expand}[_glob_do "" $pattern]
+ }
+ }
+
+ if {$nocomplain == 0 && [llength $result] == 0} {
+ error "no files matched glob patterns"
+ }
+
+ return $result
+}
@@ -447,7 +447,7 @@ static int file_cmd_type(Jim_Interp *interp, int argc, Jim_Obj *const *argv) if (file_lstat(interp, argv[0], &sb) != JIM_OK) { return JIM_ERR; } - Jim_SetIntResult(interp, sb.st_mode); + Jim_SetResultString(interp, GetFileType((int)sb.st_mode), -1); return JIM_OK; } diff --git a/stdio.tcl b/stdio.tcl new file mode 100644 index 0000000..a6e9f97 --- /dev/null +++ b/stdio.tcl @@ -0,0 +1,71 @@ +# (c) 2008 Steve Bennett <steveb@workware.net.au> +# +# Implements Tcl-compatible IO commands based on the aio package +# +# Provides puts, gets, open, close, eof, flush, seek, tell + +package provide stdio 1.0 +catch {package require aio 1.0} + +# Remove the builtin puts +rename puts "" + +set stdio::stdin [aio.open standard input] +set stdio::stdout [aio.open standard output] +set stdio::stderr [aio.open standard error] +set stdio::std_channel_map [list stdin ${stdio::stdin} stdout ${stdio::stdout} stderr ${stdio::stderr}] + +proc stdio::std_channel {channel} { + global _stdmap + return [string map ${::stdio::std_channel_map} $channel] +} + +proc puts {channel args} { + set nonewline 0 + if {$channel eq "-nonewline"} { + set nonewline 1 + set channel [lindex $args 0] + set args [lrange $args 1 end] + } + if {[llength $args] == 0} { + set args [list $channel] + set channel stdout + } + + set channel [stdio::std_channel $channel] + + if {$nonewline} { + $channel puts -nonewline {expand}$args + } else { + $channel puts {expand}$args + } +} + +proc gets {channel args} { + set channel [stdio::std_channel $channel] + return [uplevel 1 [list $channel gets {expand}$args]] +} + +proc open {file args} { + return [aio.open $file {expand}$args] +} + +proc close {channel} { + [stdio::std_channel $channel] close +} + +proc eof {channel} { + [stdio::std_channel $channel] eof +} + +proc flush {channel} { + [stdio::std_channel $channel] flush +} + +proc seek {channel args} { + [stdio::std_channel $channel] seek {expand}$args +} + +proc tell {channel} { + [stdio::std_channel $channel] tell +} diff --git a/tcl6.tcl b/tcl6.tcl new file mode 100644 index 0000000..d62b895 --- /dev/null +++ b/tcl6.tcl @@ -0,0 +1,100 @@ +# (c) 2008 Steve Bennett <steveb@workware.net.au> +# +# Loads a Tcl6-compatible environment plus some newer features, +# including stdio, array, file, clock, glob, regexp, regsub, lsearch, case, ::env + +package provide tcl6 1.0 + +package require stdio + +# Extremely simple autoload approach +set autoload {glob glob array array} + +proc unknown {cmd args} { + if {[info exists ::autoload($cmd)]} { + package require $::autoload($cmd) + return [uplevel 1 $cmd $args] + } + error "invalid command name \"$cmd\"" +} + +# Set up the ::env array +set env [env] + +# Very basic lsearch -exact with no options +proc lsearch {list value} { + set i 0 + foreach elem $list { + if {$elem eq $value} { + return $i + } + incr i + } + return -1 +} + +# Internal function to match a value agains a list of patterns +proc _case_search_patterns {patterns value} { + set i 0 + foreach pattern $patterns { + if {[string match $pattern $value]} { + return $i + } + incr i + } + return -1 +} + +# case var ?in? pattern action ?pattern action ...? +proc case {var args} { + # Skip dummy parameter + if {[lindex $args 0] eq "in"} { + set args [lrange $args 1 end] + } + + # Check for single arg form + if {[llength $args] == 1} { + set args [lindex $args 0] + } + + # Check for odd number of args + if {[llength $args] % 2 != 0} { + error "extra case pattern with no body" + } + + #puts "looking for $var in '$args'" + foreach {value action} $args { + if {$value eq "default"} { + set do_action $action + continue + } else { + if {[_case_search_patterns $value $var] >= 0} { + set do_action $action + break + } + } + } + + if {[info exists do_action]} { + return [uplevel 1 $do_action] + } +} + +# Optional argument is a glob pattern +proc parray {arrayname {pattern *}} { + upvar $arrayname a + + set max 0 + foreach name [array names a $pattern]] { + if {[string length $name] > $max} { + set max [string length $name] + } + } + incr max [string length $arrayname] + incr max 2 + foreach name [lsort [array names a $pattern]] { + puts [format "%-${max}s = $a($name)" $arrayname\($name\)] + } +} + +set ::tcl_platform(platform) unix |