155 changed files with 99394 additions and 10955 deletions
@ -0,0 +1,271 @@
|
||||
# ascii85.tcl -- |
||||
# |
||||
# Encode/Decode ascii85 for a string |
||||
# |
||||
# Copyright (c) Emiliano Gavilan |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
|
||||
package require Tcl 8.4 |
||||
|
||||
namespace eval ascii85 { |
||||
namespace export encode encodefile decode |
||||
# default values for encode options |
||||
variable options |
||||
array set options [list -wrapchar \n -maxlen 76] |
||||
} |
||||
|
||||
# ::ascii85::encode -- |
||||
# |
||||
# Ascii85 encode a given string. |
||||
# |
||||
# Arguments: |
||||
# args ?-maxlen maxlen? ?-wrapchar wrapchar? string |
||||
# |
||||
# If maxlen is 0, the output is not wrapped. |
||||
# |
||||
# Results: |
||||
# A Ascii85 encoded version of $string, wrapped at $maxlen characters |
||||
# by $wrapchar. |
||||
|
||||
proc ascii85::encode {args} { |
||||
variable options |
||||
|
||||
set alen [llength $args] |
||||
if {$alen != 1 && $alen != 3 && $alen != 5} { |
||||
return -code error "wrong # args:\ |
||||
should be \"[lindex [info level 0] 0]\ |
||||
?-maxlen maxlen?\ |
||||
?-wrapchar wrapchar? string\"" |
||||
} |
||||
|
||||
set data [lindex $args end] |
||||
array set opts [array get options] |
||||
array set opts [lrange $args 0 end-1] |
||||
foreach key [array names opts] { |
||||
if {[lsearch -exact [array names options] $key] == -1} { |
||||
return -code error "unknown option \"$key\":\ |
||||
must be -maxlen or -wrapchar" |
||||
} |
||||
} |
||||
|
||||
if {![string is integer -strict $opts(-maxlen)] |
||||
|| $opts(-maxlen) < 0} { |
||||
return -code error "expected positive integer but got\ |
||||
\"$opts(-maxlen)\"" |
||||
} |
||||
|
||||
# perform this check early |
||||
if {[string length $data] == 0} { |
||||
return "" |
||||
} |
||||
|
||||
# shorten the names |
||||
set ml $opts(-maxlen) |
||||
set wc $opts(-wrapchar) |
||||
|
||||
# if maxlen is zero, don't wrap the output |
||||
if {$ml == 0} { |
||||
set wc "" |
||||
} |
||||
|
||||
set encoded {} |
||||
|
||||
binary scan $data c* X |
||||
set len [llength $X] |
||||
set rest [expr {$len % 4}] |
||||
set lastidx [expr {$len - $rest - 1}] |
||||
|
||||
foreach {b1 b2 b3 b4} [lrange $X 0 $lastidx] { |
||||
# calculate the 32 bit value |
||||
# this is an inlined version of the [encode4bytes] proc |
||||
# included here for performance reasons |
||||
set val [expr { |
||||
( (($b1 & 0xff) << 24) |
||||
|(($b2 & 0xff) << 16) |
||||
|(($b3 & 0xff) << 8) |
||||
| ($b4 & 0xff) |
||||
) & 0xffffffff }] |
||||
|
||||
if {$val == 0} { |
||||
# four \0 bytes encodes as "z" instead of "!!!!!" |
||||
append current "z" |
||||
} else { |
||||
# no magic numbers here. |
||||
# 52200625 -> 85 ** 4 |
||||
# 614125 -> 85 ** 3 |
||||
# 7225 -> 85 ** 2 |
||||
append current [binary format ccccc \ |
||||
[expr { ( $val / 52200625) + 33 }] \ |
||||
[expr { (($val % 52200625) / 614125) + 33 }] \ |
||||
[expr { (($val % 614125) / 7225) + 33 }] \ |
||||
[expr { (($val % 7225) / 85) + 33 }] \ |
||||
[expr { ( $val % 85) + 33 }]] |
||||
} |
||||
|
||||
if {[string length $current] >= $ml} { |
||||
append encoded [string range $current 0 [expr {$ml - 1}]] $wc |
||||
set current [string range $current $ml end] |
||||
} |
||||
} |
||||
|
||||
if { $rest } { |
||||
# there are remaining bytes. |
||||
# pad with \0 and encode not using the "z" convention. |
||||
# finally, add ($rest + 1) chars. |
||||
set val 0 |
||||
foreach {b1 b2 b3 b4} [pad [lrange $X [incr lastidx] end] 4 0] break |
||||
append current [string range [encode4bytes $b1 $b2 $b3 $b4] 0 $rest] |
||||
} |
||||
append encoded [regsub -all -- ".{$ml}" $current "&$wc"] |
||||
|
||||
return $encoded |
||||
} |
||||
|
||||
proc ascii85::encode4bytes {b1 b2 b3 b4} { |
||||
set val [expr { |
||||
( (($b1 & 0xff) << 24) |
||||
|(($b2 & 0xff) << 16) |
||||
|(($b3 & 0xff) << 8) |
||||
| ($b4 & 0xff) |
||||
) & 0xffffffff }] |
||||
return [binary format ccccc \ |
||||
[expr { ( $val / 52200625) + 33 }] \ |
||||
[expr { (($val % 52200625) / 614125) + 33 }] \ |
||||
[expr { (($val % 614125) / 7225) + 33 }] \ |
||||
[expr { (($val % 7225) / 85) + 33 }] \ |
||||
[expr { ( $val % 85) + 33 }]] |
||||
} |
||||
|
||||
# ::ascii85::encodefile -- |
||||
# |
||||
# Ascii85 encode the contents of a file using default values |
||||
# for maxlen and wrapchar parameters. |
||||
# |
||||
# Arguments: |
||||
# fname The name of the file to encode. |
||||
# |
||||
# Results: |
||||
# An Ascii85 encoded version of the contents of the file. |
||||
# This is a convenience command |
||||
|
||||
proc ascii85::encodefile {fname} { |
||||
set fd [open $fname] |
||||
fconfigure $fd -encoding binary -translation binary |
||||
return [encode [read $fd]][close $fd] |
||||
} |
||||
|
||||
# ::ascii85::decode -- |
||||
# |
||||
# Ascii85 decode a given string. |
||||
# |
||||
# Arguments: |
||||
# string The string to decode. |
||||
# Leading spaces and tabs are removed, along with trailing newlines |
||||
# |
||||
# Results: |
||||
# The decoded value. |
||||
|
||||
proc ascii85::decode {data} { |
||||
# get rid of leading spaces/tabs and trailing newlines |
||||
set data [string map [list \n {} \t {} { } {}] $data] |
||||
set len [string length $data] |
||||
|
||||
# perform this ckeck early |
||||
if {! $len} { |
||||
return "" |
||||
} |
||||
|
||||
set decoded {} |
||||
set count 0 |
||||
set group [list] |
||||
binary scan $data c* X |
||||
|
||||
foreach char $X { |
||||
# we must check that every char is in the allowed range |
||||
if {$char < 33 || $char > 117 } { |
||||
# "z" is an exception |
||||
if {$char == 122} { |
||||
if {$count == 0} { |
||||
# if a "z" char appears at the beggining of a group, |
||||
# it decodes as four null bytes |
||||
append decoded \x00\x00\x00\x00 |
||||
continue |
||||
} else { |
||||
# if not, is an error |
||||
return -code error \ |
||||
"error decoding data: \"z\" char misplaced" |
||||
} |
||||
} |
||||
# char is not in range and not a "z" at the beggining of a group |
||||
return -code error \ |
||||
"error decoding data: chars outside the allowed range" |
||||
} |
||||
|
||||
lappend group $char |
||||
incr count |
||||
if {$count == 5} { |
||||
# this is an inlined version of the [decode5chars] proc |
||||
# included here for performance reasons |
||||
set val [expr { |
||||
([lindex $group 0] - 33) * wide(52200625) + |
||||
([lindex $group 1] - 33) * 614125 + |
||||
([lindex $group 2] - 33) * 7225 + |
||||
([lindex $group 3] - 33) * 85 + |
||||
([lindex $group 4] - 33) }] |
||||
if {$val > 0xffffffff} { |
||||
return -code error "error decoding data: decoded group overflow" |
||||
} else { |
||||
append decoded [binary format I $val] |
||||
incr count -5 |
||||
set group [list] |
||||
} |
||||
} |
||||
} |
||||
|
||||
set len [llength $group] |
||||
switch -- $len { |
||||
0 { |
||||
# all input has been consumed |
||||
# do nothing |
||||
} |
||||
1 { |
||||
# a single char is a condition error, there should be at least 2 |
||||
return -code error \ |
||||
"error decoding data: trailing char" |
||||
} |
||||
default { |
||||
# pad with "u"s, decode and add ($len - 1) bytes |
||||
append decoded [string range \ |
||||
[decode5chars [pad $group 5 122]] \ |
||||
0 \ |
||||
[expr {$len - 2}]] |
||||
} |
||||
} |
||||
|
||||
return $decoded |
||||
} |
||||
|
||||
proc ascii85::decode5chars {group} { |
||||
set val [expr { |
||||
([lindex $group 0] - 33) * wide(52200625) + |
||||
([lindex $group 1] - 33) * 614125 + |
||||
([lindex $group 2] - 33) * 7225 + |
||||
([lindex $group 3] - 33) * 85 + |
||||
([lindex $group 4] - 33) }] |
||||
if {$val > 0xffffffff} { |
||||
return -code error "error decoding data: decoded group overflow" |
||||
} |
||||
|
||||
return [binary format I $val] |
||||
} |
||||
|
||||
proc ascii85::pad {chars len padchar} { |
||||
while {[llength $chars] < $len} { |
||||
lappend chars $padchar |
||||
} |
||||
|
||||
return $chars |
||||
} |
||||
|
||||
package provide ascii85 1.0 |
||||
@ -0,0 +1,410 @@
|
||||
# base64.tcl -- |
||||
# |
||||
# Encode/Decode base64 for a string |
||||
# Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems |
||||
# The decoder was done for exmh by Chris Garrigues |
||||
# |
||||
# Copyright (c) 1998-2000 by Ajuba Solutions. |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
|
||||
# Version 1.0 implemented Base64_Encode, Base64_Decode |
||||
# Version 2.0 uses the base64 namespace |
||||
# Version 2.1 fixes various decode bugs and adds options to encode |
||||
# Version 2.2 is much faster, Tcl8.0 compatible |
||||
# Version 2.2.1 bugfixes |
||||
# Version 2.2.2 bugfixes |
||||
# Version 2.3 bugfixes and extended to support Trf |
||||
# Version 2.4.x bugfixes |
||||
|
||||
# @mdgen EXCLUDE: base64c.tcl |
||||
|
||||
package require Tcl 8.2 |
||||
namespace eval ::base64 { |
||||
namespace export encode decode |
||||
} |
||||
|
||||
package provide base64 2.5 |
||||
|
||||
if {[package vsatisfies [package require Tcl] 8.6]} { |
||||
proc ::base64::encode {args} { |
||||
binary encode base64 -maxlen 76 {*}$args |
||||
} |
||||
|
||||
proc ::base64::decode {string} { |
||||
# Tcllib is strict with respect to end of input, yet lax for |
||||
# invalid characters outside of that. |
||||
regsub -all -- {[^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/]} $string {} string |
||||
binary decode base64 -strict $string |
||||
} |
||||
|
||||
return |
||||
} |
||||
|
||||
if {![catch {package require Trf 2.0}]} { |
||||
# Trf is available, so implement the functionality provided here |
||||
# in terms of calls to Trf for speed. |
||||
|
||||
# ::base64::encode -- |
||||
# |
||||
# Base64 encode a given string. |
||||
# |
||||
# Arguments: |
||||
# args ?-maxlen maxlen? ?-wrapchar wrapchar? string |
||||
# |
||||
# If maxlen is 0, the output is not wrapped. |
||||
# |
||||
# Results: |
||||
# A Base64 encoded version of $string, wrapped at $maxlen characters |
||||
# by $wrapchar. |
||||
|
||||
proc ::base64::encode {args} { |
||||
# Set the default wrapchar and maximum line length to match |
||||
# the settings for MIME encoding (RFC 3548, RFC 2045). These |
||||
# are the settings used by Trf as well. Various RFCs allow for |
||||
# different wrapping characters and wraplengths, so these may |
||||
# be overridden by command line options. |
||||
set wrapchar "\n" |
||||
set maxlen 76 |
||||
|
||||
if { [llength $args] == 0 } { |
||||
error "wrong # args: should be \"[lindex [info level 0] 0]\ |
||||
?-maxlen maxlen? ?-wrapchar wrapchar? string\"" |
||||
} |
||||
|
||||
set optionStrings [list "-maxlen" "-wrapchar"] |
||||
for {set i 0} {$i < [llength $args] - 1} {incr i} { |
||||
set arg [lindex $args $i] |
||||
set index [lsearch -glob $optionStrings "${arg}*"] |
||||
if { $index == -1 } { |
||||
error "unknown option \"$arg\": must be -maxlen or -wrapchar" |
||||
} |
||||
incr i |
||||
if { $i >= [llength $args] - 1 } { |
||||
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 |
||||
} |
||||
|
||||
# [string is] requires Tcl8.2; this works with 8.0 too |
||||
if {[catch {expr {$maxlen % 2}}]} { |
||||
return -code error "expected integer but got \"$maxlen\"" |
||||
} elseif {$maxlen < 0} { |
||||
return -code error "expected positive integer but got \"$maxlen\"" |
||||
} |
||||
|
||||
set string [lindex $args end] |
||||
set result [::base64 -mode encode -- $string] |
||||
|
||||
# Trf's encoder implicitly uses the settings -maxlen 76, |
||||
# -wrapchar \n for its output. We may have to reflow this for |
||||
# the settings chosen by the user. A second difference is that |
||||
# Trf closes the output with the wrap char sequence, |
||||
# always. The code here doesn't. Therefore 'trimright' is |
||||
# needed in the fast cases. |
||||
|
||||
if {($maxlen == 76) && [string equal $wrapchar \n]} { |
||||
# Both maxlen and wrapchar are identical to Trf's |
||||
# settings. This is the super-fast case, because nearly |
||||
# nothing has to be done. Only thing to do is strip a |
||||
# terminating wrapchar. |
||||
set result [string trimright $result] |
||||
} elseif {$maxlen == 76} { |
||||
# wrapchar has to be different here, length is the |
||||
# same. We can use 'string map' to transform the wrap |
||||
# information. |
||||
set result [string map [list \n $wrapchar] \ |
||||
[string trimright $result]] |
||||
} elseif {$maxlen == 0} { |
||||
# Have to reflow the output to no wrapping. Another fast |
||||
# case using only 'string map'. 'trimright' is not needed |
||||
# here. |
||||
|
||||
set result [string map [list \n ""] $result] |
||||
} else { |
||||
# Have to reflow the output from 76 to the chosen maxlen, |
||||
# and possibly change the wrap sequence as well. |
||||
|
||||
# Note: After getting rid of the old wrap sequence we |
||||
# extract the relevant segments from the string without |
||||
# modifying the string. Modification, i.e. removal of the |
||||
# processed part, means 'shifting down characters in |
||||
# memory', making the algorithm O(n^2). By avoiding the |
||||
# modification we stay in O(n). |
||||
|
||||
set result [string map [list \n ""] $result] |
||||
set l [expr {[string length $result]-$maxlen}] |
||||
for {set off 0} {$off < $l} {incr off $maxlen} { |
||||
append res [string range $result $off [expr {$off+$maxlen-1}]] $wrapchar |
||||
} |
||||
append res [string range $result $off end] |
||||
set result $res |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
# ::base64::decode -- |
||||
# |
||||
# Base64 decode a given string. |
||||
# |
||||
# Arguments: |
||||
# string The string to decode. Characters not in the base64 |
||||
# alphabet are ignored (e.g., newlines) |
||||
# |
||||
# Results: |
||||
# The decoded value. |
||||
|
||||
proc ::base64::decode {string} { |
||||
regsub -all {\s} $string {} string |
||||
::base64 -mode decode -- $string |
||||
} |
||||
|
||||
} else { |
||||
# Without Trf use a pure tcl implementation |
||||
|
||||
namespace eval base64 { |
||||
variable base64 {} |
||||
variable base64_en {} |
||||
|
||||
# We create the auxiliary array base64_tmp, it will be unset later. |
||||
variable base64_tmp |
||||
variable i |
||||
|
||||
set i 0 |
||||
foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \ |
||||
a b c d e f g h i j k l m n o p q r s t u v w x y z \ |
||||
0 1 2 3 4 5 6 7 8 9 + /} { |
||||
set base64_tmp($char) $i |
||||
lappend base64_en $char |
||||
incr i |
||||
} |
||||
|
||||
# |
||||
# Create base64 as list: to code for instance C<->3, specify |
||||
# that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded |
||||
# ascii chars get a {}. we later use the fact that lindex on a |
||||
# non-existing index returns {}, and that [expr {} < 0] is true |
||||
# |
||||
|
||||
# the last ascii char is 'z' |
||||
variable char |
||||
variable len |
||||
variable val |
||||
|
||||
scan z %c len |
||||
for {set i 0} {$i <= $len} {incr i} { |
||||
set char [format %c $i] |
||||
set val {} |
||||
if {[info exists base64_tmp($char)]} { |
||||
set val $base64_tmp($char) |
||||
} else { |
||||
set val {} |
||||
} |
||||
lappend base64 $val |
||||
} |
||||
|
||||
# code the character "=" as -1; used to signal end of message |
||||
scan = %c i |
||||
set base64 [lreplace $base64 $i $i -1] |
||||
|
||||
# remove unneeded variables |
||||
unset base64_tmp i char len val |
||||
|
||||
namespace export encode decode |
||||
} |
||||
|
||||
# ::base64::encode -- |
||||
# |
||||
# Base64 encode a given string. |
||||
# |
||||
# Arguments: |
||||
# args ?-maxlen maxlen? ?-wrapchar wrapchar? string |
||||
# |
||||
# If maxlen is 0, the output is not wrapped. |
||||
# |
||||
# Results: |
||||
# A Base64 encoded version of $string, wrapped at $maxlen characters |
||||
# by $wrapchar. |
||||
|
||||
proc ::base64::encode {args} { |
||||
set base64_en $::base64::base64_en |
||||
|
||||
# Set the default wrapchar and maximum line length to match |
||||
# the settings for MIME encoding (RFC 3548, RFC 2045). These |
||||
# are the settings used by Trf as well. Various RFCs allow for |
||||
# different wrapping characters and wraplengths, so these may |
||||
# be overridden by command line options. |
||||
set wrapchar "\n" |
||||
set maxlen 76 |
||||
|
||||
if { [llength $args] == 0 } { |
||||
error "wrong # args: should be \"[lindex [info level 0] 0]\ |
||||
?-maxlen maxlen? ?-wrapchar wrapchar? string\"" |
||||
} |
||||
|
||||
set optionStrings [list "-maxlen" "-wrapchar"] |
||||
for {set i 0} {$i < [llength $args] - 1} {incr i} { |
||||
set arg [lindex $args $i] |
||||
set index [lsearch -glob $optionStrings "${arg}*"] |
||||
if { $index == -1 } { |
||||
error "unknown option \"$arg\": must be -maxlen or -wrapchar" |
||||
} |
||||
incr i |
||||
if { $i >= [llength $args] - 1 } { |
||||
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 |
||||
} |
||||
|
||||
# [string is] requires Tcl8.2; this works with 8.0 too |
||||
if {[catch {expr {$maxlen % 2}}]} { |
||||
return -code error "expected integer but got \"$maxlen\"" |
||||
} elseif {$maxlen < 0} { |
||||
return -code error "expected positive integer but got \"$maxlen\"" |
||||
} |
||||
|
||||
set string [lindex $args end] |
||||
|
||||
set result {} |
||||
set state 0 |
||||
set length 0 |
||||
|
||||
|
||||
# Process the input bytes 3-by-3 |
||||
|
||||
binary scan $string c* X |
||||
|
||||
foreach {x y z} $X { |
||||
ADD [lindex $base64_en [expr {($x >>2) & 0x3F}]] |
||||
if {$y != {}} { |
||||
ADD [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]] |
||||
if {$z != {}} { |
||||
ADD [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]] |
||||
ADD [lindex $base64_en [expr {($z & 0x3F)}]] |
||||
} else { |
||||
set state 2 |
||||
break |
||||
} |
||||
} else { |
||||
set state 1 |
||||
break |
||||
} |
||||
} |
||||
if {$state == 1} { |
||||
ADD [lindex $base64_en [expr {(($x << 4) & 0x30)}]] |
||||
ADD = |
||||
ADD = |
||||
} elseif {$state == 2} { |
||||
ADD [lindex $base64_en [expr {(($y << 2) & 0x3C)}]] |
||||
ADD = |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
proc ::base64::ADD {x} { |
||||
# The line length check is always done before appending so |
||||
# that we don't get an extra newline if the output is a |
||||
# multiple of $maxlen chars long. |
||||
|
||||
upvar 1 maxlen maxlen length length result result wrapchar wrapchar |
||||
if {$maxlen && $length >= $maxlen} { |
||||
append result $wrapchar |
||||
set length 0 |
||||
} |
||||
append result $x |
||||
incr length |
||||
return |
||||
} |
||||
|
||||
# ::base64::decode -- |
||||
# |
||||
# Base64 decode a given string. |
||||
# |
||||
# Arguments: |
||||
# string The string to decode. Characters not in the base64 |
||||
# alphabet are ignored (e.g., newlines) |
||||
# |
||||
# Results: |
||||
# The decoded value. |
||||
|
||||
proc ::base64::decode {string} { |
||||
if {[string length $string] == 0} {return ""} |
||||
|
||||
set base64 $::base64::base64 |
||||
set output "" ; # Fix for [Bug 821126] |
||||
set nums {} |
||||
|
||||
binary scan $string c* X |
||||
lappend X 61 ;# force a terminator |
||||
foreach x $X { |
||||
set bits [lindex $base64 $x] |
||||
if {$bits >= 0} { |
||||
if {[llength [lappend nums $bits]] == 4} { |
||||
foreach {v w z y} $nums break |
||||
set a [expr {($v << 2) | ($w >> 4)}] |
||||
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 {} |
||||
} |
||||
} elseif {$bits == -1} { |
||||
# = indicates end of data. Output whatever chars are |
||||
# left, if any. |
||||
if {![llength $nums]} break |
||||
# The encoding algorithm dictates that we can only |
||||
# have 1 or 2 padding characters. If x=={}, we must |
||||
# (*) have 12 bits of input (enough for 1 8-bit |
||||
# output). If x!={}, we have 18 bits of input (enough |
||||
# for 2 8-bit outputs). |
||||
# |
||||
# (*) If we don't then the input is broken (bug 2976290). |
||||
|
||||
foreach {v w z} $nums break |
||||
|
||||
# Bug 2976290 |
||||
if {$w == {}} { |
||||
return -code error "Not enough data to process padding" |
||||
} |
||||
|
||||
set a [expr {($v << 2) | (($w & 0x30) >> 4)}] |
||||
if {$z == {}} { |
||||
append output [binary format c $a ] |
||||
} else { |
||||
set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}] |
||||
append output [binary format cc $a $b] |
||||
} |
||||
break |
||||
} else { |
||||
# RFC 2045 says that line breaks and other characters not part |
||||
# of the Base64 alphabet must be ignored, and that the decoder |
||||
# can optionally emit a warning or reject the message. We opt |
||||
# not to do so, but to just ignore the character. |
||||
continue |
||||
} |
||||
} |
||||
return $output |
||||
} |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
return |
||||
|
||||
@ -0,0 +1,19 @@
|
||||
# base64c - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# This package is a place-holder for the critcl enhanced code present in |
||||
# the tcllib base64 module. |
||||
# |
||||
# Normally this code will become part of the tcllibc library. |
||||
# |
||||
|
||||
# @sak notprovided base64c |
||||
package require critcl |
||||
package provide base64c 0.1.0 |
||||
|
||||
namespace eval ::base64c { |
||||
variable base64c_rcsid {$Id: base64c.tcl,v 1.5 2008/03/25 07:15:35 andreas_kupries Exp $} |
||||
|
||||
critcl::ccode { |
||||
/* no code required in this file */ |
||||
} |
||||
} |
||||
@ -0,0 +1,5 @@
|
||||
if {![package vsatisfies [package provide Tcl] 8.2]} {return} |
||||
package ifneeded base64 2.5 [list source [file join $dir base64.tcl]] |
||||
package ifneeded uuencode 1.1.5 [list source [file join $dir uuencode.tcl]] |
||||
package ifneeded yencode 1.1.3 [list source [file join $dir yencode.tcl]] |
||||
package ifneeded ascii85 1.0 [list source [file join $dir ascii85.tcl]] |
||||
@ -0,0 +1,335 @@
|
||||
# uuencode - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# Provide a Tcl only implementation of uuencode and uudecode. |
||||
# |
||||
# ------------------------------------------------------------------------- |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# ------------------------------------------------------------------------- |
||||
|
||||
package require Tcl 8.2; # tcl minimum version |
||||
|
||||
# Try and get some compiled helper package. |
||||
if {[catch {package require tcllibc}]} { |
||||
catch {package require Trf} |
||||
} |
||||
|
||||
namespace eval ::uuencode { |
||||
namespace export encode decode uuencode uudecode |
||||
} |
||||
|
||||
proc ::uuencode::Enc {c} { |
||||
return [format %c [expr {($c != 0) ? (($c & 0x3f) + 0x20) : 0x60}]] |
||||
} |
||||
|
||||
proc ::uuencode::Encode {s} { |
||||
set r {} |
||||
binary scan $s c* d |
||||
foreach {c1 c2 c3} $d { |
||||
if {$c1 == {}} {set c1 0} |
||||
if {$c2 == {}} {set c2 0} |
||||
if {$c3 == {}} {set c3 0} |
||||
append r [Enc [expr {$c1 >> 2}]] |
||||
append r [Enc [expr {(($c1 << 4) & 060) | (($c2 >> 4) & 017)}]] |
||||
append r [Enc [expr {(($c2 << 2) & 074) | (($c3 >> 6) & 003)}]] |
||||
append r [Enc [expr {($c3 & 077)}]] |
||||
} |
||||
return $r |
||||
} |
||||
|
||||
|
||||
proc ::uuencode::Decode {s} { |
||||
if {[string length $s] == 0} {return ""} |
||||
set r {} |
||||
binary scan [pad $s] c* d |
||||
|
||||
foreach {c0 c1 c2 c3} $d { |
||||
append r [format %c [expr {((($c0-0x20)&0x3F) << 2) & 0xFF |
||||
| ((($c1-0x20)&0x3F) >> 4) & 0xFF}]] |
||||
append r [format %c [expr {((($c1-0x20)&0x3F) << 4) & 0xFF |
||||
| ((($c2-0x20)&0x3F) >> 2) & 0xFF}]] |
||||
append r [format %c [expr {((($c2-0x20)&0x3F) << 6) & 0xFF |
||||
| (($c3-0x20)&0x3F) & 0xFF}]] |
||||
} |
||||
return $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# C coded version of the Encode/Decode functions for base64c package. |
||||
# ------------------------------------------------------------------------- |
||||
if {[package provide critcl] != {}} { |
||||
namespace eval ::uuencode { |
||||
critcl::ccode { |
||||
#include <string.h> |
||||
static unsigned char Enc(unsigned char c) { |
||||
return (c != 0) ? ((c & 0x3f) + 0x20) : 0x60; |
||||
} |
||||
} |
||||
critcl::ccommand CEncode {dummy interp objc objv} { |
||||
Tcl_Obj *inputPtr, *resultPtr; |
||||
int len, rlen, xtra; |
||||
unsigned char *input, *p, *r; |
||||
|
||||
if (objc != 2) { |
||||
Tcl_WrongNumArgs(interp, 1, objv, "data"); |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
inputPtr = objv[1]; |
||||
input = Tcl_GetByteArrayFromObj(inputPtr, &len); |
||||
if ((xtra = (3 - (len % 3))) != 3) { |
||||
if (Tcl_IsShared(inputPtr)) |
||||
inputPtr = Tcl_DuplicateObj(inputPtr); |
||||
input = Tcl_SetByteArrayLength(inputPtr, len + xtra); |
||||
memset(input + len, 0, xtra); |
||||
len += xtra; |
||||
} |
||||
|
||||
rlen = (len / 3) * 4; |
||||
resultPtr = Tcl_NewObj(); |
||||
r = Tcl_SetByteArrayLength(resultPtr, rlen); |
||||
memset(r, 0, rlen); |
||||
|
||||
for (p = input; p < input + len; p += 3) { |
||||
char a, b, c; |
||||
a = *p; b = *(p+1), c = *(p+2); |
||||
*r++ = Enc(a >> 2); |
||||
*r++ = Enc(((a << 4) & 060) | ((b >> 4) & 017)); |
||||
*r++ = Enc(((b << 2) & 074) | ((c >> 6) & 003)); |
||||
*r++ = Enc(c & 077); |
||||
} |
||||
Tcl_SetObjResult(interp, resultPtr); |
||||
return TCL_OK; |
||||
} |
||||
|
||||
critcl::ccommand CDecode {dummy interp objc objv} { |
||||
Tcl_Obj *inputPtr, *resultPtr; |
||||
int len, rlen, xtra; |
||||
unsigned char *input, *p, *r; |
||||
|
||||
if (objc != 2) { |
||||
Tcl_WrongNumArgs(interp, 1, objv, "data"); |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
/* if input is not mod 4, extend it with nuls */ |
||||
inputPtr = objv[1]; |
||||
input = Tcl_GetByteArrayFromObj(inputPtr, &len); |
||||
if ((xtra = (4 - (len % 4))) != 4) { |
||||
if (Tcl_IsShared(inputPtr)) |
||||
inputPtr = Tcl_DuplicateObj(inputPtr); |
||||
input = Tcl_SetByteArrayLength(inputPtr, len + xtra); |
||||
memset(input + len, 0, xtra); |
||||
len += xtra; |
||||
} |
||||
|
||||
/* output will be 1/3 smaller than input and a multiple of 3 */ |
||||
rlen = (len / 4) * 3; |
||||
resultPtr = Tcl_NewObj(); |
||||
r = Tcl_SetByteArrayLength(resultPtr, rlen); |
||||
memset(r, 0, rlen); |
||||
|
||||
for (p = input; p < input + len; p += 4) { |
||||
char a, b, c, d; |
||||
a = *p; b = *(p+1), c = *(p+2), d = *(p+3); |
||||
*r++ = (((a - 0x20) & 0x3f) << 2) | (((b - 0x20) & 0x3f) >> 4); |
||||
*r++ = (((b - 0x20) & 0x3f) << 4) | (((c - 0x20) & 0x3f) >> 2); |
||||
*r++ = (((c - 0x20) & 0x3f) << 6) | (((d - 0x20) & 0x3f) ); |
||||
} |
||||
Tcl_SetObjResult(interp, resultPtr); |
||||
return TCL_OK; |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# Description: |
||||
# Permit more tolerant decoding of invalid input strings by padding to |
||||
# a multiple of 4 bytes with nulls. |
||||
# Result: |
||||
# Returns the input string - possibly padded with uuencoded null chars. |
||||
# |
||||
proc ::uuencode::pad {s} { |
||||
if {[set mod [expr {[string length $s] % 4}]] != 0} { |
||||
append s [string repeat "`" [expr {4 - $mod}]] |
||||
} |
||||
return $s |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# If the Trf package is available then we shall use this by default but the |
||||
# Tcllib implementations are always visible if needed (ie: for testing) |
||||
if {[info commands ::uuencode::CDecode] != {}} { |
||||
# tcllib critcl package |
||||
interp alias {} ::uuencode::encode {} ::uuencode::CEncode |
||||
interp alias {} ::uuencode::decode {} ::uuencode::CDecode |
||||
} elseif {[package provide Trf] != {}} { |
||||
proc ::uuencode::encode {s} { |
||||
return [::uuencode -mode encode -- $s] |
||||
} |
||||
proc ::uuencode::decode {s} { |
||||
return [::uuencode -mode decode -- [pad $s]] |
||||
} |
||||
} else { |
||||
# pure-tcl then |
||||
interp alias {} ::uuencode::encode {} ::uuencode::Encode |
||||
interp alias {} ::uuencode::decode {} ::uuencode::Decode |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
proc ::uuencode::uuencode {args} { |
||||
array set opts {mode 0644 filename {} name {}} |
||||
set wrongargs "wrong \# args: should be\ |
||||
\"uuencode ?-name string? ?-mode octal?\ |
||||
(-file filename | ?--? string)\"" |
||||
while {[string match -* [lindex $args 0]]} { |
||||
switch -glob -- [lindex $args 0] { |
||||
-f* { |
||||
if {[llength $args] < 2} { |
||||
return -code error $wrongargs |
||||
} |
||||
set opts(filename) [lindex $args 1] |
||||
set args [lreplace $args 0 0] |
||||
} |
||||
-m* { |
||||
if {[llength $args] < 2} { |
||||
return -code error $wrongargs |
||||
} |
||||
set opts(mode) [lindex $args 1] |
||||
set args [lreplace $args 0 0] |
||||
} |
||||
-n* { |
||||
if {[llength $args] < 2} { |
||||
return -code error $wrongargs |
||||
} |
||||
set opts(name) [lindex $args 1] |
||||
set args [lreplace $args 0 0] |
||||
} |
||||
-- { |
||||
set args [lreplace $args 0 0] |
||||
break |
||||
} |
||||
default { |
||||
return -code error "bad option [lindex $args 0]:\ |
||||
must be -file, -mode, or -name" |
||||
} |
||||
} |
||||
set args [lreplace $args 0 0] |
||||
} |
||||
|
||||
if {$opts(name) == {}} { |
||||
set opts(name) $opts(filename) |
||||
} |
||||
if {$opts(name) == {}} { |
||||
set opts(name) "data.dat" |
||||
} |
||||
|
||||
if {$opts(filename) != {}} { |
||||
set f [open $opts(filename) r] |
||||
fconfigure $f -translation binary |
||||
set data [read $f] |
||||
close $f |
||||
} else { |
||||
if {[llength $args] != 1} { |
||||
return -code error $wrongargs |
||||
} |
||||
set data [lindex $args 0] |
||||
} |
||||
|
||||
set r {} |
||||
append r [format "begin %o %s" $opts(mode) $opts(name)] "\n" |
||||
for {set n 0} {$n < [string length $data]} {incr n 45} { |
||||
set s [string range $data $n [expr {$n + 44}]] |
||||
append r [Enc [string length $s]] |
||||
append r [encode $s] "\n" |
||||
} |
||||
append r "`\nend" |
||||
return $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Description: |
||||
# Perform uudecoding of a file or data. A file may contain more than one |
||||
# encoded data section so the result is a list where each element is a |
||||
# three element list of the provided filename, the suggested mode and the |
||||
# data itself. |
||||
# |
||||
proc ::uuencode::uudecode {args} { |
||||
array set opts {mode 0644 filename {}} |
||||
set wrongargs "wrong \# args: should be \"uudecode (-file filename | ?--? string)\"" |
||||
while {[string match -* [lindex $args 0]]} { |
||||
switch -glob -- [lindex $args 0] { |
||||
-f* { |
||||
if {[llength $args] < 2} { |
||||
return -code error $wrongargs |
||||
} |
||||
set opts(filename) [lindex $args 1] |
||||
set args [lreplace $args 0 0] |
||||
} |
||||
-- { |
||||
set args [lreplace $args 0 0] |
||||
break |
||||
} |
||||
default { |
||||
return -code error "bad option [lindex $args 0]:\ |
||||
must be -file" |
||||
} |
||||
} |
||||
set args [lreplace $args 0 0] |
||||
} |
||||
|
||||
if {$opts(filename) != {}} { |
||||
set f [open $opts(filename) r] |
||||
set data [read $f] |
||||
close $f |
||||
} else { |
||||
if {[llength $args] != 1} { |
||||
return -code error $wrongargs |
||||
} |
||||
set data [lindex $args 0] |
||||
} |
||||
|
||||
set state false |
||||
set result {} |
||||
|
||||
foreach {line} [split $data "\n"] { |
||||
switch -exact -- $state { |
||||
false { |
||||
if {[regexp {^begin ([0-7]+) ([^\s]*)} $line \ |
||||
-> opts(mode) opts(name)]} { |
||||
set state true |
||||
set r {} |
||||
} |
||||
} |
||||
|
||||
true { |
||||
if {[string match "end" $line]} { |
||||
set state false |
||||
lappend result [list $opts(name) $opts(mode) $r] |
||||
} else { |
||||
scan $line %c c |
||||
set n [expr {($c - 0x21)}] |
||||
append r [string range \ |
||||
[decode [string range $line 1 end]] 0 $n] |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
package provide uuencode 1.1.5 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# |
||||
# Local variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
||||
|
||||
@ -0,0 +1,307 @@
|
||||
# yencode.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# Provide a Tcl only implementation of yEnc encoding algorithm |
||||
# |
||||
# ------------------------------------------------------------------------- |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# FUTURE: Rework to allow switching between the tcl/critcl implementations. |
||||
|
||||
package require Tcl 8.2; # tcl minimum version |
||||
catch {package require crc32}; # tcllib 1.1 |
||||
catch {package require tcllibc}; # critcl enhancements for tcllib |
||||
|
||||
namespace eval ::yencode { |
||||
namespace export encode decode yencode ydecode |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
proc ::yencode::Encode {s} { |
||||
set r {} |
||||
binary scan $s c* d |
||||
foreach {c} $d { |
||||
set v [expr {($c + 42) % 256}] |
||||
if {$v == 0x00 || $v == 0x09 || $v == 0x0A |
||||
|| $v == 0x0D || $v == 0x3D} { |
||||
append r "=" |
||||
set v [expr {($v + 64) % 256}] |
||||
} |
||||
append r [format %c $v] |
||||
} |
||||
return $r |
||||
} |
||||
|
||||
proc ::yencode::Decode {s} { |
||||
if {[string length $s] == 0} {return ""} |
||||
set r {} |
||||
set esc 0 |
||||
binary scan $s c* d |
||||
foreach c $d { |
||||
if {$c == 61 && $esc == 0} { |
||||
set esc 1 |
||||
continue |
||||
} |
||||
set v [expr {($c - 42) % 256}] |
||||
if {$esc} { |
||||
set v [expr {($v - 64) % 256}] |
||||
set esc 0 |
||||
} |
||||
append r [format %c $v] |
||||
} |
||||
return $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# C coded versions for critcl built base64c package |
||||
# ------------------------------------------------------------------------- |
||||
|
||||
if {[package provide critcl] != {}} { |
||||
namespace eval ::yencode { |
||||
critcl::ccode { |
||||
#include <string.h> |
||||
} |
||||
critcl::ccommand CEncode {dummy interp objc objv} { |
||||
Tcl_Obj *inputPtr, *resultPtr; |
||||
int len, rlen, xtra; |
||||
unsigned char *input, *p, *r, v; |
||||
|
||||
if (objc != 2) { |
||||
Tcl_WrongNumArgs(interp, 1, objv, "data"); |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
/* fetch the input data */ |
||||
inputPtr = objv[1]; |
||||
input = Tcl_GetByteArrayFromObj(inputPtr, &len); |
||||
|
||||
/* calculate the length of the encoded result */ |
||||
rlen = len; |
||||
for (p = input; p < input + len; p++) { |
||||
v = (*p + 42) % 256; |
||||
if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) |
||||
rlen++; |
||||
} |
||||
|
||||
/* allocate the output buffer */ |
||||
resultPtr = Tcl_NewObj(); |
||||
r = Tcl_SetByteArrayLength(resultPtr, rlen); |
||||
|
||||
/* encode the input */ |
||||
for (p = input; p < input + len; p++) { |
||||
v = (*p + 42) % 256; |
||||
if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) { |
||||
*r++ = '='; |
||||
v = (v + 64) % 256; |
||||
} |
||||
*r++ = v; |
||||
} |
||||
Tcl_SetObjResult(interp, resultPtr); |
||||
return TCL_OK; |
||||
} |
||||
|
||||
critcl::ccommand CDecode {dummy interp objc objv} { |
||||
Tcl_Obj *inputPtr, *resultPtr; |
||||
int len, rlen, esc; |
||||
unsigned char *input, *p, *r, v; |
||||
|
||||
if (objc != 2) { |
||||
Tcl_WrongNumArgs(interp, 1, objv, "data"); |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
/* fetch the input data */ |
||||
inputPtr = objv[1]; |
||||
input = Tcl_GetByteArrayFromObj(inputPtr, &len); |
||||
|
||||
/* allocate the output buffer */ |
||||
resultPtr = Tcl_NewObj(); |
||||
r = Tcl_SetByteArrayLength(resultPtr, len); |
||||
|
||||
/* encode the input */ |
||||
for (p = input, esc = 0, rlen = 0; p < input + len; p++) { |
||||
if (*p == 61 && esc == 0) { |
||||
esc = 1; |
||||
continue; |
||||
} |
||||
v = (*p - 42) % 256; |
||||
if (esc) { |
||||
v = (v - 64) % 256; |
||||
esc = 0; |
||||
} |
||||
*r++ = v; |
||||
rlen++; |
||||
} |
||||
Tcl_SetByteArrayLength(resultPtr, rlen); |
||||
Tcl_SetObjResult(interp, resultPtr); |
||||
return TCL_OK; |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {[info commands ::yencode::CEncode] != {}} { |
||||
interp alias {} ::yencode::encode {} ::yencode::CEncode |
||||
interp alias {} ::yencode::decode {} ::yencode::CDecode |
||||
} else { |
||||
interp alias {} ::yencode::encode {} ::yencode::Encode |
||||
interp alias {} ::yencode::decode {} ::yencode::Decode |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Description: |
||||
# Pop the nth element off a list. Used in options processing. |
||||
# |
||||
proc ::yencode::Pop {varname {nth 0}} { |
||||
upvar $varname args |
||||
set r [lindex $args $nth] |
||||
set args [lreplace $args $nth $nth] |
||||
return $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
proc ::yencode::yencode {args} { |
||||
array set opts {mode 0644 filename {} name {} line 128 crc32 1} |
||||
while {[string match -* [lindex $args 0]]} { |
||||
switch -glob -- [lindex $args 0] { |
||||
-f* { set opts(filename) [Pop args 1] } |
||||
-m* { set opts(mode) [Pop args 1] } |
||||
-n* { set opts(name) [Pop args 1] } |
||||
-l* { set opts(line) [Pop args 1] } |
||||
-c* { set opts(crc32) [Pop args 1] } |
||||
-- { Pop args ; break } |
||||
default { |
||||
set options [join [lsort [array names opts]] ", -"] |
||||
return -code error "bad option [lindex $args 0]:\ |
||||
must be -$options" |
||||
} |
||||
} |
||||
Pop args |
||||
} |
||||
|
||||
if {$opts(name) == {}} { |
||||
set opts(name) $opts(filename) |
||||
} |
||||
if {$opts(name) == {}} { |
||||
set opts(name) "data.dat" |
||||
} |
||||
if {! [string is boolean $opts(crc32)]} { |
||||
return -code error "bad option -crc32: argument must be true or false" |
||||
} |
||||
|
||||
if {$opts(filename) != {}} { |
||||
set f [open $opts(filename) r] |
||||
fconfigure $f -translation binary |
||||
set data [read $f] |
||||
close $f |
||||
} else { |
||||
if {[llength $args] != 1} { |
||||
return -code error "wrong \# args: should be\ |
||||
\"yencode ?options? -file name | data\"" |
||||
} |
||||
set data [lindex $args 0] |
||||
} |
||||
|
||||
set opts(size) [string length $data] |
||||
|
||||
set r {} |
||||
append r [format "=ybegin line=%d size=%d name=%s" \ |
||||
$opts(line) $opts(size) $opts(name)] "\n" |
||||
|
||||
set ndx 0 |
||||
while {$ndx < $opts(size)} { |
||||
set pln [string range $data $ndx [expr {$ndx + $opts(line) - 1}]] |
||||
set enc [encode $pln] |
||||
incr ndx [string length $pln] |
||||
append r $enc "\r\n" |
||||
} |
||||
|
||||
append r [format "=yend size=%d" $ndx] |
||||
if {$opts(crc32)} { |
||||
append r " crc32=" [crc::crc32 -format %x $data] |
||||
} |
||||
return $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Description: |
||||
# Perform ydecoding of a file or data. A file may contain more than one |
||||
# encoded data section so the result is a list where each element is a |
||||
# three element list of the provided filename, the file size and the |
||||
# data itself. |
||||
# |
||||
proc ::yencode::ydecode {args} { |
||||
array set opts {mode 0644 filename {} name default.bin} |
||||
while {[string match -* [lindex $args 0]]} { |
||||
switch -glob -- [lindex $args 0] { |
||||
-f* { set opts(filename) [Pop args 1] } |
||||
-- { Pop args ; break; } |
||||
default { |
||||
set options [join [lsort [array names opts]] ", -"] |
||||
return -code error "bad option [lindex $args 0]:\ |
||||
must be -$opts" |
||||
} |
||||
} |
||||
Pop args |
||||
} |
||||
|
||||
if {$opts(filename) != {}} { |
||||
set f [open $opts(filename) r] |
||||
set data [read $f] |
||||
close $f |
||||
} else { |
||||
if {[llength $args] != 1} { |
||||
return -code error "wrong \# args: should be\ |
||||
\"ydecode ?options? -file name | data\"" |
||||
} |
||||
set data [lindex $args 0] |
||||
} |
||||
|
||||
set state false |
||||
set result {} |
||||
|
||||
foreach {line} [split $data "\n"] { |
||||
set line [string trimright $line "\r\n"] |
||||
switch -exact -- $state { |
||||
false { |
||||
if {[string match "=ybegin*" $line]} { |
||||
regexp {line=(\d+)} $line -> opts(line) |
||||
regexp {size=(\d+)} $line -> opts(size) |
||||
regexp {name=(\d+)} $line -> opts(name) |
||||
|
||||
if {$opts(name) == {}} { |
||||
set opts(name) default.bin |
||||
} |
||||
|
||||
set state true |
||||
set r {} |
||||
} |
||||
} |
||||
|
||||
true { |
||||
if {[string match "=yend*" $line]} { |
||||
set state false |
||||
lappend result [list $opts(name) $opts(size) $r] |
||||
} else { |
||||
append r [decode $line] |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
package provide yencode 1.1.3 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# |
||||
# Local variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
||||
|
||||
@ -0,0 +1,72 @@
|
||||
# ascaller.tcl - |
||||
# |
||||
# A few utility procs that manage the evaluation of a command |
||||
# or a script in the context of a caller, taking care of all |
||||
# the ugly details of proper return codes, errorcodes, and |
||||
# a good stack trace in ::errorInfo as appropriate. |
||||
# ------------------------------------------------------------------------- |
||||
# |
||||
# RCS: @(#) $Id: ascaller.tcl,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $ |
||||
|
||||
namespace eval ::control { |
||||
|
||||
proc CommandAsCaller {cmdVar resultVar {where {}} {codeVar code}} { |
||||
set x [expr {[string equal "" $where] |
||||
? {} : [subst -nobackslashes {\n ($where)}]}] |
||||
set script [subst -nobackslashes -nocommands { |
||||
set $codeVar [catch {uplevel 1 $$cmdVar} $resultVar] |
||||
if {$$codeVar > 1} { |
||||
return -code $$codeVar $$resultVar |
||||
} |
||||
if {$$codeVar == 1} { |
||||
if {[string equal {"uplevel 1 $$cmdVar"} \ |
||||
[lindex [split [set ::errorInfo] \n] end]]} { |
||||
set $codeVar [join \ |
||||
[lrange [split [set ::errorInfo] \n] 0 \ |
||||
end-[expr {4+[llength [split $$cmdVar \n]]}]] \n] |
||||
} else { |
||||
set $codeVar [join \ |
||||
[lrange [split [set ::errorInfo] \n] 0 end-1] \n] |
||||
} |
||||
return -code error -errorcode [set ::errorCode] \ |
||||
-errorinfo "$$codeVar$x" $$resultVar |
||||
} |
||||
}] |
||||
return $script |
||||
} |
||||
|
||||
proc BodyAsCaller {bodyVar resultVar codeVar {where {}}} { |
||||
set x [expr {[string equal "" $where] |
||||
? {} : [subst -nobackslashes -nocommands \ |
||||
{\n ($where[string map {{ ("uplevel"} {}} \ |
||||
[lindex [split [set ::errorInfo] \n] end]]}]}] |
||||
set script [subst -nobackslashes -nocommands { |
||||
set $codeVar [catch {uplevel 1 $$bodyVar} $resultVar] |
||||
if {$$codeVar == 1} { |
||||
if {[string equal {"uplevel 1 $$bodyVar"} \ |
||||
[lindex [split [set ::errorInfo] \n] end]]} { |
||||
set ::errorInfo [join \ |
||||
[lrange [split [set ::errorInfo] \n] 0 end-2] \n] |
||||
} |
||||
set $codeVar [join \ |
||||
[lrange [split [set ::errorInfo] \n] 0 end-1] \n] |
||||
return -code error -errorcode [set ::errorCode] \ |
||||
-errorinfo "$$codeVar$x" $$resultVar |
||||
} |
||||
}] |
||||
return $script |
||||
} |
||||
|
||||
proc ErrorInfoAsCaller {find replace} { |
||||
set info $::errorInfo |
||||
set i [string last "\n (\"$find" $info] |
||||
if {$i == -1} {return $info} |
||||
set result [string range $info 0 [incr i 6]] ;# keep "\n (\"" |
||||
append result $replace ;# $find -> $replace |
||||
incr i [string length $find] |
||||
set j [string first ) $info [incr i]] ;# keep rest of parenthetical |
||||
append result [string range $info $i $j] |
||||
return $result |
||||
} |
||||
|
||||
} |
||||
@ -0,0 +1,91 @@
|
||||
# assert.tcl -- |
||||
# |
||||
# The [assert] command of the package "control". |
||||
# |
||||
# RCS: @(#) $Id: assert.tcl,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $ |
||||
|
||||
namespace eval ::control { |
||||
|
||||
namespace eval assert { |
||||
namespace export EnabledAssert DisabledAssert |
||||
variable CallbackCmd [list return -code error] |
||||
|
||||
namespace import [namespace parent]::no-op |
||||
rename no-op DisabledAssert |
||||
|
||||
proc EnabledAssert {expr args} { |
||||
variable CallbackCmd |
||||
|
||||
set code [catch {uplevel 1 [list expr $expr]} res] |
||||
if {$code} { |
||||
return -code $code $res |
||||
} |
||||
if {![string is boolean -strict $res]} { |
||||
return -code error "invalid boolean expression: $expr" |
||||
} |
||||
if {$res} {return} |
||||
if {[llength $args]} { |
||||
set msg [join $args] |
||||
} else { |
||||
set msg "assertion failed: $expr" |
||||
} |
||||
# Might want to catch this |
||||
namespace eval :: $CallbackCmd [list $msg] |
||||
} |
||||
|
||||
proc enabled {args} { |
||||
set n [llength $args] |
||||
if {$n > 1} { |
||||
return -code error "wrong # args: should be\ |
||||
\"[lindex [info level 0] 0] ?boolean?\"" |
||||
} |
||||
if {$n} { |
||||
set val [lindex $args 0] |
||||
if {![string is boolean -strict $val]} { |
||||
return -code error "invalid boolean value: $val" |
||||
} |
||||
if {$val} { |
||||
[namespace parent]::AssertSwitch Disabled Enabled |
||||
} else { |
||||
[namespace parent]::AssertSwitch Enabled Disabled |
||||
} |
||||
} else { |
||||
return [string equal [namespace origin EnabledAssert] \ |
||||
[namespace origin [namespace parent]::assert]] |
||||
} |
||||
return "" |
||||
} |
||||
|
||||
proc callback {args} { |
||||
set n [llength $args] |
||||
if {$n > 1} { |
||||
return -code error "wrong # args: should be\ |
||||
\"[lindex [info level 0] 0] ?command?\"" |
||||
} |
||||
if {$n} { |
||||
return [variable CallbackCmd [lindex $args 0]] |
||||
} |
||||
variable CallbackCmd |
||||
return $CallbackCmd |
||||
} |
||||
|
||||
} |
||||
|
||||
proc AssertSwitch {old new} { |
||||
if {[string equal [namespace origin assert] \ |
||||
[namespace origin assert::${new}Assert]]} {return} |
||||
rename assert ${old}Assert |
||||
rename ${new}Assert assert |
||||
} |
||||
|
||||
namespace import assert::DisabledAssert assert::EnabledAssert |
||||
|
||||
# For indexer |
||||
proc assert args # |
||||
rename assert {} |
||||
|
||||
# Initial default: disabled asserts |
||||
rename DisabledAssert assert |
||||
|
||||
} |
||||
|
||||
@ -0,0 +1,24 @@
|
||||
# control.tcl -- |
||||
# |
||||
# This is the main package provide script for the package |
||||
# "control". It provides commands that govern the flow of |
||||
# control of a program. |
||||
|
||||
package require Tcl 8.5 9 |
||||
|
||||
namespace eval ::control { |
||||
namespace export assert control do no-op rswitch |
||||
|
||||
proc control {command args} { |
||||
# Need to add error handling here |
||||
namespace eval [list $command] $args |
||||
} |
||||
|
||||
# Set up for auto-loading the commands |
||||
variable home [file join [pwd] [file dirname [info script]]] |
||||
if {[lsearch -exact $::auto_path $home] == -1} { |
||||
lappend ::auto_path $home |
||||
} |
||||
|
||||
package provide [namespace tail [namespace current]] 0.1.4 |
||||
} |
||||
@ -0,0 +1,81 @@
|
||||
# do.tcl -- |
||||
# |
||||
# Tcl implementation of a "do ... while|until" loop. |
||||
# |
||||
# Originally written for the "Texas Tcl Shootout" programming contest |
||||
# at the 2000 Tcl Conference in Austin/Texas. |
||||
# |
||||
# Copyright (c) 2001 by Reinhard Max <Reinhard.Max@gmx.de> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: do.tcl,v 1.6 2004/01/15 06:36:12 andreas_kupries Exp $ |
||||
# |
||||
namespace eval ::control { |
||||
|
||||
proc do {body args} { |
||||
|
||||
# |
||||
# Implements a "do body while|until test" loop |
||||
# |
||||
# It is almost as fast as builtin "while" command for loops with |
||||
# more than just a few iterations. |
||||
# |
||||
|
||||
set len [llength $args] |
||||
if {$len !=2 && $len != 0} { |
||||
set proc [namespace current]::[lindex [info level 0] 0] |
||||
return -code error "wrong # args: should be \"$proc body\" or \"$proc body \[until|while\] test\"" |
||||
} |
||||
set test 0 |
||||
foreach {whileOrUntil test} $args { |
||||
switch -exact -- $whileOrUntil { |
||||
"while" {} |
||||
"until" { set test !($test) } |
||||
default { |
||||
return -code error \ |
||||
"bad option \"$whileOrUntil\": must be until, or while" |
||||
} |
||||
} |
||||
break |
||||
} |
||||
|
||||
# the first invocation of the body |
||||
set code [catch { uplevel 1 $body } result] |
||||
|
||||
# decide what to do upon the return code: |
||||
# |
||||
# 0 - the body executed successfully |
||||
# 1 - the body raised an error |
||||
# 2 - the body invoked [return] |
||||
# 3 - the body invoked [break] |
||||
# 4 - the body invoked [continue] |
||||
# everything else - return and pass on the results |
||||
# |
||||
switch -exact -- $code { |
||||
0 {} |
||||
1 { |
||||
return -errorinfo [ErrorInfoAsCaller uplevel do] \ |
||||
-errorcode $::errorCode -code error $result |
||||
} |
||||
3 { |
||||
# FRINK: nocheck |
||||
return |
||||
} |
||||
4 {} |
||||
default { |
||||
return -code $code $result |
||||
} |
||||
} |
||||
# the rest of the loop |
||||
set code [catch {uplevel 1 [list while $test $body]} result] |
||||
if {$code == 1} { |
||||
return -errorinfo [ErrorInfoAsCaller while do] \ |
||||
-errorcode $::errorCode -code error $result |
||||
} |
||||
return -code $code $result |
||||
|
||||
} |
||||
|
||||
} |
||||
@ -0,0 +1,14 @@
|
||||
# no-op.tcl -- |
||||
# |
||||
# The [no-op] command of the package "control". |
||||
# It accepts any number of arguments and does nothing. |
||||
# It returns an empty string. |
||||
# |
||||
# RCS: @(#) $Id: no-op.tcl,v 1.2 2004/01/15 06:36:12 andreas_kupries Exp $ |
||||
|
||||
namespace eval ::control { |
||||
|
||||
proc no-op args {} |
||||
|
||||
} |
||||
|
||||
@ -0,0 +1,2 @@
|
||||
if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} |
||||
package ifneeded control 0.1.4 [list source [file join $dir control.tcl]] |
||||
@ -0,0 +1,18 @@
|
||||
# Tcl autoload index file, version 2.0 |
||||
# This file is generated by the "auto_mkindex" command |
||||
# and sourced to set up indexing information for one or |
||||
# more commands. Typically each line is a command that |
||||
# sets an element in the auto_index array, where the |
||||
# element name is the name of a command and the value is |
||||
# a script that loads the command. |
||||
|
||||
set auto_index(::control::CommandAsCaller) [list source [file join $dir ascaller.tcl]] |
||||
set auto_index(::control::BodyAsCaller) [list source [file join $dir ascaller.tcl]] |
||||
set auto_index(::control::ErrorInfoAsCaller) [list source [file join $dir ascaller.tcl]] |
||||
set auto_index(::control::assert::EnabledAssert) [list source [file join $dir assert.tcl]] |
||||
set auto_index(::control::assert::enabled) [list source [file join $dir assert.tcl]] |
||||
set auto_index(::control::assert::callback) [list source [file join $dir assert.tcl]] |
||||
set auto_index(::control::AssertSwitch) [list source [file join $dir assert.tcl]] |
||||
set auto_index(::control::assert) [list source [file join $dir assert.tcl]] |
||||
set auto_index(::control::do) [list source [file join $dir do.tcl]] |
||||
set auto_index(::control::no-op) [list source [file join $dir no-op.tcl]] |
||||
@ -0,0 +1,97 @@
|
||||
## -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
## Utility command for use as debug prefix command to un-mangle snit |
||||
## and TclOO method calls. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5 |
||||
package require debug |
||||
|
||||
namespace eval ::debug { |
||||
namespace export caller |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API & Implementation |
||||
|
||||
proc ::debug::caller {args} { |
||||
# For snit (type)methods, rework the command line to be more |
||||
# legible and in line with what the user would expect. To this end |
||||
# we pull the primary command out of the arguments, be it type or |
||||
# object, massage the command to match the original (type)method |
||||
# name, then resort and expand the words to match the call before |
||||
# the snit got its claws into it. |
||||
|
||||
set a [lassign [info level -1] m] |
||||
regsub {.*Snit_} $m {} m |
||||
|
||||
if {[string match ::oo::Obj*::my $m]} { |
||||
# TclOO call. |
||||
set m [uplevel 1 self] |
||||
return [list $m {*}[Filter $a $args]] |
||||
} |
||||
if {$m eq "my"} { |
||||
# TclOO call. |
||||
set m [uplevel 1 self] |
||||
return [list $m {*}[Filter $a $args]] |
||||
} |
||||
|
||||
switch -glob -- $m { |
||||
htypemethod* { |
||||
# primary = type, a = type |
||||
set a [lassign $a primary] |
||||
set m [string map {_ { }} [string range $m 11 end]] |
||||
} |
||||
typemethod* { |
||||
# primary = type, a = type |
||||
set a [lassign $a primary] |
||||
set m [string range $m 10 end] |
||||
} |
||||
hmethod* { |
||||
# primary = self, a = type selfns self win ... |
||||
set a [lassign $a _ _ primary _] |
||||
set m [string map {_ { }} [string range $m 7 end]] |
||||
} |
||||
method* { |
||||
# primary = self, a = type selfns self win ... |
||||
set a [lassign $a _ _ primary _] |
||||
set m [string range $m 6 end] |
||||
} |
||||
destructor - |
||||
constructor { |
||||
# primary = self, a = type selfns self win ... |
||||
set a [lassign $a _ _ primary _] |
||||
} |
||||
typeconstructor { |
||||
return [list {*}$a $m] |
||||
} |
||||
default { |
||||
# Unknown |
||||
return [list $m {*}[Filter $a $args]] |
||||
} |
||||
} |
||||
return [list $primary {*}$m {*}[Filter $a $args]] |
||||
} |
||||
|
||||
proc ::debug::Filter {args droplist} { |
||||
if {[llength $droplist]} { |
||||
# Replace unwanted arguments with '*'. This is usually done |
||||
# for arguments which can be large Tcl values. These would |
||||
# screw up formatting and, to add insult to this injury, also |
||||
# repeat for each debug output in the same proc, method, etc. |
||||
foreach i [lsort -integer $droplist] { |
||||
set args [lreplace $args $i $i *] |
||||
} |
||||
} |
||||
return $args |
||||
} |
||||
|
||||
# ### ######### ########################### |
||||
## Ready for use |
||||
|
||||
package provide debug::caller 1.1 |
||||
return |
||||
@ -0,0 +1,306 @@
|
||||
# Debug - a debug narrative logger. |
||||
# -- Colin McCormack / originally Wub server utilities |
||||
# |
||||
# Debugging areas of interest are represented by 'tokens' which have |
||||
# independantly settable levels of interest (an integer, higher is more detailed) |
||||
# |
||||
# Debug narrative is provided as a tcl script whose value is [subst]ed in the |
||||
# caller's scope if and only if the current level of interest matches or exceeds |
||||
# the Debug call's level of detail. This is useful, as one can place arbitrarily |
||||
# complex narrative in code without unnecessarily evaluating it. |
||||
# |
||||
# TODO: potentially different streams for different areas of interest. |
||||
# (currently only stderr is used. there is some complexity in efficient |
||||
# cross-threaded streams.) |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5 |
||||
|
||||
namespace eval ::debug { |
||||
namespace export -clear \ |
||||
define on off prefix suffix header trailer \ |
||||
names 2array level setting parray pdict \ |
||||
nl tab hexl |
||||
namespace ensemble create -subcommands {} |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## API & Implementation |
||||
|
||||
proc ::debug::noop {args} {} |
||||
|
||||
proc ::debug::debug {tag message {level 1}} { |
||||
variable detail |
||||
if {$detail($tag) < $level} { |
||||
#puts stderr "$tag @@@ $detail($tag) >= $level" |
||||
return |
||||
} |
||||
|
||||
variable prefix |
||||
variable suffix |
||||
variable header |
||||
variable trailer |
||||
variable fds |
||||
|
||||
if {[info exists fds($tag)]} { |
||||
set fd $fds($tag) |
||||
} else { |
||||
set fd stderr |
||||
} |
||||
|
||||
# Assemble the shown text from the user message and the various |
||||
# prefixes and suffices (global + per-tag). |
||||
|
||||
set themessage "" |
||||
if {[info exists prefix(::)]} { append themessage $prefix(::) } |
||||
if {[info exists prefix($tag)]} { append themessage $prefix($tag) } |
||||
append themessage $message |
||||
if {[info exists suffix($tag)]} { append themessage $suffix($tag) } |
||||
if {[info exists suffix(::)]} { append themessage $suffix(::) } |
||||
|
||||
# Resolve variables references and command invokations embedded |
||||
# into the message with plain text. |
||||
set code [catch { |
||||
set smessage [uplevel 1 [list ::subst -nobackslashes $themessage]] |
||||
set sheader [uplevel 1 [list ::subst -nobackslashes $header]] |
||||
set strailer [uplevel 1 [list ::subst -nobackslashes $trailer]] |
||||
} __ eo] |
||||
|
||||
# And dump an internal error if that resolution failed. |
||||
if {$code} { |
||||
if {[catch { |
||||
set caller [info level -1] |
||||
}]} { set caller GLOBAL } |
||||
if {[string length $caller] >= 1000} { |
||||
set caller "[string range $caller 0 200]...[string range $caller end-200 end]" |
||||
} |
||||
foreach line [split $caller \n] { |
||||
puts -nonewline $fd "@@(DebugError from $tag ($eo): $line)" |
||||
} |
||||
return |
||||
} |
||||
|
||||
# From here we have a good message to show. We only shorten it a |
||||
# bit if its a bit excessive in size. |
||||
|
||||
if {[string length $smessage] > 4096} { |
||||
set head [string range $smessage 0 2048] |
||||
set tail [string range $smessage end-2048 end] |
||||
set smessage "${head}...(truncated)...$tail" |
||||
} |
||||
|
||||
foreach line [split $smessage \n] { |
||||
puts $fd "$sheader$tag | $line$strailer" |
||||
} |
||||
return |
||||
} |
||||
|
||||
# names - return names of debug tags |
||||
proc ::debug::names {} { |
||||
variable detail |
||||
return [lsort [array names detail]] |
||||
} |
||||
|
||||
proc ::debug::2array {} { |
||||
variable detail |
||||
set result {} |
||||
foreach n [lsort [array names detail]] { |
||||
if {[interp alias {} debug.$n] ne "::debug::noop"} { |
||||
lappend result $n $detail($n) |
||||
} else { |
||||
lappend result $n -$detail($n) |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# level - set level and fd for tag |
||||
proc ::debug::level {tag {level ""} {fd {}}} { |
||||
variable detail |
||||
# TODO: Force level >=0. |
||||
if {$level ne ""} { |
||||
set detail($tag) $level |
||||
} |
||||
|
||||
if {![info exists detail($tag)]} { |
||||
set detail($tag) 1 |
||||
} |
||||
|
||||
variable fds |
||||
if {$fd ne {}} { |
||||
set fds($tag) $fd |
||||
} |
||||
|
||||
return $detail($tag) |
||||
} |
||||
|
||||
proc ::debug::header {text} { variable header $text } |
||||
proc ::debug::trailer {text} { variable trailer $text } |
||||
|
||||
proc ::debug::define {tag} { |
||||
if {[interp alias {} debug.$tag] ne {}} return |
||||
off $tag |
||||
return |
||||
} |
||||
|
||||
# Set a prefix/suffix to use for tag. |
||||
# The global (tag-independent) prefix/suffix is adressed through tag '::'. |
||||
# This works because colon (:) is an illegal character for user-specified tags. |
||||
|
||||
proc ::debug::prefix {tag {theprefix {}}} { |
||||
variable prefix |
||||
set prefix($tag) $theprefix |
||||
|
||||
if {[interp alias {} debug.$tag] ne {}} return |
||||
off $tag |
||||
return |
||||
} |
||||
|
||||
proc ::debug::suffix {tag {theprefix {}}} { |
||||
variable suffix |
||||
set suffix($tag) $theprefix |
||||
|
||||
if {[interp alias {} debug.$tag] ne {}} return |
||||
off $tag |
||||
return |
||||
} |
||||
|
||||
# turn on debugging for tag |
||||
proc ::debug::on {tag {level ""} {fd {}}} { |
||||
variable active |
||||
set active($tag) 1 |
||||
level $tag $level $fd |
||||
interp alias {} debug.$tag {} ::debug::debug $tag |
||||
return |
||||
} |
||||
|
||||
# turn off debugging for tag |
||||
proc ::debug::off {tag {level ""} {fd {}}} { |
||||
variable active |
||||
set active($tag) 1 |
||||
level $tag $level $fd |
||||
interp alias {} debug.$tag {} ::debug::noop |
||||
return |
||||
} |
||||
|
||||
proc ::debug::setting {args} { |
||||
if {[llength $args] == 1} { |
||||
set args [lindex $args 0] |
||||
} |
||||
set fd stderr |
||||
if {[llength $args] % 2} { |
||||
set fd [lindex $args end] |
||||
set args [lrange $args 0 end-1] |
||||
} |
||||
foreach {tag level} $args { |
||||
if {$level > 0} { |
||||
level $tag $level $fd |
||||
interp alias {} debug.$tag {} ::debug::debug $tag |
||||
} else { |
||||
level $tag [expr {-$level}] $fd |
||||
interp alias {} debug.$tag {} ::debug::noop |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Convenience commands. |
||||
# Format arrays and dicts as multi-line message. |
||||
# Insert newlines and tabs. |
||||
|
||||
proc ::debug::nl {} { return \n } |
||||
proc ::debug::tab {} { return \t } |
||||
|
||||
proc ::debug::parray {a {pattern *}} { |
||||
upvar 1 $a array |
||||
if {![array exists array]} { |
||||
error "\"$a\" isn't an array" |
||||
} |
||||
pdict [array get array] $pattern |
||||
} |
||||
|
||||
proc ::debug::pdict {dict {pattern *}} { |
||||
set maxl 0 |
||||
set names [lsort -dict [dict keys $dict $pattern]] |
||||
foreach name $names { |
||||
if {[string length $name] > $maxl} { |
||||
set maxl [string length $name] |
||||
} |
||||
} |
||||
set maxl [expr {$maxl + 2}] |
||||
set lines {} |
||||
foreach name $names { |
||||
set nameString [format (%s) $name] |
||||
lappend lines [format "%-*s = %s" \ |
||||
$maxl $nameString \ |
||||
[dict get $dict $name]] |
||||
} |
||||
return [join $lines \n] |
||||
} |
||||
|
||||
proc ::debug::hexl {data {prefix {}}} { |
||||
set r {} |
||||
|
||||
# Convert the data to hex and to characters. |
||||
binary scan $data H*@0a* hexa asciia |
||||
|
||||
# Replace non-printing characters in the data with dots. |
||||
regsub -all -- {[^[:graph:] ]} $asciia {.} asciia |
||||
|
||||
# Pad with spaces to a full multiple of 32/16. |
||||
set n [expr {[string length $hexa] % 32}] |
||||
if {$n < 32} { append hexa [string repeat { } [expr {32-$n}]] } |
||||
#puts "pad H [expr {32-$n}]" |
||||
|
||||
set n [expr {[string length $asciia] % 32}] |
||||
if {$n < 16} { append asciia [string repeat { } [expr {16-$n}]] } |
||||
#puts "pad A [expr {32-$n}]" |
||||
|
||||
# Reassemble formatted, in groups of 16 bytes/characters. |
||||
# The hex part is handled in groups of 32 nibbles. |
||||
set addr 0 |
||||
while {[string length $hexa]} { |
||||
# Get front group of 16 bytes each. |
||||
set hex [string range $hexa 0 31] |
||||
set ascii [string range $asciia 0 15] |
||||
# Prep for next iteration |
||||
set hexa [string range $hexa 32 end] |
||||
set asciia [string range $asciia 16 end] |
||||
|
||||
# Convert the hex to pairs of hex digits |
||||
regsub -all -- {..} $hex {& } hex |
||||
|
||||
# Add the hex and latin-1 data to the result buffer |
||||
append r $prefix [format %04x $addr] { | } $hex { |} $ascii |\n |
||||
incr addr 16 |
||||
} |
||||
|
||||
# And done |
||||
return $r |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
|
||||
namespace eval debug { |
||||
variable detail ; # map: TAG -> level of interest |
||||
variable prefix ; # map: TAG -> message prefix to use |
||||
variable suffix ; # map: TAG -> message suffix to use |
||||
variable fds ; # map: TAG -> handle of open channel to log to. |
||||
variable header {} ; # per-line heading, subst'ed |
||||
variable trailer {} ; # per-line ending, subst'ed |
||||
|
||||
# Notes: |
||||
# - The tag '::' is reserved. "prefix" and "suffix" use it to store |
||||
# the global message prefix / suffix. |
||||
# - prefix and suffix are applied per message. |
||||
# - header and trailer are per line. And should not generate multiple lines! |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Ready |
||||
|
||||
package provide debug 1.0.6 |
||||
return |
||||
@ -0,0 +1,68 @@
|
||||
# -*- tcl -* |
||||
# Debug -- Heartbeat. Track operation of Tcl's eventloop. |
||||
# -- Colin McCormack / originally Wub server utilities |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5 |
||||
package require debug |
||||
|
||||
namespace eval ::debug { |
||||
namespace export heartbeat |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## API & Implementation |
||||
|
||||
proc ::debug::heartbeat {{delta 500}} { |
||||
variable duration $delta |
||||
variable timer |
||||
|
||||
if {$duration > 0} { |
||||
# stop a previous heartbeat before starting the next |
||||
catch { after cancel $timer } |
||||
on heartbeat |
||||
::debug::every $duration { |
||||
debug.heartbeat {[::debug::pulse]} |
||||
} |
||||
} else { |
||||
catch { after cancel $timer } |
||||
off heartbeat |
||||
} |
||||
} |
||||
|
||||
proc ::debug::every {ms body} { |
||||
eval $body |
||||
variable timer [after $ms [info level 0]] |
||||
return |
||||
} |
||||
|
||||
proc ::debug::pulse {} { |
||||
variable duration |
||||
variable hbtimer |
||||
variable heartbeat |
||||
|
||||
set now [::tcl::clock::milliseconds] |
||||
set diff [expr {$now - $hbtimer - $duration}] |
||||
|
||||
set hbtimer $now |
||||
|
||||
return [list [incr heartbeat] $diff] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
|
||||
namespace eval ::debug { |
||||
variable duration 0 ; # milliseconds between heart-beats |
||||
variable heartbeat 0 ; # beat counter |
||||
variable hbtimer [::tcl::clock::milliseconds] |
||||
variable timer |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Ready |
||||
|
||||
package provide debug::heartbeat 1.0.1 |
||||
return |
||||
@ -0,0 +1,5 @@
|
||||
if {![package vsatisfies [package require Tcl] 8.5]} return |
||||
package ifneeded debug 1.0.6 [list source [file join $dir debug.tcl]] |
||||
package ifneeded debug::heartbeat 1.0.1 [list source [file join $dir heartbeat.tcl]] |
||||
package ifneeded debug::timestamp 1 [list source [file join $dir timestamp.tcl]] |
||||
package ifneeded debug::caller 1.1 [list source [file join $dir caller.tcl]] |
||||
@ -0,0 +1,47 @@
|
||||
# -*- tcl -* |
||||
# Debug -- Timestamps. |
||||
# -- Colin McCormack / originally Wub server utilities |
||||
# |
||||
# Generate timestamps for debug messages. |
||||
# The provided commands are for use in prefixes and headers. |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5 |
||||
package require debug |
||||
|
||||
namespace eval ::debug { |
||||
namespace export timestamp |
||||
namespace ensemble create |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## API & Implementation |
||||
|
||||
proc ::debug::timestamp {} { |
||||
variable timestamp::delta |
||||
variable timestamp::baseline |
||||
|
||||
set now [::tcl::clock::milliseconds] |
||||
if {$delta} { |
||||
set time "${now}-[expr {$now - $delta}]mS " |
||||
} else { |
||||
set time "${now}mS " |
||||
} |
||||
set delta $now |
||||
return $time |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
|
||||
namespace eval ::debug::timestamp { |
||||
variable delta 0 |
||||
variable baseline [::tcl::clock::milliseconds] |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Ready |
||||
|
||||
package provide debug::timestamp 1 |
||||
return |
||||
@ -0,0 +1,207 @@
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Copyright (c) 2008-2009 ActiveState Software Inc., Andreas Kupries |
||||
## 2016 Andreas Kupries |
||||
## BSD License |
||||
## |
||||
# Package to help the writing of file decoders. Provides generic |
||||
# low-level support commands. |
||||
|
||||
package require Tcl 8.5 9 |
||||
|
||||
namespace eval ::fileutil::decode { |
||||
namespace export mark go rewind at |
||||
namespace export byte short-le long-le nbytes skip |
||||
namespace export unsigned match recode getval |
||||
namespace export clear get put putloc setbuf |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
proc ::fileutil::decode::open {fname} { |
||||
variable chan |
||||
set chan [::open $fname r] |
||||
fconfigure $chan \ |
||||
-translation binary \ |
||||
-encoding binary \ |
||||
-eofchar {} |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::close {} { |
||||
variable chan |
||||
::close $chan |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
proc ::fileutil::decode::mark {} { |
||||
variable chan |
||||
variable mark |
||||
set mark [tell $chan] |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::go {to} { |
||||
variable chan |
||||
seek $chan $to start |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::rewind {} { |
||||
variable chan |
||||
variable mark |
||||
if {$mark == {}} { |
||||
return -code error \ |
||||
-errorcode {FILE DECODE NO MARK} \ |
||||
"No mark to rewind to" |
||||
} |
||||
seek $chan $mark start |
||||
set mark {} |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::at {} { |
||||
variable chan |
||||
return [tell $chan] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
proc ::fileutil::decode::byte {} { |
||||
variable chan |
||||
variable mask 0xff |
||||
variable val [read $chan 1] |
||||
binary scan $val c val |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::short-le {} { |
||||
variable chan |
||||
variable mask 0xffff |
||||
variable val [read $chan 2] |
||||
binary scan $val s val |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::long-le {} { |
||||
variable chan |
||||
variable mask 0xffffffff |
||||
variable val [read $chan 4] |
||||
binary scan $val i val |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::nbytes {n} { |
||||
variable chan |
||||
variable mask {} |
||||
variable val [read $chan $n] |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::skip {n} { |
||||
variable chan |
||||
#read $chan $n |
||||
seek $chan $n current |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
proc ::fileutil::decode::unsigned {} { |
||||
variable val |
||||
if {$val >= 0} return |
||||
variable mask |
||||
if {$mask eq {}} { |
||||
return -code error \ |
||||
-errorcode {FILE DECODE ILLEGAL UNSIGNED} \ |
||||
"Unsigned not possible here" |
||||
} |
||||
set val [format %u [expr {$val & $mask}]] |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::match {eval} { |
||||
variable val |
||||
|
||||
#puts "Match: Expected $eval, Got: [format 0x%08x $val]" |
||||
|
||||
if {$val == $eval} {return 1} |
||||
rewind |
||||
return 0 |
||||
} |
||||
|
||||
proc ::fileutil::decode::recode {cmdpfx} { |
||||
variable val |
||||
lappend cmdpfx $val |
||||
set val [uplevel 1 $cmdpfx] |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::getval {} { |
||||
variable val |
||||
return $val |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
proc ::fileutil::decode::clear {} { |
||||
variable buf {} |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::get {} { |
||||
variable buf |
||||
return $buf |
||||
} |
||||
|
||||
proc ::fileutil::decode::setbuf {list} { |
||||
variable buf $list |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::put {name} { |
||||
variable buf |
||||
variable val |
||||
lappend buf $name $val |
||||
return |
||||
} |
||||
|
||||
proc ::fileutil::decode::putloc {name} { |
||||
variable buf |
||||
variable chan |
||||
lappend buf $name [tell $chan] |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
namespace eval ::fileutil::decode { |
||||
# Stream to read from |
||||
variable chan {} |
||||
|
||||
# Last value read from the stream, or modified through decoder |
||||
# operations. |
||||
variable val {} |
||||
|
||||
# Remembered location in the stream |
||||
variable mark {} |
||||
|
||||
# Buffer for accumulating structured results |
||||
variable buf {} |
||||
|
||||
# Mask for trimming a value to unsigned. |
||||
# Size-dependent |
||||
variable mask {} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
package provide fileutil::decode 0.2.2 |
||||
return |
||||
@ -0,0 +1,28 @@
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
# (c) 2007 Andreas Kupries. |
||||
|
||||
# Multi file operations. Singleton based on the multiop processor. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
package require fileutil::multi::op |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API & Implementation |
||||
|
||||
namespace eval ::fileutil {} |
||||
|
||||
# Create the multiop processor object and make its do method the main |
||||
# command of this package. |
||||
::fileutil::multi::op ::fileutil::multi::obj |
||||
|
||||
proc ::fileutil::multi {args} { |
||||
return [uplevel 1 [linsert $args 0 ::fileutil::multi::obj do]] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide fileutil::multi 0.2 |
||||
@ -0,0 +1,645 @@
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
# (c) 2007-2008 Andreas Kupries. |
||||
|
||||
# DSL allowing the easy specification of multi-file copy and/or move |
||||
# and/or deletion operations. Alternate names would be scatter/gather |
||||
# processor, or maybe even assembler. |
||||
|
||||
# Examples: |
||||
# (1) copy |
||||
# into [installdir_of tls] |
||||
# from c:/TDK/PrivateOpenSSL/bin |
||||
# the *.dll |
||||
# |
||||
# (2) move |
||||
# from /sources |
||||
# into /scratch |
||||
# the * |
||||
# but not *.html |
||||
# (Alternatively: except for *.html) |
||||
# |
||||
# (3) into /scratch |
||||
# from /sources |
||||
# move |
||||
# as pkgIndex.tcl |
||||
# the index |
||||
# |
||||
# (4) in /scratch |
||||
# remove |
||||
# the *.txt |
||||
|
||||
# The language is derived from the parts of TclApp's option language |
||||
# dealing with files and their locations, yet not identical. In parts |
||||
# simplified, in parts more capable, keyword names were changed |
||||
# throughout. |
||||
|
||||
# Language commands |
||||
|
||||
# From the examples |
||||
# |
||||
# into DIR : Specify destination directory. |
||||
# in DIR : See 'into'. |
||||
# from DIR : Specify source directory. |
||||
# the PATTERN (...) : Specify files to operate on. |
||||
# but not PATTERN : Specify exceptions to 'the'. |
||||
# but exclude PATTERN : Specify exceptions to 'the'. |
||||
# except for PATTERN : See 'but not'. |
||||
# as NAME : New name for file. |
||||
# move : Move files. |
||||
# copy : Copy files. |
||||
# remove : Delete files. |
||||
# |
||||
# Furthermore |
||||
# |
||||
# reset : Force to defaults. |
||||
# cd DIR : Change destination to subdirectory. |
||||
# up : Change destination to parent directory. |
||||
# ( : Save a copy of the current state. |
||||
# ) : Restore last saved state and make it current. |
||||
|
||||
# The main active element is the command 'the'. In other words, this |
||||
# command not only specifies the files to operate on, but also |
||||
# executes the operation as defined in the current state. All other |
||||
# commands modify the state to set the operation up, and nothing |
||||
# else. To allow for a more natural syntax the active command also |
||||
# looks ahead for the commands 'as', 'but', and 'except', and executes |
||||
# them, like qualifiers, so that they take effect as if they had been |
||||
# written before. The command 'but' and 'except use identical |
||||
# constructions to handle their qualifiers, i.e. 'not' and 'for'. |
||||
|
||||
# Note that the fact that most commands just modify the state allows |
||||
# us to use more off forms as specifications instead of just natural |
||||
# language sentences For example the example 2 can re-arranged into: |
||||
# |
||||
# (5) from /sources |
||||
# into /scratch |
||||
# but not *.html |
||||
# move |
||||
# the * |
||||
# |
||||
# and the result is still a valid specification. |
||||
|
||||
# Further note that the information collected by 'but', 'except', and |
||||
# 'as' is automatically reset after the associated 'the' was |
||||
# executed. However no other state is reset in that manner, allowing |
||||
# the user to avoid repetitions of unchanging information. Lets us for |
||||
# example merge the examples 2 and 3. The trivial merge is: |
||||
|
||||
# (6) move |
||||
# into /scratch |
||||
# from /sources |
||||
# the * |
||||
# but not *.html not index |
||||
# move |
||||
# into /scratch |
||||
# from /sources |
||||
# the index |
||||
# as pkgIndex.tcl |
||||
# |
||||
# With less repetitions |
||||
# |
||||
# (7) move |
||||
# into /scratch |
||||
# from /sources |
||||
# the * |
||||
# but not *.html not index |
||||
# the index |
||||
# as pkgIndex.tcl |
||||
|
||||
# I have not yet managed to find a suitable syntax to specify when to |
||||
# add a new extension to the moved/copied files, or have to strip all |
||||
# extensions, a specific extension, or even replace extensions. |
||||
|
||||
# Other possibilities to muse about: Load the patterns for 'not'/'for' |
||||
# from a file ... Actually, load the whole exceptions from a file, |
||||
# with its contents a proper interpretable word list. Which makes it |
||||
# general processing of include files. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
# This processor uses the 'wip' word list interpreter as its |
||||
# foundation. |
||||
|
||||
package require fileutil ; # File testing |
||||
package require snit ; # OO support |
||||
package require struct::stack ; # Context stack |
||||
package require wip ; # DSL execution core |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API & Implementation |
||||
|
||||
snit::type ::fileutil::multi::op { |
||||
# ### ### ### ######### ######### ######### |
||||
## API |
||||
|
||||
constructor {args} {} ; # create processor |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API - Implementation. |
||||
|
||||
constructor {args} { |
||||
install stack using struct::stack ${selfns}::stack |
||||
$self wip_setup |
||||
|
||||
# Mapping dsl commands to methods. |
||||
defdva \ |
||||
reset Reset ( Push ) Pop \ |
||||
into Into in Into from From \ |
||||
cd ChDir up ChUp as As \ |
||||
move Move copy Copy remove Remove \ |
||||
but But not Exclude the The \ |
||||
except Except for Exclude exclude Exclude \ |
||||
to Into -> Save the-set TheSet \ |
||||
recursive Recursive recursively Recursive \ |
||||
for-win ForWindows for-unix ForUnix \ |
||||
for-windows ForWindows expand Expand \ |
||||
invoke Invoke strict Strict !strict NotStrict \ |
||||
files Files links Links all Everything \ |
||||
dirs Directories directories Directories \ |
||||
state? QueryState from? QueryFrom into? QueryInto \ |
||||
excluded? QueryExcluded as? QueryAs type? QueryType \ |
||||
recursive? QueryRecursive operation? QueryOperation \ |
||||
strict? QueryStrict !recursive NotRecursive |
||||
|
||||
$self Reset |
||||
runl $args |
||||
return |
||||
} |
||||
|
||||
destructor { |
||||
$mywip destroy |
||||
return |
||||
} |
||||
|
||||
method do {args} { |
||||
return [runl $args] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## DSL Implementation |
||||
wip::dsl |
||||
|
||||
# General reset of processor state |
||||
method Reset {} { |
||||
$stack clear |
||||
set base "" |
||||
set alias "" |
||||
set op "" |
||||
set recursive 0 |
||||
set src "" |
||||
set excl "" |
||||
set types {} |
||||
set strict 0 |
||||
return |
||||
} |
||||
|
||||
# Stack manipulation |
||||
method Push {} { |
||||
$stack push [list $base $alias $op $opcmd $recursive $src $excl $types $strict] |
||||
return |
||||
} |
||||
|
||||
method Pop {} { |
||||
if {![$stack size]} { |
||||
return -code error {Stack underflow} |
||||
} |
||||
foreach {base alias op opcmd recursive src excl types strict} [$stack pop] break |
||||
return |
||||
} |
||||
|
||||
# Destination directory |
||||
method Into {dir} { |
||||
if {$dir eq ""} {set dir [pwd]} |
||||
if {$strict && ![fileutil::test $dir edr msg {Destination directory}]} { |
||||
return -code error $msg |
||||
} |
||||
set base $dir |
||||
return |
||||
} |
||||
|
||||
method ChDir {dir} { $self Into [file join $base $dir] ; return } |
||||
method ChUp {} { $self Into [file dirname $base] ; return } |
||||
|
||||
# Detail |
||||
method As {fname} { |
||||
set alias [ForceRelative $fname] |
||||
return |
||||
} |
||||
|
||||
# Operations |
||||
method Move {} { set op move ; return } |
||||
method Copy {} { set op copy ; return } |
||||
method Remove {} { set op remove ; return } |
||||
method Expand {} { set op expand ; return } |
||||
|
||||
method Invoke {cmdprefix} { |
||||
set op invoke |
||||
set opcmd $cmdprefix |
||||
return |
||||
} |
||||
|
||||
# Operation qualifier |
||||
method Recursive {} { set recursive 1 ; return } |
||||
method NotRecursive {} { set recursive 0 ; return } |
||||
|
||||
# Source directory |
||||
method From {dir} { |
||||
if {$dir eq ""} {set dir [pwd]} |
||||
if {![fileutil::test $dir edr msg {Source directory}]} { |
||||
return -code error $msg |
||||
} |
||||
set src $dir |
||||
return |
||||
} |
||||
|
||||
# Exceptions |
||||
method But {} { run_next_while {not exclude} ; return } |
||||
method Except {} { run_next_while {for} ; return } |
||||
|
||||
method Exclude {pattern} { |
||||
lappend excl $pattern |
||||
return |
||||
} |
||||
|
||||
# Define the files to operate on, and perform the operation. |
||||
method The {pattern} { |
||||
run_next_while {as but except exclude from into in to files dirs directories links all} |
||||
|
||||
switch -exact -- $op { |
||||
invoke {Invoke [Resolve [Remember [Exclude [Expand $src $pattern]]]]} |
||||
move {Move [Resolve [Remember [Exclude [Expand $src $pattern]]]]} |
||||
copy {Copy [Resolve [Remember [Exclude [Expand $src $pattern]]]]} |
||||
remove {Remove [Remember [Exclude [Expand $base $pattern]]] } |
||||
expand { Remember [Exclude [Expand $base $pattern]] } |
||||
} |
||||
|
||||
# Reset the per-pattern flags of the resolution context back |
||||
# to their defaults, for the next pattern. |
||||
|
||||
set alias {} |
||||
set excl {} |
||||
set recursive 0 |
||||
return |
||||
} |
||||
|
||||
# Like 'The' above, except that the fileset is taken from the |
||||
# specified variable. Semi-complementary to 'Save' below. |
||||
# Exclusion data and recursion info do not apply for this, this is |
||||
# already implicitly covered by the set, when it was generated. |
||||
|
||||
method TheSet {varname} { |
||||
# See 'Save' for the levels we jump here. |
||||
upvar 5 $varname var |
||||
|
||||
run_next_while {as from into in to} |
||||
|
||||
switch -exact -- $op { |
||||
invoke {Invoke [Resolve $var]} |
||||
move {Move [Resolve $var]} |
||||
copy {Copy [Resolve $var]} |
||||
remove {Remove $var } |
||||
expand { |
||||
return -code error "Expansion does not make sense\ |
||||
when we already have a set of files." |
||||
} |
||||
} |
||||
|
||||
# Reset the per-pattern flags of the resolution context back |
||||
# to their defaults, for the next pattern. |
||||
|
||||
set alias {} |
||||
return |
||||
} |
||||
|
||||
# Save the last expansion result to a variable for use by future commands. |
||||
|
||||
method Save {varname} { |
||||
# Levels to jump. Brittle. |
||||
# 5: Caller |
||||
# 4: object do ... |
||||
# 3: runl |
||||
# 2: wip::runl |
||||
# 1: run_next |
||||
# 0: Here |
||||
upvar 5 $varname v |
||||
set v $lastexpansion |
||||
return |
||||
} |
||||
|
||||
# Platform conditionals ... |
||||
|
||||
method ForUnix {} { |
||||
global tcl_platform |
||||
if {$tcl_platform(platform) eq "unix"} return |
||||
# Kill the remaining code. This effectively aborts processing. |
||||
replacel {} |
||||
return |
||||
} |
||||
|
||||
method ForWindows {} { |
||||
global tcl_platform |
||||
if {$tcl_platform(platform) eq "windows"} return |
||||
# Kill the remaining code. This effectively aborts processing. |
||||
replacel {} |
||||
return |
||||
} |
||||
|
||||
# Strictness |
||||
|
||||
method Strict {} { |
||||
set strict 1 |
||||
return |
||||
} |
||||
|
||||
method NotStrict {} { |
||||
set strict 0 |
||||
return |
||||
} |
||||
|
||||
# Type qualifiers |
||||
|
||||
method Files {} { |
||||
set types files |
||||
return |
||||
} |
||||
|
||||
method Links {} { |
||||
set types links |
||||
return |
||||
} |
||||
|
||||
method Directories {} { |
||||
set types dirs |
||||
return |
||||
} |
||||
|
||||
method Everything {} { |
||||
set types {} |
||||
return |
||||
} |
||||
|
||||
# State interogation |
||||
|
||||
method QueryState {} { |
||||
return [list \ |
||||
from $src \ |
||||
into $base \ |
||||
as $alias \ |
||||
op $op \ |
||||
excluded $excl \ |
||||
recursive $recursive \ |
||||
type $types \ |
||||
strict $strict \ |
||||
] |
||||
} |
||||
method QueryExcluded {} { |
||||
return $excl |
||||
} |
||||
method QueryFrom {} { |
||||
return $src |
||||
} |
||||
method QueryInto {} { |
||||
return $base |
||||
} |
||||
method QueryAs {} { |
||||
return $alias |
||||
} |
||||
method QueryOperation {} { |
||||
return $op |
||||
} |
||||
method QueryRecursive {} { |
||||
return $recursive |
||||
} |
||||
method QueryType {} { |
||||
return $types |
||||
} |
||||
method QueryStrict {} { |
||||
return $strict |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## DSL State |
||||
|
||||
component stack ; # State stack - ( ) |
||||
variable base "" ; # Destination dir - into, in, cd, up |
||||
variable alias "" ; # Detail - as |
||||
variable op "" ; # Operation - move, copy, remove, expand, invoke |
||||
variable opcmd "" ; # Command prefix for invoke. |
||||
variable recursive 0 ; # Op. qualifier: recursive expansion? |
||||
variable src "" ; # Source dir - from |
||||
variable excl "" ; # Excluded files - but not|exclude, except for |
||||
# incl ; # Included files - the (immediate use) |
||||
variable types {} ; # Limit glob/find to specific types (f, l, d). |
||||
variable strict 0 ; # Strictness of into/Expand |
||||
|
||||
variable lastexpansion "" ; # Area for last expansion result, for 'Save' to take from. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal -- Path manipulation helpers. |
||||
|
||||
proc ForceRelative {path} { |
||||
set pathtype [file pathtype $path] |
||||
switch -exact -- $pathtype { |
||||
relative { |
||||
return $path |
||||
} |
||||
absolute { |
||||
# Chop off the first element in the path, which is the |
||||
# root, either '/' or 'x:/'. If this was the only |
||||
# element assume an empty path. |
||||
|
||||
set path [lrange [file split $path] 1 end] |
||||
if {![llength $path]} {return {}} |
||||
return [eval [linsert $path 0 file join]] |
||||
} |
||||
volumerelative { |
||||
return -code error {Unable to handle volumerelative path, yet} |
||||
} |
||||
} |
||||
|
||||
return -code error \ |
||||
"file pathtype returned unknown type \"$pathtype\"" |
||||
} |
||||
|
||||
proc ForceAbsolute {path} { |
||||
return [file join [pwd] $path] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal - Operation execution helpers |
||||
|
||||
proc Invoke {files} { |
||||
upvar 1 base base src src opcmd opcmd |
||||
uplevel #0 [linsert $opcmd end $src $base $files] |
||||
return |
||||
} |
||||
|
||||
proc Move {files} { |
||||
upvar 1 base base src src |
||||
|
||||
foreach {s d} $files { |
||||
set s [file join $src $s] |
||||
set d [file join $base $d] |
||||
|
||||
file mkdir [file dirname $d] |
||||
file rename -force $s $d |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc Copy {files} { |
||||
upvar 1 base base src src |
||||
|
||||
foreach {s d} $files { |
||||
set s [file join $src $s] |
||||
set d [file join $base $d] |
||||
|
||||
file mkdir [file dirname $d] |
||||
if { |
||||
[file isdirectory $s] && |
||||
[file exists $d] && |
||||
[file isdirectory $d] |
||||
} { |
||||
# Special case: source and destination are |
||||
# directories, and the latter exists. This puts the |
||||
# source under the destination, and may even prevent |
||||
# copying at all. The semantics of the operation is |
||||
# that the source is the destination. We avoid the |
||||
# trouble by copying the contents of the source, |
||||
# instead of the directory itself. |
||||
foreach path [glob -directory $s *] { |
||||
file copy -force $path $d |
||||
} |
||||
} else { |
||||
file copy -force $s $d |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc Remove {files} { |
||||
upvar 1 base base |
||||
|
||||
foreach f $files { |
||||
file delete -force [file join $base $f] |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal -- Resolution helper commands |
||||
|
||||
typevariable tmap -array { |
||||
files {f TFile} |
||||
links {l TLink} |
||||
dirs {d TDir} |
||||
{} {{} {}} |
||||
} |
||||
|
||||
proc Expand {dir pattern} { |
||||
upvar 1 recursive recursive strict strict types types tmap tmap |
||||
# FUTURE: struct::list filter ... |
||||
|
||||
set files {} |
||||
if {$recursive} { |
||||
# Recursion through the entire directory hierarchy, save |
||||
# all matching paths. |
||||
|
||||
set filter [lindex $tmap($types) 1] |
||||
if {$filter ne ""} { |
||||
set filter [myproc $filter] |
||||
} |
||||
|
||||
foreach f [fileutil::find $dir $filter] { |
||||
if {![string match $pattern [file tail $f]]} continue |
||||
lappend files [fileutil::stripPath $dir $f] |
||||
} |
||||
} else { |
||||
# No recursion, just scan the whole directory for matching paths. |
||||
# check for specific types integrated. |
||||
|
||||
set filter [lindex $tmap($types) 0] |
||||
if {$filter ne ""} { |
||||
foreach f [glob -nocomplain -directory $dir -types $filter -- $pattern] { |
||||
lappend files [fileutil::stripPath $dir $f] |
||||
} |
||||
} else { |
||||
foreach f [glob -nocomplain -directory $dir -- $pattern] { |
||||
lappend files [fileutil::stripPath $dir $f] |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {[llength $files]} {return $files} |
||||
if {!$strict} {return {}} |
||||
|
||||
return -code error \ |
||||
"No files matching pattern \"$pattern\" in directory \"$dir\"" |
||||
} |
||||
|
||||
proc TFile {f} {file isfile $f} |
||||
proc TDir {f} {file isdirectory $f} |
||||
proc TLink {f} {expr {[file type $f] eq "link"}} |
||||
|
||||
proc Exclude {files} { |
||||
upvar 1 excl excl |
||||
|
||||
# FUTURE: struct::list filter ... |
||||
set res {} |
||||
foreach f $files { |
||||
if {[IsExcluded $f $excl]} continue |
||||
lappend res $f |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
proc IsExcluded {f patterns} { |
||||
foreach p $patterns { |
||||
if {[string match $p $f]} {return 1} |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
proc Resolve {files} { |
||||
upvar 1 alias alias |
||||
set res {} |
||||
foreach f $files { |
||||
|
||||
# Remember alias for processing and auto-invalidate to |
||||
# prevent contamination of the next file. |
||||
|
||||
set thealias $alias |
||||
set alias "" |
||||
|
||||
if {$thealias eq ""} { |
||||
set d $f |
||||
} else { |
||||
set d [file dirname $f] |
||||
if {$d eq "."} { |
||||
set d $thealias |
||||
} else { |
||||
set d [file join $d $thealias] |
||||
} |
||||
} |
||||
|
||||
lappend res $f $d |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
proc Remember {files} { |
||||
upvar 1 lastexpansion lastexpansion |
||||
set lastexpansion $files |
||||
return $files |
||||
} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide fileutil::multi::op 0.5.4 |
||||
@ -0,0 +1,7 @@
|
||||
if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} |
||||
package ifneeded fileutil 1.16.2 [list source [file join $dir fileutil.tcl]] |
||||
package ifneeded fileutil::traverse 0.7 [list source [file join $dir traverse.tcl]] |
||||
package ifneeded fileutil::multi 0.2 [list source [file join $dir multi.tcl]] |
||||
package ifneeded fileutil::multi::op 0.5.4 [list source [file join $dir multiop.tcl]] |
||||
package ifneeded fileutil::decode 0.2.2 [list source [file join $dir decode.tcl]] |
||||
package ifneeded fileutil::paths 1.1 [list source [file join $dir paths.tcl]] |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,6 @@
|
||||
if {[package vsatisfies [package provide Tcl] 8.5 9]} { |
||||
package ifneeded snit 2.3.3 \ |
||||
[list source [file join $dir snit2.tcl]] |
||||
} |
||||
|
||||
package ifneeded snit 1.4.2 [list source [file join $dir snit.tcl]] |
||||
@ -0,0 +1,32 @@
|
||||
#----------------------------------------------------------------------- |
||||
# TITLE: |
||||
# snit.tcl |
||||
# |
||||
# AUTHOR: |
||||
# Will Duquette |
||||
# |
||||
# DESCRIPTION: |
||||
# Snit's Not Incr Tcl, a simple object system in Pure Tcl. |
||||
# |
||||
# Snit 1.x Loader |
||||
# |
||||
# Copyright (C) 2003-2006 by William H. Duquette |
||||
# This code is licensed as described in license.txt. |
||||
# |
||||
#----------------------------------------------------------------------- |
||||
|
||||
package require Tcl 8.5 9 |
||||
|
||||
# Define the snit namespace and save the library directory |
||||
|
||||
namespace eval ::snit:: { |
||||
set library [file dirname [info script]] |
||||
} |
||||
|
||||
source [file join $::snit::library main1.tcl] |
||||
|
||||
# Load the library of Snit validation types. |
||||
|
||||
source [file join $::snit::library validate.tcl] |
||||
|
||||
package provide snit 1.4.2 |
||||
@ -0,0 +1,32 @@
|
||||
#----------------------------------------------------------------------- |
||||
# TITLE: |
||||
# snit2.tcl |
||||
# |
||||
# AUTHOR: |
||||
# Will Duquette |
||||
# |
||||
# DESCRIPTION: |
||||
# Snit's Not Incr Tcl, a simple object system in Pure Tcl. |
||||
# |
||||
# Snit 2.x Loader |
||||
# |
||||
# Copyright (C) 2003-2006 by William H. Duquette |
||||
# This code is licensed as described in license.txt. |
||||
# |
||||
#----------------------------------------------------------------------- |
||||
|
||||
package require Tcl 8.5 9 |
||||
|
||||
# Define the snit namespace and save the library directory |
||||
|
||||
namespace eval ::snit:: { |
||||
set library [file dirname [info script]] |
||||
} |
||||
|
||||
# Load the kernel. |
||||
source [file join $::snit::library main2.tcl] |
||||
|
||||
# Load the library of Snit validation types. |
||||
source [file join $::snit::library validate.tcl] |
||||
|
||||
package provide snit 2.3.3 |
||||
@ -0,0 +1,720 @@
|
||||
#----------------------------------------------------------------------- |
||||
# TITLE: |
||||
# validate.tcl |
||||
# |
||||
# AUTHOR: |
||||
# Will Duquette |
||||
# |
||||
# DESCRIPTION: |
||||
# Snit validation types. |
||||
# |
||||
#----------------------------------------------------------------------- |
||||
|
||||
namespace eval ::snit:: { |
||||
namespace export \ |
||||
boolean \ |
||||
double \ |
||||
enum \ |
||||
fpixels \ |
||||
integer \ |
||||
listtype \ |
||||
pixels \ |
||||
stringtype \ |
||||
window |
||||
} |
||||
|
||||
#----------------------------------------------------------------------- |
||||
# snit::boolean |
||||
|
||||
snit::type ::snit::boolean { |
||||
#------------------------------------------------------------------- |
||||
# Type Methods |
||||
|
||||
typemethod validate {value} { |
||||
if {![string is boolean -strict $value]} { |
||||
return -code error -errorcode INVALID \ |
||||
"invalid boolean \"$value\", should be one of: 1, 0, true, false, yes, no, on, off" |
||||
|
||||
} |
||||
|
||||
return $value |
||||
} |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Constructor |
||||
|
||||
# None needed; no options |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Public Methods |
||||
|
||||
method validate {value} { |
||||
$type validate $value |
||||
} |
||||
} |
||||
|
||||
#----------------------------------------------------------------------- |
||||
# snit::double |
||||
|
||||
snit::type ::snit::double { |
||||
#------------------------------------------------------------------- |
||||
# Options |
||||
|
||||
# -min value |
||||
# |
||||
# Minimum value |
||||
|
||||
option -min -default "" -readonly 1 |
||||
|
||||
# -max value |
||||
# |
||||
# Maximum value |
||||
|
||||
option -max -default "" -readonly 1 |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Type Methods |
||||
|
||||
typemethod validate {value} { |
||||
if {![string is double -strict $value]} { |
||||
return -code error -errorcode INVALID \ |
||||
"invalid value \"$value\", expected double" |
||||
} |
||||
|
||||
return $value |
||||
} |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Constructor |
||||
|
||||
constructor {args} { |
||||
# FIRST, get the options |
||||
$self configurelist $args |
||||
|
||||
if {"" != $options(-min) && |
||||
![string is double -strict $options(-min)]} { |
||||
return -code error \ |
||||
"invalid -min: \"$options(-min)\"" |
||||
} |
||||
|
||||
if {"" != $options(-max) && |
||||
![string is double -strict $options(-max)]} { |
||||
return -code error \ |
||||
"invalid -max: \"$options(-max)\"" |
||||
} |
||||
|
||||
if {"" != $options(-min) && |
||||
"" != $options(-max) && |
||||
$options(-max) < $options(-min)} { |
||||
return -code error "-max < -min" |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Public Methods |
||||
|
||||
# Fixed method for the snit::double type. |
||||
# WHD, 6/7/2010. |
||||
method validate {value} { |
||||
$type validate $value |
||||
|
||||
if {("" != $options(-min) && $value < $options(-min)) || |
||||
("" != $options(-max) && $value > $options(-max))} { |
||||
|
||||
set msg "invalid value \"$value\", expected double" |
||||
|
||||
if {"" != $options(-min) && "" != $options(-max)} { |
||||
append msg " in range $options(-min), $options(-max)" |
||||
} elseif {"" != $options(-min)} { |
||||
append msg " no less than $options(-min)" |
||||
} elseif {"" != $options(-max)} { |
||||
append msg " no greater than $options(-max)" |
||||
} |
||||
|
||||
return -code error -errorcode INVALID $msg |
||||
} |
||||
|
||||
return $value |
||||
} |
||||
} |
||||
|
||||
#----------------------------------------------------------------------- |
||||
# snit::enum |
||||
|
||||
snit::type ::snit::enum { |
||||
#------------------------------------------------------------------- |
||||
# Options |
||||
|
||||
# -values list |
||||
# |
||||
# Valid values for this type |
||||
|
||||
option -values -default {} -readonly 1 |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Type Methods |
||||
|
||||
typemethod validate {value} { |
||||
# No -values specified; it's always valid |
||||
return $value |
||||
} |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Constructor |
||||
|
||||
constructor {args} { |
||||
$self configurelist $args |
||||
|
||||
if {[llength $options(-values)] == 0} { |
||||
return -code error \ |
||||
"invalid -values: \"\"" |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Public Methods |
||||
|
||||
method validate {value} { |
||||
if {[lsearch -exact $options(-values) $value] == -1} { |
||||
return -code error -errorcode INVALID \ |
||||
"invalid value \"$value\", should be one of: [join $options(-values) {, }]" |
||||
} |
||||
|
||||
return $value |
||||
} |
||||
} |
||||
|
||||
#----------------------------------------------------------------------- |
||||
# snit::fpixels |
||||
|
||||
snit::type ::snit::fpixels { |
||||
#------------------------------------------------------------------- |
||||
# Options |
||||
|
||||
# -min value |
||||
# |
||||
# Minimum value |
||||
|
||||
option -min -default "" -readonly 1 |
||||
|
||||
# -max value |
||||
# |
||||
# Maximum value |
||||
|
||||
option -max -default "" -readonly 1 |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Instance variables |
||||
|
||||
variable min "" ;# -min, no suffix |
||||
variable max "" ;# -max, no suffix |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Type Methods |
||||
|
||||
typemethod validate {value} { |
||||
if {[catch {winfo fpixels . $value} dummy]} { |
||||
return -code error -errorcode INVALID \ |
||||
"invalid value \"$value\", expected fpixels" |
||||
} |
||||
|
||||
return $value |
||||
} |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Constructor |
||||
|
||||
constructor {args} { |
||||
# FIRST, get the options |
||||
$self configurelist $args |
||||
|
||||
if {"" != $options(-min) && |
||||
[catch {winfo fpixels . $options(-min)} min]} { |
||||
return -code error \ |
||||
"invalid -min: \"$options(-min)\"" |
||||
} |
||||
|
||||
if {"" != $options(-max) && |
||||
[catch {winfo fpixels . $options(-max)} max]} { |
||||
return -code error \ |
||||
"invalid -max: \"$options(-max)\"" |
||||
} |
||||
|
||||
if {"" != $min && |
||||
"" != $max && |
||||
$max < $min} { |
||||
return -code error "-max < -min" |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Public Methods |
||||
|
||||
method validate {value} { |
||||
$type validate $value |
||||
|
||||
set val [winfo fpixels . $value] |
||||
|
||||
if {("" != $min && $val < $min) || |
||||
("" != $max && $val > $max)} { |
||||
|
||||
set msg "invalid value \"$value\", expected fpixels" |
||||
|
||||
if {"" != $min && "" != $max} { |
||||
append msg " in range $options(-min), $options(-max)" |
||||
} elseif {"" != $min} { |
||||
append msg " no less than $options(-min)" |
||||
} |
||||
|
||||
return -code error -errorcode INVALID $msg |
||||
} |
||||
|
||||
return $value |
||||
} |
||||
} |
||||
|
||||
#----------------------------------------------------------------------- |
||||
# snit::integer |
||||
|
||||
snit::type ::snit::integer { |
||||
#------------------------------------------------------------------- |
||||
# Options |
||||
|
||||
# -min value |
||||
# |
||||
# Minimum value |
||||
|
||||
option -min -default "" -readonly 1 |
||||
|
||||
# -max value |
||||
# |
||||
# Maximum value |
||||
|
||||
option -max -default "" -readonly 1 |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Type Methods |
||||
|
||||
typemethod validate {value} { |
||||
if {![string is integer -strict $value]} { |
||||
return -code error -errorcode INVALID \ |
||||
"invalid value \"$value\", expected integer" |
||||
} |
||||
|
||||
return $value |
||||
} |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Constructor |
||||
|
||||
constructor {args} { |
||||
# FIRST, get the options |
||||
$self configurelist $args |
||||
|
||||
if {"" != $options(-min) && |
||||
![string is integer -strict $options(-min)]} { |
||||
return -code error \ |
||||
"invalid -min: \"$options(-min)\"" |
||||
} |
||||
|
||||
if {"" != $options(-max) && |
||||
![string is integer -strict $options(-max)]} { |
||||
return -code error \ |
||||
"invalid -max: \"$options(-max)\"" |
||||
} |
||||
|
||||
if {"" != $options(-min) && |
||||
"" != $options(-max) && |
||||
$options(-max) < $options(-min)} { |
||||
return -code error "-max < -min" |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Public Methods |
||||
|
||||
method validate {value} { |
||||
$type validate $value |
||||
|
||||
if {("" != $options(-min) && $value < $options(-min)) || |
||||
("" != $options(-max) && $value > $options(-max))} { |
||||
|
||||
set msg "invalid value \"$value\", expected integer" |
||||
|
||||
if {"" != $options(-min) && "" != $options(-max)} { |
||||
append msg " in range $options(-min), $options(-max)" |
||||
} elseif {"" != $options(-min)} { |
||||
append msg " no less than $options(-min)" |
||||
} |
||||
|
||||
return -code error -errorcode INVALID $msg |
||||
} |
||||
|
||||
return $value |
||||
} |
||||
} |
||||
|
||||
#----------------------------------------------------------------------- |
||||
# snit::list |
||||
|
||||
snit::type ::snit::listtype { |
||||
#------------------------------------------------------------------- |
||||
# Options |
||||
|
||||
# -type type |
||||
# |
||||
# Specifies a value type |
||||
|
||||
option -type -readonly 1 |
||||
|
||||
# -minlen len |
||||
# |
||||
# Minimum list length |
||||
|
||||
option -minlen -readonly 1 -default 0 |
||||
|
||||
# -maxlen len |
||||
# |
||||
# Maximum list length |
||||
|
||||
option -maxlen -readonly 1 |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Type Methods |
||||
|
||||
typemethod validate {value} { |
||||
if {[catch {llength $value} result]} { |
||||
return -code error -errorcode INVALID \ |
||||
"invalid value \"$value\", expected list" |
||||
} |
||||
|
||||
return $value |
||||
} |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Constructor |
||||
|
||||
constructor {args} { |
||||
# FIRST, get the options |
||||
$self configurelist $args |
||||
|
||||
if {"" != $options(-minlen) && |
||||
(![string is integer -strict $options(-minlen)] || |
||||
$options(-minlen) < 0)} { |
||||
return -code error \ |
||||
"invalid -minlen: \"$options(-minlen)\"" |
||||
} |
||||
|
||||
if {"" == $options(-minlen)} { |
||||
set options(-minlen) 0 |
||||
} |
||||
|
||||
if {"" != $options(-maxlen) && |
||||
![string is integer -strict $options(-maxlen)]} { |
||||
return -code error \ |
||||
"invalid -maxlen: \"$options(-maxlen)\"" |
||||
} |
||||
|
||||
if {"" != $options(-maxlen) && |
||||
$options(-maxlen) < $options(-minlen)} { |
||||
return -code error "-maxlen < -minlen" |
||||
} |
||||
} |
||||
|
||||
|
||||
#------------------------------------------------------------------- |
||||
# Methods |
||||
|
||||
method validate {value} { |
||||
$type validate $value |
||||
|
||||
set len [llength $value] |
||||
|
||||
if {$len < $options(-minlen)} { |
||||
return -code error -errorcode INVALID \ |
||||
"value has too few elements; at least $options(-minlen) expected" |
||||
} elseif {"" != $options(-maxlen)} { |
||||
if {$len > $options(-maxlen)} { |
||||
return -code error -errorcode INVALID \ |
||||
"value has too many elements; no more than $options(-maxlen) expected" |
||||
} |
||||
} |
||||
|
||||
# NEXT, check each value |
||||
if {"" != $options(-type)} { |
||||
foreach item $value { |
||||
set cmd $options(-type) |
||||
lappend cmd validate $item |
||||
uplevel \#0 $cmd |
||||
} |
||||
} |
||||
|
||||
return $value |
||||
} |
||||
} |
||||
|
||||
#----------------------------------------------------------------------- |
||||
# snit::pixels |
||||
|
||||
snit::type ::snit::pixels { |
||||
#------------------------------------------------------------------- |
||||
# Options |
||||
|
||||
# -min value |
||||
# |
||||
# Minimum value |
||||
|
||||
option -min -default "" -readonly 1 |
||||
|
||||
# -max value |
||||
# |
||||
# Maximum value |
||||
|
||||
option -max -default "" -readonly 1 |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Instance variables |
||||
|
||||
variable min "" ;# -min, no suffix |
||||
variable max "" ;# -max, no suffix |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Type Methods |
||||
|
||||
typemethod validate {value} { |
||||
if {[catch {winfo pixels . $value} dummy]} { |
||||
return -code error -errorcode INVALID \ |
||||
"invalid value \"$value\", expected pixels" |
||||
} |
||||
|
||||
return $value |
||||
} |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Constructor |
||||
|
||||
constructor {args} { |
||||
# FIRST, get the options |
||||
$self configurelist $args |
||||
|
||||
if {"" != $options(-min) && |
||||
[catch {winfo pixels . $options(-min)} min]} { |
||||
return -code error \ |
||||
"invalid -min: \"$options(-min)\"" |
||||
} |
||||
|
||||
if {"" != $options(-max) && |
||||
[catch {winfo pixels . $options(-max)} max]} { |
||||
return -code error \ |
||||
"invalid -max: \"$options(-max)\"" |
||||
} |
||||
|
||||
if {"" != $min && |
||||
"" != $max && |
||||
$max < $min} { |
||||
return -code error "-max < -min" |
||||
} |
||||
} |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Public Methods |
||||
|
||||
method validate {value} { |
||||
$type validate $value |
||||
|
||||
set val [winfo pixels . $value] |
||||
|
||||
if {("" != $min && $val < $min) || |
||||
("" != $max && $val > $max)} { |
||||
|
||||
set msg "invalid value \"$value\", expected pixels" |
||||
|
||||
if {"" != $min && "" != $max} { |
||||
append msg " in range $options(-min), $options(-max)" |
||||
} elseif {"" != $min} { |
||||
append msg " no less than $options(-min)" |
||||
} |
||||
|
||||
return -code error -errorcode INVALID $msg |
||||
} |
||||
|
||||
return $value |
||||
} |
||||
} |
||||
|
||||
#----------------------------------------------------------------------- |
||||
# snit::stringtype |
||||
|
||||
snit::type ::snit::stringtype { |
||||
#------------------------------------------------------------------- |
||||
# Options |
||||
|
||||
# -minlen len |
||||
# |
||||
# Minimum list length |
||||
|
||||
option -minlen -readonly 1 -default 0 |
||||
|
||||
# -maxlen len |
||||
# |
||||
# Maximum list length |
||||
|
||||
option -maxlen -readonly 1 |
||||
|
||||
# -nocase 0|1 |
||||
# |
||||
# globs and regexps are case-insensitive if -nocase 1. |
||||
|
||||
option -nocase -readonly 1 -default 0 |
||||
|
||||
# -glob pattern |
||||
# |
||||
# Glob-match pattern, or "" |
||||
|
||||
option -glob -readonly 1 |
||||
|
||||
# -regexp regexp |
||||
# |
||||
# Regular expression to match |
||||
|
||||
option -regexp -readonly 1 |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Type Methods |
||||
|
||||
typemethod validate {value} { |
||||
# By default, any string (hence, any Tcl value) is valid. |
||||
return $value |
||||
} |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Constructor |
||||
|
||||
constructor {args} { |
||||
# FIRST, get the options |
||||
$self configurelist $args |
||||
|
||||
# NEXT, validate -minlen and -maxlen |
||||
if {"" != $options(-minlen) && |
||||
(![string is integer -strict $options(-minlen)] || |
||||
$options(-minlen) < 0)} { |
||||
return -code error \ |
||||
"invalid -minlen: \"$options(-minlen)\"" |
||||
} |
||||
|
||||
if {"" == $options(-minlen)} { |
||||
set options(-minlen) 0 |
||||
} |
||||
|
||||
if {"" != $options(-maxlen) && |
||||
![string is integer -strict $options(-maxlen)]} { |
||||
return -code error \ |
||||
"invalid -maxlen: \"$options(-maxlen)\"" |
||||
} |
||||
|
||||
if {"" != $options(-maxlen) && |
||||
$options(-maxlen) < $options(-minlen)} { |
||||
return -code error "-maxlen < -minlen" |
||||
} |
||||
|
||||
# NEXT, validate -nocase |
||||
if {[catch {snit::boolean validate $options(-nocase)} result]} { |
||||
return -code error "invalid -nocase: $result" |
||||
} |
||||
|
||||
# Validate the glob |
||||
if {"" != $options(-glob) && |
||||
[catch {string match $options(-glob) ""} dummy]} { |
||||
return -code error \ |
||||
"invalid -glob: \"$options(-glob)\"" |
||||
} |
||||
|
||||
# Validate the regexp |
||||
if {"" != $options(-regexp) && |
||||
[catch {regexp $options(-regexp) ""} dummy]} { |
||||
return -code error \ |
||||
"invalid -regexp: \"$options(-regexp)\"" |
||||
} |
||||
} |
||||
|
||||
|
||||
#------------------------------------------------------------------- |
||||
# Methods |
||||
|
||||
method validate {value} { |
||||
# Usually we'd call [$type validate $value] here, but |
||||
# as it's a no-op, don't bother. |
||||
|
||||
# FIRST, validate the length. |
||||
set len [string length $value] |
||||
|
||||
if {$len < $options(-minlen)} { |
||||
return -code error -errorcode INVALID \ |
||||
"too short: at least $options(-minlen) characters expected" |
||||
} elseif {"" != $options(-maxlen)} { |
||||
if {$len > $options(-maxlen)} { |
||||
return -code error -errorcode INVALID \ |
||||
"too long: no more than $options(-maxlen) characters expected" |
||||
} |
||||
} |
||||
|
||||
# NEXT, check the glob match, with or without case. |
||||
if {"" != $options(-glob)} { |
||||
if {$options(-nocase)} { |
||||
set result [string match -nocase $options(-glob) $value] |
||||
} else { |
||||
set result [string match $options(-glob) $value] |
||||
} |
||||
|
||||
if {!$result} { |
||||
return -code error -errorcode INVALID \ |
||||
"invalid value \"$value\"" |
||||
} |
||||
} |
||||
|
||||
# NEXT, check regexp match with or without case |
||||
if {"" != $options(-regexp)} { |
||||
if {$options(-nocase)} { |
||||
set result [regexp -nocase -- $options(-regexp) $value] |
||||
} else { |
||||
set result [regexp -- $options(-regexp) $value] |
||||
} |
||||
|
||||
if {!$result} { |
||||
return -code error -errorcode INVALID \ |
||||
"invalid value \"$value\"" |
||||
} |
||||
} |
||||
|
||||
return $value |
||||
} |
||||
} |
||||
|
||||
#----------------------------------------------------------------------- |
||||
# snit::window |
||||
|
||||
snit::type ::snit::window { |
||||
#------------------------------------------------------------------- |
||||
# Type Methods |
||||
|
||||
typemethod validate {value} { |
||||
if {![winfo exists $value]} { |
||||
return -code error -errorcode INVALID \ |
||||
"invalid value \"$value\", value is not a window" |
||||
} |
||||
|
||||
return $value |
||||
} |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Constructor |
||||
|
||||
# None needed; no options |
||||
|
||||
#------------------------------------------------------------------- |
||||
# Public Methods |
||||
|
||||
method validate {value} { |
||||
$type validate $value |
||||
} |
||||
} |
||||
@ -0,0 +1,385 @@
|
||||
# disjointset.tcl -- |
||||
# |
||||
# Implementation of a Disjoint Set for Tcl. |
||||
# |
||||
# Copyright (c) Google Summer of Code 2008 Alejandro Eduardo Cruz Paz |
||||
# Copyright (c) 2008 Andreas Kupries (API redesign and simplification) |
||||
# Copyright (c) 2018 by Kevin B. Kenny - reworked to a proper disjoint-sets |
||||
# data structure, added 'add-element', 'exemplars' and 'find-exemplar'. |
||||
|
||||
# References |
||||
# |
||||
# - General overview |
||||
# - https://en.wikipedia.org/wiki/Disjoint-set_data_structure |
||||
# |
||||
# - Time/Complexity proofs |
||||
# - https://dl.acm.org/citation.cfm?doid=62.2160 |
||||
# - https://dl.acm.org/citation.cfm?doid=364099.364331 |
||||
# |
||||
|
||||
package require Tcl 8.6 9 |
||||
|
||||
# Initialize the disjointset structure namespace. Note that any |
||||
# missing parent namespace (::struct) will be automatically created as |
||||
# well. |
||||
namespace eval ::struct::disjointset { |
||||
|
||||
# Only export one command, the one used to instantiate a new |
||||
# disjoint set |
||||
namespace export disjointset |
||||
} |
||||
|
||||
# class struct::disjointset::_disjointset -- |
||||
# |
||||
# Implementation of a disjoint-sets data structure |
||||
|
||||
oo::class create struct::disjointset::_disjointset { |
||||
|
||||
# elements - Dictionary whose keys are all the elements in the structure, |
||||
# and whose values are element numbers. |
||||
# tree - List indexed by element number whose members are |
||||
# ordered triples consisting of the element's name, |
||||
# the element number of the element's parent (or the element's |
||||
# own index if the element is a root), and the rank of |
||||
# the element. |
||||
# nParts - Number of partitions in the structure. Maintained only |
||||
# so that num_partitions will work. |
||||
|
||||
variable elements tree nParts |
||||
|
||||
constructor {} { |
||||
set elements {} |
||||
set tree {} |
||||
set nParts 0 |
||||
} |
||||
|
||||
# add-element -- |
||||
# |
||||
# Adds an element to the structure |
||||
# |
||||
# Parameters: |
||||
# item - Name of the element to add |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# Element is added |
||||
|
||||
method add-element {item} { |
||||
if {[dict exists $elements $item]} { |
||||
return -code error \ |
||||
-errorcode [list STRUCT DISJOINTSET DUPLICATE $item [self]] \ |
||||
"The element \"$item\" is already known to the disjoint\ |
||||
set [self]" |
||||
} |
||||
set n [llength $tree] |
||||
dict set elements $item $n |
||||
lappend tree [list $item $n 0] |
||||
incr nParts |
||||
return |
||||
} |
||||
|
||||
# add-partition -- |
||||
# |
||||
# Adds a collection of new elements to a disjoint-sets structure and |
||||
# makes them all one partition. |
||||
# |
||||
# Parameters: |
||||
# items - List of elements to add. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# Adds all the elements, and groups them into a single partition. |
||||
|
||||
method add-partition {items} { |
||||
|
||||
# Integrity check - make sure that none of the elements have yet |
||||
# been added |
||||
|
||||
foreach name $items { |
||||
if {[dict exists $elements $name]} { |
||||
return -code error \ |
||||
-errorcode [list STRUCT DISJOINTSET DUPLICATE \ |
||||
$name [self]] \ |
||||
"The element \"$name\" is already known to the disjoint\ |
||||
set [self]" |
||||
} |
||||
} |
||||
|
||||
# Add all the elements in one go, and establish parent links for all |
||||
# but the first |
||||
|
||||
set first -1 |
||||
foreach n $items { |
||||
set idx [llength $tree] |
||||
dict set elements $n $idx |
||||
if {$first < 0} { |
||||
set first $idx |
||||
set rank 1 |
||||
} else { |
||||
set rank 0 |
||||
} |
||||
lappend tree [list $n $first $rank] |
||||
} |
||||
incr nParts |
||||
return |
||||
} |
||||
|
||||
# equal -- |
||||
# |
||||
# Test if two elements belong to the same partition in a disjoint-sets |
||||
# data structure. |
||||
# |
||||
# Parameters: |
||||
# a - Name of the first element |
||||
# b - Name of the second element |
||||
# |
||||
# Results: |
||||
# Returns 1 if the elements are in the same partition, and 0 otherwise. |
||||
|
||||
method equal {a b} { |
||||
expr {[my FindNum $a] == [my FindNum $b]} |
||||
} |
||||
|
||||
# exemplars -- |
||||
# |
||||
# Find one representative element for each partition in a disjoint-sets |
||||
# data structure. |
||||
# |
||||
# Results: |
||||
# Returns a list of element names |
||||
|
||||
method exemplars {} { |
||||
set result {} |
||||
set n -1 |
||||
foreach row $tree { |
||||
if {[lindex $row 1] == [incr n]} { |
||||
lappend result [lindex $row 0] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# find -- |
||||
# |
||||
# Find the partition to which a given element belongs. |
||||
# |
||||
# Parameters: |
||||
# item - Item to find |
||||
# |
||||
# Results: |
||||
# Returns a list of the partition's members |
||||
# |
||||
# Notes: |
||||
# This operation takes time proportional to the total number of elements |
||||
# in the disjoint-sets structure. If a simple name of the partition |
||||
# is all that is required, use "find-exemplar" instead, which runs |
||||
# in amortized time proportional to the inverse Ackermann function of |
||||
# the size of the partition. |
||||
|
||||
method find {item} { |
||||
set result {} |
||||
# No error on a nonexistent item |
||||
if {![dict exists $elements $item]} { |
||||
return {} |
||||
} |
||||
set pnum [my FindNum $item] |
||||
set n -1 |
||||
foreach row $tree { |
||||
if {[my FindByNum [incr n]] eq $pnum} { |
||||
lappend result [lindex $row 0] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# find-exemplar -- |
||||
# |
||||
# Find a representative element of the partition that contains a given |
||||
# element. |
||||
# |
||||
# parameters: |
||||
# item - Item to examine |
||||
# |
||||
# Results: |
||||
# Returns the exemplar |
||||
# |
||||
# Notes: |
||||
# Takes O(alpha(|P|)) amortized time, where |P| is the size of the |
||||
# partition, and alpha is the inverse Ackermann function |
||||
|
||||
method find-exemplar {item} { |
||||
return [lindex $tree [my FindNum $item] 0] |
||||
} |
||||
|
||||
# merge -- |
||||
# |
||||
# Merges the partitions that two elements are in. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
method merge {a b} { |
||||
my MergeByNum [my FindNum $a] [my FindNum $b] |
||||
} |
||||
|
||||
# num-partitions -- |
||||
# |
||||
# Counts the partitions of a disjoint-sets data structure |
||||
# |
||||
# Results: |
||||
# Returns the partition count. |
||||
|
||||
method num-partitions {} { |
||||
return $nParts |
||||
} |
||||
|
||||
# partitions -- |
||||
# |
||||
# Enumerates the partitions of a disjoint-sets data structure |
||||
# |
||||
# Results: |
||||
# Returns a list of lists. Each list is one of the partitions |
||||
# in the disjoint set, and each member of the sublist is one |
||||
# of the elements added to the structure. |
||||
|
||||
method partitions {} { |
||||
|
||||
# Find the partition number for each element, and accumulate a |
||||
# list per partition |
||||
set parts {} |
||||
dict for {element eltNo} $elements { |
||||
set partNo [my FindByNum $eltNo] |
||||
dict lappend parts $partNo $element |
||||
} |
||||
return [dict values $parts] |
||||
} |
||||
|
||||
# FindNum -- |
||||
# |
||||
# Finds the partition number for an element. |
||||
# |
||||
# Parameters: |
||||
# item - Item to look up |
||||
# |
||||
# Results: |
||||
# Returns the partition number |
||||
|
||||
method FindNum {item} { |
||||
if {![dict exists $elements $item]} { |
||||
return -code error \ |
||||
-errorcode [list STRUCT DISJOINTSET NOTFOUND $item [self]] \ |
||||
"The element \"$item\" is not known to the disjoint\ |
||||
set [self]" |
||||
} |
||||
return [my FindByNum [dict get $elements $item]] |
||||
} |
||||
|
||||
# FindByNum -- |
||||
# |
||||
# Finds the partition number for an element, given the element's |
||||
# index |
||||
# |
||||
# Parameters: |
||||
# idx - Index of the item to look up |
||||
# |
||||
# Results: |
||||
# Returns the partition number |
||||
# |
||||
# Side effects: |
||||
# Performs path splitting |
||||
|
||||
method FindByNum {idx} { |
||||
while {1} { |
||||
set parent [lindex $tree $idx 1] |
||||
if {$parent == $idx} { |
||||
return $idx |
||||
} |
||||
set prev $idx |
||||
set idx $parent |
||||
lset tree $prev 1 [lindex $tree $idx 1] |
||||
} |
||||
} |
||||
|
||||
# MergeByNum -- |
||||
# |
||||
# Merges two partitions in a disjoint-sets data structure |
||||
# |
||||
# Parameters: |
||||
# x - Index of an element in the first partition |
||||
# y - Index of an element in the second partition |
||||
# |
||||
# Results: |
||||
# None |
||||
# |
||||
# Side effects: |
||||
# Merges the partition of the lower rank into the one of the |
||||
# higher rank. |
||||
|
||||
method MergeByNum {x y} { |
||||
set xroot [my FindByNum $x] |
||||
set yroot [my FindByNum $y] |
||||
|
||||
if {$xroot == $yroot} { |
||||
# The elements are already in the same partition |
||||
return |
||||
} |
||||
|
||||
incr nParts -1 |
||||
|
||||
# Make xroot the taller tree |
||||
if {[lindex $tree $xroot 2] < [lindex $tree $yroot 2]} { |
||||
set t $xroot; set xroot $yroot; set yroot $t |
||||
} |
||||
|
||||
# Merge yroot into xroot |
||||
set xrank [lindex $tree $xroot 2] |
||||
set yrank [lindex $tree $yroot 2] |
||||
lset tree $yroot 1 $xroot |
||||
if {$xrank == $yrank} { |
||||
lset tree $xroot 2 [expr {$xrank + 1}] |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ::struct::disjointset::disjointset -- |
||||
# |
||||
# Create a new disjoint set with a given name; if no name is |
||||
# given, use disjointsetX, where X is a number. |
||||
# |
||||
# Arguments: |
||||
# name Optional name of the disjoint set; if not specified, generate one. |
||||
# |
||||
# Results: |
||||
# name Name of the disjoint set created |
||||
|
||||
proc ::struct::disjointset::disjointset {args} { |
||||
|
||||
switch -exact -- [llength $args] { |
||||
0 { |
||||
return [_disjointset new] |
||||
} |
||||
1 { |
||||
# Name supplied by user |
||||
return [uplevel 1 [list [namespace which _disjointset] \ |
||||
create [lindex $args 0]]] |
||||
} |
||||
default { |
||||
# Too many args |
||||
return -code error \ |
||||
-errorcode {TCL WRONGARGS} \ |
||||
"wrong # args: should be \"[lindex [info level 0] 0] ?name?\"" |
||||
} |
||||
} |
||||
} |
||||
|
||||
namespace eval ::struct { |
||||
namespace import disjointset::disjointset |
||||
namespace export disjointset |
||||
} |
||||
|
||||
package provide struct::disjointset 1.2 |
||||
return |
||||
@ -0,0 +1,177 @@
|
||||
# graph.tcl -- |
||||
# |
||||
# Implementation of a graph data structure for Tcl. |
||||
# |
||||
# Copyright (c) 2000-2005,2019 by Andreas Kupries |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
|
||||
# @mdgen EXCLUDE: graph_c.tcl |
||||
|
||||
package require Tcl 8.5 9 |
||||
|
||||
namespace eval ::struct::graph {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Management of graph implementations. |
||||
|
||||
# ::struct::graph::LoadAccelerator -- |
||||
# |
||||
# Loads a named implementation, if possible. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to load. |
||||
# |
||||
# Results: |
||||
# A boolean flag. True if the implementation |
||||
# was successfully loaded; and False otherwise. |
||||
|
||||
proc ::struct::graph::LoadAccelerator {key} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $key { |
||||
critcl { |
||||
# Critcl implementation of graph requires Tcl 8.4. |
||||
if {[catch {package require tcllibc}]} {return 0} |
||||
set r [llength [info commands ::struct::graph_critcl]] |
||||
} |
||||
tcl { |
||||
variable selfdir |
||||
source [file join $selfdir graph_tcl.tcl] |
||||
set r 1 |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator/impl. package $key:\ |
||||
must be one of [join [KnownImplementations] {, }]" |
||||
} |
||||
} |
||||
set accel($key) $r |
||||
return $r |
||||
} |
||||
|
||||
# ::struct::graph::SwitchTo -- |
||||
# |
||||
# Activates a loaded named implementation. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to activate. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::graph::SwitchTo {key} { |
||||
variable accel |
||||
variable loaded |
||||
|
||||
if {[string equal $key $loaded]} { |
||||
# No change, nothing to do. |
||||
return |
||||
} elseif {![string equal $key ""]} { |
||||
# Validate the target implementation of the switch. |
||||
|
||||
if {![info exists accel($key)]} { |
||||
return -code error "Unable to activate unknown implementation \"$key\"" |
||||
} elseif {![info exists accel($key)] || !$accel($key)} { |
||||
return -code error "Unable to activate missing implementation \"$key\"" |
||||
} |
||||
} |
||||
|
||||
# Deactivate the previous implementation, if there was any. |
||||
|
||||
if {![string equal $loaded ""]} { |
||||
rename ::struct::graph ::struct::graph_$loaded |
||||
} |
||||
|
||||
# Activate the new implementation, if there is any. |
||||
|
||||
if {![string equal $key ""]} { |
||||
rename ::struct::graph_$key ::struct::graph |
||||
} |
||||
|
||||
# Remember the active implementation, for deactivation by future |
||||
# switches. |
||||
|
||||
set loaded $key |
||||
return |
||||
} |
||||
|
||||
# ::struct::graph::Implementations -- |
||||
# |
||||
# Determines which implementations are |
||||
# present, i.e. loaded. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. |
||||
|
||||
proc ::struct::graph::Implementations {} { |
||||
variable accel |
||||
set res {} |
||||
foreach n [array names accel] { |
||||
if {!$accel($n)} continue |
||||
lappend res $n |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::struct::graph::KnownImplementations -- |
||||
# |
||||
# Determines which implementations are known |
||||
# as possible implementations. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. In the order |
||||
# of preference, most prefered first. |
||||
|
||||
proc ::struct::graph::KnownImplementations {} { |
||||
return {critcl tcl} |
||||
} |
||||
|
||||
proc ::struct::graph::Names {} { |
||||
return { |
||||
critcl {tcllibc based} |
||||
tcl {pure Tcl} |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Data structures. |
||||
|
||||
namespace eval ::struct::graph { |
||||
variable selfdir [file dirname [info script]] |
||||
variable accel |
||||
array set accel {tcl 0 critcl 0} |
||||
variable loaded {} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Choose an implementation, |
||||
## most prefered first. Loads only one of the |
||||
## possible implementations. And activates it. |
||||
|
||||
namespace eval ::struct::graph { |
||||
variable e |
||||
foreach e [KnownImplementations] { |
||||
if {[LoadAccelerator $e]} { |
||||
SwitchTo $e |
||||
break |
||||
} |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Export the constructor command. |
||||
namespace export graph |
||||
} |
||||
|
||||
package provide struct::graph 2.4.4 |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,158 @@
|
||||
# graphc.tcl -- |
||||
# |
||||
# Implementation of a graph data structure for Tcl. |
||||
# This code based on critcl, API compatible to the PTI [x]. |
||||
# [x] Pure Tcl Implementation. |
||||
# |
||||
# Copyright (c) 2006,2019 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
|
||||
package require critcl |
||||
# @sak notprovided struct_graphc |
||||
package provide struct_graphc 2.4.4 |
||||
package require Tcl 8.5 9 |
||||
|
||||
namespace eval ::struct { |
||||
# Supporting code for the main command. |
||||
|
||||
catch { |
||||
#critcl::cheaders -g |
||||
#critcl::debug memory symbols |
||||
} |
||||
|
||||
critcl::cheaders graph/*.h |
||||
critcl::csources graph/*.c |
||||
|
||||
critcl::ccode { |
||||
/* -*- c -*- */ |
||||
|
||||
#include <global.h> |
||||
#include <objcmd.h> |
||||
#include <graph.h> |
||||
|
||||
#define USAGE "?name ?=|:=|as|deserialize source??" |
||||
|
||||
static void gg_delete (ClientData clientData) |
||||
{ |
||||
/* Release the whole graph. */ |
||||
g_delete ((G*) clientData); |
||||
} |
||||
} |
||||
|
||||
# Main command, graph creation. |
||||
|
||||
critcl::ccommand graph_critcl {dummy interp objc objv} { |
||||
/* Syntax */ |
||||
/* - epsilon |1 */ |
||||
/* - name |2 */ |
||||
/* - name =|:=|as|deserialize source |4 */ |
||||
|
||||
CONST char* name; |
||||
G* g; |
||||
Tcl_Obj* fqn; |
||||
Tcl_CmdInfo ci; |
||||
|
||||
if ((objc != 4) && (objc != 2) && (objc != 1)) { |
||||
Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
if (objc < 2) { |
||||
name = gg_new (interp); |
||||
} else { |
||||
name = Tcl_GetString (objv [1]); |
||||
} |
||||
|
||||
if (!Tcl_StringMatch (name, "::*")) { |
||||
/* Relative name. Prefix with current namespace */ |
||||
|
||||
Tcl_Eval (interp, "namespace current"); |
||||
fqn = Tcl_GetObjResult (interp); |
||||
fqn = Tcl_DuplicateObj (fqn); |
||||
Tcl_IncrRefCount (fqn); |
||||
|
||||
if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { |
||||
Tcl_AppendToObj (fqn, "::", -1); /* OK tcl9 */ |
||||
} |
||||
Tcl_AppendToObj (fqn, name, -1); /* OK tcl9 */ |
||||
} else { |
||||
fqn = Tcl_NewStringObj (name, -1); /* OK tcl9 */ |
||||
Tcl_IncrRefCount (fqn); |
||||
} |
||||
|
||||
Tcl_ResetResult (interp); |
||||
|
||||
if (Tcl_GetCommandInfo (interp, Tcl_GetString (fqn), &ci)) { |
||||
Tcl_Obj* err; |
||||
|
||||
err = Tcl_NewObj (); |
||||
Tcl_AppendToObj (err, "command \"", -1); /* OK tcl9 */ |
||||
Tcl_AppendObjToObj (err, fqn); |
||||
Tcl_AppendToObj (err, "\" already exists, unable to create graph", -1); /* OK tcl9 */ |
||||
|
||||
Tcl_DecrRefCount (fqn); |
||||
Tcl_SetObjResult (interp, err); |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
if (objc == 4) { |
||||
/* Construction with immediate initialization */ |
||||
/* through deserialization */ |
||||
|
||||
Tcl_Obj* type = objv[2]; |
||||
Tcl_Obj* src = objv[3]; |
||||
int srctype; |
||||
|
||||
static CONST char* types [] = { |
||||
":=", "=", "as", "deserialize", NULL |
||||
}; |
||||
enum types { |
||||
G_ASSIGN, G_IS, G_AS, G_DESER |
||||
}; |
||||
|
||||
if (Tcl_GetIndexFromObj (interp, type, types, "type", 0, &srctype) != TCL_OK) { |
||||
Tcl_DecrRefCount (fqn); |
||||
Tcl_ResetResult (interp); |
||||
Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
g = g_new (); |
||||
|
||||
switch (srctype) { |
||||
case G_ASSIGN: |
||||
case G_AS: |
||||
case G_IS: |
||||
if (g_ms_assign (interp, g, src) != TCL_OK) { |
||||
g_delete (g); |
||||
Tcl_DecrRefCount (fqn); |
||||
return TCL_ERROR; |
||||
} |
||||
break; |
||||
|
||||
case G_DESER: |
||||
if (g_deserialize (g, interp, src) != TCL_OK) { |
||||
g_delete (g); |
||||
Tcl_DecrRefCount (fqn); |
||||
return TCL_ERROR; |
||||
} |
||||
break; |
||||
} |
||||
} else { |
||||
g = g_new (); |
||||
} |
||||
|
||||
g->cmd = Tcl_CreateObjCommand2 (interp, Tcl_GetString (fqn), |
||||
g_objcmd, (ClientData) g, |
||||
gg_delete); |
||||
|
||||
Tcl_SetObjResult (interp, fqn); |
||||
Tcl_DecrRefCount (fqn); |
||||
return TCL_OK; |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,104 @@
|
||||
# map.tcl -- |
||||
# Copyright (c) 2009-2019 Andreas Kupries <andreas_kupries@sourceforge.net> |
||||
# |
||||
# Object wrapper around array/dict. Useful as key/value store in |
||||
# larger systems. |
||||
# |
||||
# Examples: |
||||
# - configuration mgmt in doctools v2 import/export managers |
||||
# - pt import/export managers |
||||
# |
||||
# Each object manages a key/value map. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5 9 |
||||
package require snit |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API |
||||
|
||||
# ATTENTION: |
||||
## |
||||
# From an API point of view the code below is equivalent to the much |
||||
# shorter `snit::type struct::map { ... }`. |
||||
# |
||||
# Then why the more complex form ? |
||||
# |
||||
# When snit compiles the class to Tcl code, and later on when methods |
||||
# are executed it will happen in the `struct` namespace. The moment |
||||
# this package is used together with `struct::set` all unqualified |
||||
# `set` statements will go bonkers, eiter in snit, or, here, in method |
||||
# `set`, because they get resolved to the `struct::set` dispatcher |
||||
# instead of `::set`. Moving the implementation a level deeper makes |
||||
# the `struct::map` namespace the context, with no conflict. |
||||
|
||||
# Future / TODO: Convert all the OO stuff here over to TclOO, as much |
||||
# as possible (snit configure/cget support is currently still better, |
||||
# ditto hierarchical methods). |
||||
|
||||
namespace eval ::struct {} |
||||
|
||||
proc ::struct::map {args} { |
||||
uplevel 1 [linsert $args 0 struct::map::I] |
||||
} |
||||
|
||||
snit::type ::struct::map::I { |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Options :: None |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Creating, destruction |
||||
|
||||
# Default constructor. |
||||
# Default destructor. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Public methods. Reading and writing the map. |
||||
|
||||
method names {} { |
||||
return [array names mymap] |
||||
} |
||||
|
||||
method get {} { |
||||
return [array get mymap] |
||||
} |
||||
|
||||
method set {name {value {}}} { |
||||
# 7 instead of 3 in the condition below, because of the 4 |
||||
# implicit arguments snit is providing to each method. |
||||
if {[llength [info level 0]] == 7} { |
||||
::set mymap($name) $value |
||||
} elseif {![info exists mymap($name)]} { |
||||
return -code error "can't read \"$name\": no such variable" |
||||
} |
||||
return $mymap($name) |
||||
} |
||||
|
||||
method unset {args} { |
||||
if {![llength $args]} { lappend args * } |
||||
foreach pattern $args { |
||||
array unset mymap $pattern |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal methods :: None. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## State :: Map data, Tcl array |
||||
|
||||
variable mymap -array {} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide struct::map 1.1 |
||||
return |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,25 @@
|
||||
if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} |
||||
package ifneeded struct 2.2 [list source [file join $dir struct.tcl]] |
||||
package ifneeded struct 1.5 [list source [file join $dir struct1.tcl]] |
||||
|
||||
package ifneeded struct::queue 1.4.6 [list source [file join $dir queue.tcl]] |
||||
package ifneeded struct::stack 1.5.4 [list source [file join $dir stack.tcl]] |
||||
package ifneeded struct::tree 2.1.3 [list source [file join $dir tree.tcl]] |
||||
package ifneeded struct::pool 1.2.4 [list source [file join $dir pool.tcl]] |
||||
package ifneeded struct::record 1.2.3 [list source [file join $dir record.tcl]] |
||||
package ifneeded struct::set 2.2.4 [list source [file join $dir sets.tcl]] |
||||
package ifneeded struct::prioqueue 1.5 [list source [file join $dir prioqueue.tcl]] |
||||
package ifneeded struct::skiplist 1.4 [list source [file join $dir skiplist.tcl]] |
||||
|
||||
package ifneeded struct::graph 1.2.2 [list source [file join $dir graph1.tcl]] |
||||
package ifneeded struct::tree 1.2.3 [list source [file join $dir tree1.tcl]] |
||||
|
||||
package ifneeded struct::list 1.8.6 [list source [file join $dir list.tcl]] |
||||
package ifneeded struct::list::test 1.8.5 [list source [file join $dir list.test.tcl]] |
||||
package ifneeded struct::graph 2.4.4 [list source [file join $dir graph.tcl]] |
||||
package ifneeded struct::map 1.1 [list source [file join $dir map.tcl]] |
||||
|
||||
package ifneeded struct::matrix 2.2 [list source [file join $dir matrix.tcl]] |
||||
|
||||
package ifneeded struct::disjointset 1.2 [list source [file join $dir disjointset.tcl]] |
||||
package ifneeded struct::graph::op 0.11.4 [list source [file join $dir graphops.tcl]] |
||||
@ -0,0 +1,715 @@
|
||||
################################################################################ |
||||
# pool.tcl |
||||
# |
||||
# |
||||
# Author: Erik Leunissen |
||||
# |
||||
# |
||||
# Acknowledgement: |
||||
# The author is grateful for the advice provided by |
||||
# Andreas Kupries during the development of this code. |
||||
# |
||||
################################################################################ |
||||
|
||||
package require cmdline |
||||
|
||||
namespace eval ::struct {} |
||||
namespace eval ::struct::pool { |
||||
|
||||
# a list of all current pool names |
||||
variable pools {} |
||||
|
||||
# counter is used to give a unique name to a pool if |
||||
# no name was supplied, e.g. pool1, pool2 etc. |
||||
variable counter 0 |
||||
|
||||
# `commands' is the list of subcommands recognized by a pool-object command |
||||
variable commands {add clear destroy info maxsize release remove request} |
||||
|
||||
# All errors with corresponding (unformatted) messages. |
||||
# The format strings will be replaced by the appropriate |
||||
# values when an error occurs. |
||||
variable Errors |
||||
array set Errors { |
||||
BAD_SUBCMD {Bad subcommand "%s": must be %s} |
||||
DUPLICATE_ITEM_IN_ARGS {Duplicate item `%s' in arguments.} |
||||
DUPLICATE_POOLNAME {The pool `%s' already exists.} |
||||
EXCEED_MAXSIZE "This command would increase the total number of items\ |
||||
\nbeyond the maximum size of the pool. No items registered." |
||||
FORBIDDEN_ALLOCID "The value -1 is not allowed as an allocID." |
||||
INVALID_POOLSIZE {The pool currently holds %s items.\ |
||||
Can't set maxsize to a value less than that.} |
||||
ITEM_ALREADY_IN_POOL {`%s' already is a member of the pool. No items registered.} |
||||
ITEM_NOT_IN_POOL {`%s' is not a member of %s.} |
||||
ITEM_NOT_ALLOCATED {Can't release `%s' because it isn't allocated.} |
||||
ITEM_STILL_ALLOCATED {Can't remove `%s' because it is still allocated.} |
||||
NONINT_REQSIZE {The second argument must be a positive integer value} |
||||
SOME_ITEMS_NOT_FREE {Couldn't %s `%s' because some items are still allocated.} |
||||
UNKNOWN_ARG {Unknown argument `%s'} |
||||
UNKNOWN_POOL {Nothing known about `%s'.} |
||||
VARNAME_EXISTS {A variable `::struct::pool::%s' already exists.} |
||||
WRONG_INFO_TYPE "Expected second argument to be one of:\ |
||||
\n allitems, allocstate, cursize, freeitems, maxsize,\ |
||||
\nbut received: `%s'." |
||||
WRONG_NARGS "wrong#args" |
||||
} |
||||
|
||||
namespace export pool |
||||
} |
||||
|
||||
# A small helper routine to generate structured errors |
||||
|
||||
if {[package vsatisfies [package present Tcl] 8.5 9]} { |
||||
# Tcl 8.5+, have expansion operator and syntax. And option -level. |
||||
proc ::struct::pool::Error {error args} { |
||||
variable Errors |
||||
return -code error -level 1 \ |
||||
-errorcode [list STRUCT POOL $error {*}$args] \ |
||||
[format $Errors($error) {*}$args] |
||||
} |
||||
} else { |
||||
# Tcl 8.4. No expansion operator available. Nor -level. |
||||
# Construct the pieces explicitly, via linsert/eval hop&dance. |
||||
proc ::struct::pool::Error {error args} { |
||||
variable Errors |
||||
lappend code STRUCT POOL $error |
||||
eval [linsert $args 0 lappend code] |
||||
set msg [eval [linsert $args 0 format $Errors($error)]] |
||||
return -code error -errorcode $code $msg |
||||
} |
||||
} |
||||
|
||||
# A small helper routine to check list membership |
||||
proc ::struct::pool::lmember {list element} { |
||||
if { [lsearch -exact $list $element] >= 0 } { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
# General note |
||||
# ============ |
||||
# |
||||
# All procedures below use the following method to reference |
||||
# a particular pool-object: |
||||
# |
||||
# variable $poolname |
||||
# upvar #0 ::struct::pool::$poolname pool |
||||
# upvar #0 ::struct::pool::Allocstate_$poolname state |
||||
# |
||||
# Therefore, the names `pool' and `state' refer to a particular |
||||
# instance of a pool. |
||||
# |
||||
# In the comments to the code below, the words `pool' and `state' |
||||
# also refer to a particular pool. |
||||
# |
||||
|
||||
# ::struct::pool::create |
||||
# |
||||
# Creates a new instance of a pool (a pool-object). |
||||
# ::struct::pool::pool (see right below) is an alias to this procedure. |
||||
# |
||||
# |
||||
# Arguments: |
||||
# poolname: name of the pool-object |
||||
# maxsize: the maximum number of elements that the pool is allowed |
||||
# consist of. |
||||
# |
||||
# |
||||
# Results: |
||||
# the name of the newly created pool |
||||
# |
||||
# |
||||
# Side effects: |
||||
# - Registers the pool-name in the variable `pools'. |
||||
# |
||||
# - Creates the pool array which holds general state about the pool. |
||||
# The following elements are initialized: |
||||
# pool(freeitems): a list of non-allocated items |
||||
# pool(cursize): the current number of elements in the pool |
||||
# pool(maxsize): the maximum allowable number of pool elements |
||||
# Additional state may be hung off this array as long as the three |
||||
# elements above are not corrupted. |
||||
# |
||||
# - Creates a separate array `state' that will hold allocation state |
||||
# of the pool elements. |
||||
# |
||||
# - Creates an object-procedure that has the same name as the pool. |
||||
# |
||||
proc ::struct::pool::create { {poolname ""} {maxsize 10} } { |
||||
variable pools |
||||
variable counter |
||||
|
||||
# check maxsize argument |
||||
if { ![string equal $maxsize 10] } { |
||||
if { ![regexp {^\+?[1-9][0-9]*$} $maxsize] } { |
||||
Error NONINT_REQSIZE |
||||
} |
||||
} |
||||
|
||||
# create a name if no name was supplied |
||||
if { [string length $poolname]==0 } { |
||||
incr counter |
||||
set poolname pool$counter |
||||
set incrcnt 1 |
||||
} |
||||
|
||||
# check whether there exists a pool named $poolname |
||||
if { [lmember $pools $poolname] } { |
||||
if { [::info exists incrcnt] } { |
||||
incr counter -1 |
||||
} |
||||
Error DUPLICATE_POOLNAME $poolname |
||||
} |
||||
|
||||
# check whether the namespace variable exists |
||||
if { [::info exists ::struct::pool::$poolname] } { |
||||
if { [::info exists incrcnt] } { |
||||
incr counter -1 |
||||
} |
||||
Error VARNAME_EXISTS $poolname |
||||
} |
||||
|
||||
variable $poolname |
||||
|
||||
# register |
||||
lappend pools $poolname |
||||
|
||||
# create and initialize the new pool data structure |
||||
upvar #0 ::struct::pool::$poolname pool |
||||
set pool(freeitems) {} |
||||
set pool(maxsize) $maxsize |
||||
set pool(cursize) 0 |
||||
|
||||
# the array that holds allocation state |
||||
upvar #0 ::struct::pool::Allocstate_$poolname state |
||||
array set state {} |
||||
|
||||
# create a pool-object command and map it to the pool commands |
||||
interp alias {} ::$poolname {} ::struct::pool::poolCmd $poolname |
||||
return $poolname |
||||
} |
||||
|
||||
# |
||||
# This alias provides compatibility with the implementation of the |
||||
# other data structures (stack, queue etc...) in the tcllib::struct package. |
||||
# |
||||
proc ::struct::pool::pool { {poolname ""} {maxsize 10} } { |
||||
::struct::pool::create $poolname $maxsize |
||||
} |
||||
|
||||
|
||||
# ::struct::pool::poolCmd |
||||
# |
||||
# This proc constitutes a level of indirection between the pool-object |
||||
# subcommand and the pool commands (below); it's sole function is to pass |
||||
# the command along to one of the pool commands, and receive any results. |
||||
# |
||||
# Arguments: |
||||
# poolname: name of the pool-object |
||||
# subcmd: the subcommand, which identifies the pool-command to |
||||
# which calls will be passed. |
||||
# args: any arguments. They will be inspected by the pool-command |
||||
# to which this call will be passed along. |
||||
# |
||||
# Results: |
||||
# Whatever result the pool command returns, is once more returned. |
||||
# |
||||
# Side effects: |
||||
# Dispatches the call onto a specific pool command and receives any results. |
||||
# |
||||
proc ::struct::pool::poolCmd {poolname subcmd args} { |
||||
# check the subcmd argument |
||||
if { [lsearch -exact $::struct::pool::commands $subcmd] == -1 } { |
||||
set optlist [join $::struct::pool::commands ", "] |
||||
set optlist [linsert $optlist "end-1" "or"] |
||||
Error BAD_SUBCMD $subcmd $optlist |
||||
} |
||||
|
||||
# pass the call to the pool command indicated by the subcmd argument, |
||||
# and return the result from that command. |
||||
return [eval [linsert $args 0 ::struct::pool::$subcmd $poolname]] |
||||
} |
||||
|
||||
|
||||
# ::struct::pool::destroy |
||||
# |
||||
# Destroys a pool-object, its associated variables and "object-command" |
||||
# |
||||
# Arguments: |
||||
# poolname: name of the pool-object |
||||
# forceArg: if set to `-force', the pool-object will be destroyed |
||||
# regardless the allocation state of its objects. |
||||
# |
||||
# Results: |
||||
# none |
||||
# |
||||
# Side effects: |
||||
# - unregisters the pool name in the variable `pools'. |
||||
# - unsets `pool' and `state' (poolname specific variables) |
||||
# - destroys the "object-procedure" that was associated with the pool. |
||||
# |
||||
proc ::struct::pool::destroy {poolname {forceArg ""}} { |
||||
variable pools |
||||
|
||||
# check forceArg argument |
||||
if { [string length $forceArg] } { |
||||
if { [string equal $forceArg -force] } { |
||||
set force 1 |
||||
} else { |
||||
Error UNKNOWN_ARG $forceArg |
||||
} |
||||
} else { |
||||
set force 0 |
||||
} |
||||
|
||||
set index [lsearch -exact $pools $poolname] |
||||
if {$index == -1 } { |
||||
Error UNKNOWN_POOL $poolname |
||||
} |
||||
|
||||
if { !$force } { |
||||
# check for any lingering allocated items |
||||
variable $poolname |
||||
upvar #0 ::struct::pool::$poolname pool |
||||
upvar #0 ::struct::pool::Allocstate_$poolname state |
||||
if { [llength $pool(freeitems)] != $pool(cursize) } { |
||||
Error SOME_ITEMS_NOT_FREE destroy $poolname |
||||
} |
||||
} |
||||
|
||||
rename ::$poolname {} |
||||
unset ::struct::pool::$poolname |
||||
catch {unset ::struct::pool::Allocstate_$poolname} |
||||
set pools [lreplace $pools $index $index] |
||||
|
||||
return |
||||
} |
||||
|
||||
|
||||
# ::struct::pool::add |
||||
# |
||||
# Add items to the pool |
||||
# |
||||
# Arguments: |
||||
# poolname: name of the pool-object |
||||
# args: the items to add |
||||
# |
||||
# Results: |
||||
# none |
||||
# |
||||
# Side effects: |
||||
# sets the initial allocation state of the added items to -1 (free) |
||||
# |
||||
proc ::struct::pool::add {poolname args} { |
||||
variable $poolname |
||||
upvar #0 ::struct::pool::$poolname pool |
||||
upvar #0 ::struct::pool::Allocstate_$poolname state |
||||
|
||||
# argument check |
||||
if { [llength $args] == 0 } { |
||||
Error WRONG_NARGS |
||||
} |
||||
|
||||
# will this operation exceed the size limit of the pool? |
||||
if {[expr { $pool(cursize) + [llength $args] }] > $pool(maxsize) } { |
||||
Error EXCEED_MAXSIZE |
||||
} |
||||
|
||||
|
||||
# check for duplicate items on the command line |
||||
set N [llength $args] |
||||
if { $N > 1} { |
||||
for {set i 0} {$i<=$N} {incr i} { |
||||
foreach item [lrange $args [expr {$i+1}] end] { |
||||
if { [string equal [lindex $args $i] $item]} { |
||||
Error DUPLICATE_ITEM_IN_ARGS $item |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
# check whether the items exist yet in the pool |
||||
foreach item $args { |
||||
if { [lmember [array names state] $item] } { |
||||
Error ITEM_ALREADY_IN_POOL $item |
||||
} |
||||
} |
||||
|
||||
# add items to the pool, and initialize their allocation state |
||||
foreach item $args { |
||||
lappend pool(freeitems) $item |
||||
set state($item) -1 |
||||
incr pool(cursize) |
||||
} |
||||
return |
||||
} |
||||
|
||||
|
||||
|
||||
# ::struct::pool::clear |
||||
# |
||||
# Removes all items from the pool and clears corresponding |
||||
# allocation state. |
||||
# |
||||
# |
||||
# Arguments: |
||||
# poolname: name of the pool-object |
||||
# forceArg: if set to `-force', all items are removed |
||||
# regardless their allocation state. |
||||
# |
||||
# Results: |
||||
# none |
||||
# |
||||
# Side effects: |
||||
# see description above |
||||
# |
||||
proc ::struct::pool::clear {poolname {forceArg ""} } { |
||||
variable $poolname |
||||
upvar #0 ::struct::pool::$poolname pool |
||||
upvar #0 ::struct::pool::Allocstate_$poolname state |
||||
|
||||
# check forceArg argument |
||||
if { [string length $forceArg] } { |
||||
if { [string equal $forceArg -force] } { |
||||
set force 1 |
||||
} else { |
||||
Error UNKNOWN_ARG $forceArg |
||||
} |
||||
} else { |
||||
set force 0 |
||||
} |
||||
|
||||
# check whether some items are still allocated |
||||
if { !$force } { |
||||
if { [llength $pool(freeitems)] != $pool(cursize) } { |
||||
Error SOME_ITEMS_NOT_FREE clear $poolname |
||||
} |
||||
} |
||||
|
||||
# clear the pool, clean up state and adjust the pool size |
||||
set pool(freeitems) {} |
||||
array unset state |
||||
array set state {} |
||||
set pool(cursize) 0 |
||||
return |
||||
} |
||||
|
||||
|
||||
|
||||
# ::struct::pool::info |
||||
# |
||||
# Returns information about the pool in data structures that allow |
||||
# further programmatic use. |
||||
# |
||||
# Arguments: |
||||
# poolname: name of the pool-object |
||||
# type: the type of info requested |
||||
# |
||||
# |
||||
# Results: |
||||
# The info requested |
||||
# |
||||
# |
||||
# Side effects: |
||||
# none |
||||
# |
||||
proc ::struct::pool::info {poolname type args} { |
||||
variable $poolname |
||||
upvar #0 ::struct::pool::$poolname pool |
||||
upvar #0 ::struct::pool::Allocstate_$poolname state |
||||
|
||||
# check the number of arguments |
||||
if { [string equal $type allocID] } { |
||||
if { [llength $args]!=1 } { |
||||
Error WRONG_NARGS |
||||
} |
||||
} elseif { [llength $args] > 0 } { |
||||
Error WRONG_NARGS |
||||
} |
||||
|
||||
switch $type { |
||||
allitems { |
||||
return [array names state] |
||||
} |
||||
allocstate { |
||||
return [array get state] |
||||
} |
||||
allocID { |
||||
set item [lindex $args 0] |
||||
if {![lmember [array names state] $item]} { |
||||
Error ITEM_NOT_IN_POOL $item $poolname |
||||
} |
||||
return $state($item) |
||||
} |
||||
cursize { |
||||
return $pool(cursize) |
||||
} |
||||
freeitems { |
||||
return $pool(freeitems) |
||||
} |
||||
maxsize { |
||||
return $pool(maxsize) |
||||
} |
||||
default { |
||||
Error WRONG_INFO_TYPE $type |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
# ::struct::pool::maxsize |
||||
# |
||||
# Returns the current or sets a new maximum size of the pool. |
||||
# As far as querying only is concerned, this is an alias for |
||||
# `::struct::pool::info maxsize'. |
||||
# |
||||
# |
||||
# Arguments: |
||||
# poolname: name of the pool-object |
||||
# reqsize: if supplied, it is the requested size of the pool, i.e. |
||||
# the maximum number of elements in the pool. |
||||
# |
||||
# |
||||
# Results: |
||||
# The current/new maximum size of the pool. |
||||
# |
||||
# |
||||
# Side effects: |
||||
# Sets pool(maxsize) if a new size is supplied. |
||||
# |
||||
proc ::struct::pool::maxsize {poolname {reqsize ""} } { |
||||
variable $poolname |
||||
upvar #0 ::struct::pool::$poolname pool |
||||
upvar #0 ::struct::pool::Allocstate_$poolname state |
||||
|
||||
if { [string length $reqsize] } { |
||||
if { [regexp {^\+?[1-9][0-9]*$} $reqsize] } { |
||||
if { $pool(cursize) <= $reqsize } { |
||||
set pool(maxsize) $reqsize |
||||
} else { |
||||
Error INVALID_POOLSIZE $pool(cursize) |
||||
} |
||||
} else { |
||||
Error NONINT_REQSIZE |
||||
} |
||||
} |
||||
return $pool(maxsize) |
||||
} |
||||
|
||||
|
||||
# ::struct::pool::release |
||||
# |
||||
# Deallocates an item |
||||
# |
||||
# |
||||
# Arguments: |
||||
# poolname: name of the pool-object |
||||
# item: name of the item to be released |
||||
# |
||||
# |
||||
# Results: |
||||
# none |
||||
# |
||||
# Side effects: |
||||
# - sets the item's allocation state to free (-1) |
||||
# - appends item to the list of free items |
||||
# |
||||
proc ::struct::pool::release {poolname item} { |
||||
variable $poolname |
||||
upvar #0 ::struct::pool::$poolname pool |
||||
upvar #0 ::struct::pool::Allocstate_$poolname state |
||||
|
||||
# Is item in the pool? |
||||
if {![lmember [array names state] $item]} { |
||||
Error ITEM_NOT_IN_POOL $item $poolname |
||||
} |
||||
|
||||
# check whether item was allocated |
||||
if { $state($item) == -1 } { |
||||
Error ITEM_NOT_ALLOCATED $item |
||||
} else { |
||||
|
||||
# set item free and return it to the pool of free items |
||||
set state($item) -1 |
||||
lappend pool(freeitems) $item |
||||
|
||||
} |
||||
return |
||||
} |
||||
|
||||
# ::struct::pool::remove |
||||
# |
||||
# Removes an item from the pool |
||||
# |
||||
# |
||||
# Arguments: |
||||
# poolname: name of the pool-object |
||||
# item: the item to be removed |
||||
# forceArg: if set to `-force', the item is removed |
||||
# regardless its allocation state. |
||||
# |
||||
# Results: |
||||
# none |
||||
# |
||||
# Side effects: |
||||
# - cleans up allocation state related to the item |
||||
# |
||||
proc ::struct::pool::remove {poolname item {forceArg ""} } { |
||||
variable $poolname |
||||
upvar #0 ::struct::pool::$poolname pool |
||||
upvar #0 ::struct::pool::Allocstate_$poolname state |
||||
|
||||
# check forceArg argument |
||||
if { [string length $forceArg] } { |
||||
if { [string equal $forceArg -force] } { |
||||
set force 1 |
||||
} else { |
||||
Error UNKNOWN_ARG $forceArg |
||||
} |
||||
} else { |
||||
set force 0 |
||||
} |
||||
|
||||
# Is item in the pool? |
||||
if {![lmember [array names state] $item]} { |
||||
Error ITEM_NOT_IN_POOL $item $poolname |
||||
} |
||||
|
||||
set index [lsearch $pool(freeitems) $item] |
||||
if { $index >= 0} { |
||||
|
||||
# actual removal |
||||
set pool(freeitems) [lreplace $pool(freeitems) $index $index] |
||||
|
||||
} elseif { !$force } { |
||||
Error ITEM_STILL_ALLOCATED $item |
||||
} |
||||
|
||||
# clean up state and adjust the pool size |
||||
unset state($item) |
||||
incr pool(cursize) -1 |
||||
return |
||||
} |
||||
|
||||
|
||||
|
||||
# ::struct::pool::request |
||||
# |
||||
# Handles requests for an item, taking into account a preference |
||||
# for a particular item if supplied. |
||||
# |
||||
# |
||||
# Arguments: |
||||
# poolname: name of the pool-object |
||||
# |
||||
# itemvar: variable to which the item-name will be assigned |
||||
# if the request is honored. |
||||
# |
||||
# args: an optional sequence of key-value pairs, indicating the |
||||
# following options: |
||||
# -prefer: the preferred item to allocate. |
||||
# -allocID: An ID for the entity to which the item will be |
||||
# allocated. This facilitates reverse lookups. |
||||
# |
||||
# Results: |
||||
# |
||||
# 1 if the request was honored; an item is allocated |
||||
# 0 if the request couldn't be honored; no item is allocated |
||||
# |
||||
# The user is strongly advised to check the return values |
||||
# when calling this procedure. |
||||
# |
||||
# |
||||
# Side effects: |
||||
# |
||||
# if the request is honored: |
||||
# - sets allocation state to $allocID (or dummyID if it was not supplied) |
||||
# if allocation was succesful. Allocation state is maintained in the |
||||
# namespace variable state (see: `General note' above) |
||||
# - sets the variable passed via `itemvar' to the allocated item. |
||||
# |
||||
# if the request is denied, no side effects occur. |
||||
# |
||||
proc ::struct::pool::request {poolname itemvar args} { |
||||
variable $poolname |
||||
upvar #0 ::struct::pool::$poolname pool |
||||
upvar #0 ::struct::pool::Allocstate_$poolname state |
||||
|
||||
# check args |
||||
set nargs [llength $args] |
||||
if { ! ($nargs==0 || $nargs==2 || $nargs==4) } { |
||||
if { ![string equal $args -?] && ![string equal $args -help]} { |
||||
Error WRONG_NARGS |
||||
} |
||||
} elseif { $nargs } { |
||||
foreach {name value} $args { |
||||
if { ![string match -* $name] } { |
||||
Error UNKNOWN_ARG $name |
||||
} |
||||
} |
||||
} |
||||
|
||||
set allocated 0 |
||||
|
||||
# are there any items available? |
||||
if { [llength $pool(freeitems)] > 0} { |
||||
|
||||
# process command options |
||||
set options [cmdline::getoptions args { \ |
||||
{prefer.arg {} {The preference for a particular item}} \ |
||||
{allocID.arg {} {An ID for the entity to which the item will be allocated} } \ |
||||
} \ |
||||
"usage: $poolname request itemvar ?options?:"] |
||||
foreach {key value} $options { |
||||
set $key $value |
||||
} |
||||
|
||||
if { $allocID == -1 } { |
||||
Error FORBIDDEN_ALLOCID |
||||
} |
||||
|
||||
# let `item' point to a variable two levels up the call stack |
||||
upvar 2 $itemvar item |
||||
|
||||
# check whether a preference was supplied |
||||
if { [string length $prefer] } { |
||||
if {![lmember [array names state] $prefer]} { |
||||
Error ITEM_NOT_IN_POOL $prefer $poolname |
||||
} |
||||
if { $state($prefer) == -1 } { |
||||
set index [lsearch $pool(freeitems) $prefer] |
||||
set item $prefer |
||||
} else { |
||||
return 0 |
||||
} |
||||
} else { |
||||
set index 0 |
||||
set item [lindex $pool(freeitems) 0] |
||||
} |
||||
|
||||
# do the actual allocation |
||||
set pool(freeitems) [lreplace $pool(freeitems) $index $index] |
||||
if { [string length $allocID] } { |
||||
set state($item) $allocID |
||||
} else { |
||||
set state($item) dummyID |
||||
} |
||||
set allocated 1 |
||||
} |
||||
return $allocated |
||||
} |
||||
|
||||
|
||||
# EOF pool.tcl |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Get 'pool::pool' into the general structure namespace. |
||||
namespace import -force pool::pool |
||||
namespace export pool |
||||
} |
||||
package provide struct::pool 1.2.4 |
||||
@ -0,0 +1,535 @@
|
||||
# prioqueue.tcl -- |
||||
# |
||||
# Priority Queue implementation for Tcl. |
||||
# |
||||
# adapted from queue.tcl |
||||
# Copyright (c) 2002,2003 Michael Schlenker |
||||
# Copyright (c) 2008 Alejandro Paz <vidriloco@gmail.com> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: prioqueue.tcl,v 1.10 2008/09/04 04:35:02 andreas_kupries Exp $ |
||||
|
||||
package require Tcl 8.5 9 |
||||
|
||||
namespace eval ::struct {} |
||||
|
||||
namespace eval ::struct::prioqueue { |
||||
# The queues array holds all of the queues you've made |
||||
variable queues |
||||
|
||||
# counter is used to give a unique name for unnamed queues |
||||
variable counter 0 |
||||
|
||||
# commands is the list of subcommands recognized by the queue |
||||
variable commands [list \ |
||||
"clear" \ |
||||
"destroy" \ |
||||
"get" \ |
||||
"peek" \ |
||||
"put" \ |
||||
"remove" \ |
||||
"size" \ |
||||
"peekpriority" \ |
||||
] |
||||
|
||||
variable sortopt [list \ |
||||
"-integer" \ |
||||
"-real" \ |
||||
"-ascii" \ |
||||
"-dictionary" \ |
||||
] |
||||
|
||||
# this is a simple design decision, that integer and real |
||||
# are sorted decreasing (-1), and -ascii and -dictionary are sorted -increasing (1) |
||||
# the values here map to the sortopt list |
||||
# could be changed to something configurable. |
||||
variable sortdir [list \ |
||||
"-1" \ |
||||
"-1" \ |
||||
"1" \ |
||||
"1" \ |
||||
] |
||||
|
||||
|
||||
|
||||
# Only export one command, the one used to instantiate a new queue |
||||
namespace export prioqueue |
||||
|
||||
proc K {x y} {set x} ;# DKF's K combinator |
||||
} |
||||
|
||||
# ::struct::prioqueue::prioqueue -- |
||||
# |
||||
# Create a new prioqueue with a given name; if no name is given, use |
||||
# prioqueueX, where X is a number. |
||||
# |
||||
# Arguments: |
||||
# sorting sorting option for lsort to use, no -command option |
||||
# defaults to integer |
||||
# name name of the queue; if null, generate one. |
||||
# names may not begin with - |
||||
# |
||||
# |
||||
# Results: |
||||
# name name of the queue created |
||||
|
||||
proc ::struct::prioqueue::prioqueue {args} { |
||||
variable queues |
||||
variable counter |
||||
variable queues_sorting |
||||
variable sortopt |
||||
|
||||
# check args |
||||
if {[llength $args] > 2} { |
||||
error "wrong # args: should be \"[lindex [info level 0] 0] ?-ascii|-dictionary|-integer|-real? ?name?\"" |
||||
} |
||||
if {[llength $args] == 0} { |
||||
# defaulting to integer priorities |
||||
set sorting -integer |
||||
} else { |
||||
if {[llength $args] == 1} { |
||||
if {[string match "-*" [lindex $args 0]]==1} { |
||||
set sorting [lindex $args 0] |
||||
} else { |
||||
set sorting -integer |
||||
set name [lindex $args 0] |
||||
} |
||||
} else { |
||||
if {[llength $args] == 2} { |
||||
foreach {sorting name} $args {break} |
||||
} |
||||
} |
||||
} |
||||
# check option (like lsort sorting options without -command) |
||||
if {[lsearch $sortopt $sorting] == -1} { |
||||
# if sortoption is unknown, but name is a sortoption we give a better error message |
||||
if {[info exists name] && [lsearch $sortopt $name]!=-1} { |
||||
error "wrong argument position: should be \"[lindex [info level 0] 0] ?-ascii|-dictionary|-integer|-real? ?name?\"" |
||||
} |
||||
error "unknown sort option \"$sorting\"" |
||||
} |
||||
# create name if not given |
||||
if {![info exists name]} { |
||||
incr counter |
||||
set name "prioqueue${counter}" |
||||
} |
||||
|
||||
if { ![string equal [info commands ::$name] ""] } { |
||||
error "command \"$name\" already exists, unable to create prioqueue" |
||||
} |
||||
|
||||
# Initialize the queue as empty |
||||
set queues($name) [list ] |
||||
switch -exact -- $sorting { |
||||
-integer { set queues_sorting($name) 0} |
||||
-real { set queues_sorting($name) 1} |
||||
-ascii { set queues_sorting($name) 2} |
||||
-dictionary { set queues_sorting($name) 3} |
||||
} |
||||
|
||||
# Create the command to manipulate the queue |
||||
interp alias {} ::$name {} ::struct::prioqueue::QueueProc $name |
||||
|
||||
return $name |
||||
} |
||||
|
||||
########################## |
||||
# Private functions follow |
||||
|
||||
# ::struct::prioqueue::QueueProc -- |
||||
# |
||||
# Command that processes all queue object commands. |
||||
# |
||||
# Arguments: |
||||
# name name of the queue object to manipulate. |
||||
# args command name and args for the command |
||||
# |
||||
# Results: |
||||
# Varies based on command to perform |
||||
|
||||
proc ::struct::prioqueue::QueueProc {name {cmd ""} args} { |
||||
# Do minimal args checks here |
||||
if { [llength [info level 0]] == 2 } { |
||||
error "wrong # args: should be \"$name option ?arg arg ...?\"" |
||||
} |
||||
|
||||
# Split the args into command and args components |
||||
if { [string equal [info commands ::struct::prioqueue::_$cmd] ""] } { |
||||
variable commands |
||||
set optlist [join $commands ", "] |
||||
set optlist [linsert $optlist "end-1" "or"] |
||||
error "bad option \"$cmd\": must be $optlist" |
||||
} |
||||
return [eval [linsert $args 0 ::struct::prioqueue::_$cmd $name]] |
||||
} |
||||
|
||||
# ::struct::prioqueue::_clear -- |
||||
# |
||||
# Clear a queue. |
||||
# |
||||
# Arguments: |
||||
# name name of the queue object. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::prioqueue::_clear {name} { |
||||
variable queues |
||||
set queues($name) [list] |
||||
return |
||||
} |
||||
|
||||
# ::struct::prioqueue::_destroy -- |
||||
# |
||||
# Destroy a queue object by removing it's storage space and |
||||
# eliminating it's proc. |
||||
# |
||||
# Arguments: |
||||
# name name of the queue object. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::prioqueue::_destroy {name} { |
||||
variable queues |
||||
variable queues_sorting |
||||
unset queues($name) |
||||
unset queues_sorting($name) |
||||
interp alias {} ::$name {} |
||||
return |
||||
} |
||||
|
||||
# ::struct::prioqueue::_get -- |
||||
# |
||||
# Get an item from a queue. |
||||
# |
||||
# Arguments: |
||||
# name name of the queue object. |
||||
# count number of items to get; defaults to 1 |
||||
# |
||||
# Results: |
||||
# item first count items from the queue; if there are not enough |
||||
# items in the queue, throws an error. |
||||
# |
||||
|
||||
proc ::struct::prioqueue::_get {name {count 1}} { |
||||
variable queues |
||||
if { $count < 1 } { |
||||
error "invalid item count $count" |
||||
} |
||||
|
||||
if { $count > [llength $queues($name)] } { |
||||
error "insufficient items in prioqueue to fill request" |
||||
} |
||||
|
||||
if { $count == 1 } { |
||||
# Handle this as a special case, so single item gets aren't listified |
||||
set item [lindex [lindex $queues($name) 0] 1] |
||||
set queues($name) [lreplace [K $queues($name) [set queues($name) ""]] 0 0] |
||||
return $item |
||||
} |
||||
|
||||
# Otherwise, return a list of items |
||||
incr count -1 |
||||
set items [lrange $queues($name) 0 $count] |
||||
foreach item $items { |
||||
lappend result [lindex $item 1] |
||||
} |
||||
set items "" |
||||
|
||||
set queues($name) [lreplace [K $queues($name) [set queues($name) ""]] 0 $count] |
||||
return $result |
||||
} |
||||
|
||||
# ::struct::prioqueue::_peek -- |
||||
# |
||||
# Retrive the value of an item on the queue without removing it. |
||||
# |
||||
# Arguments: |
||||
# name name of the queue object. |
||||
# count number of items to peek; defaults to 1 |
||||
# |
||||
# Results: |
||||
# items top count items from the queue; if there are not enough items |
||||
# to fufill the request, throws an error. |
||||
|
||||
proc ::struct::prioqueue::_peek {name {count 1}} { |
||||
variable queues |
||||
if { $count < 1 } { |
||||
error "invalid item count $count" |
||||
} |
||||
|
||||
if { $count > [llength $queues($name)] } { |
||||
error "insufficient items in prioqueue to fill request" |
||||
} |
||||
|
||||
if { $count == 1 } { |
||||
# Handle this as a special case, so single item pops aren't listified |
||||
return [lindex [lindex $queues($name) 0] 1] |
||||
} |
||||
|
||||
# Otherwise, return a list of items |
||||
set index [expr {$count - 1}] |
||||
foreach item [lrange $queues($name) 0 $index] { |
||||
lappend result [lindex $item 1] |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# ::struct::prioqueue::_peekpriority -- |
||||
# |
||||
# Retrive the priority of an item on the queue without removing it. |
||||
# |
||||
# Arguments: |
||||
# name name of the queue object. |
||||
# count number of items to peek; defaults to 1 |
||||
# |
||||
# Results: |
||||
# items top count items from the queue; if there are not enough items |
||||
# to fufill the request, throws an error. |
||||
|
||||
proc ::struct::prioqueue::_peekpriority {name {count 1}} { |
||||
variable queues |
||||
if { $count < 1 } { |
||||
error "invalid item count $count" |
||||
} |
||||
|
||||
if { $count > [llength $queues($name)] } { |
||||
error "insufficient items in prioqueue to fill request" |
||||
} |
||||
|
||||
if { $count == 1 } { |
||||
# Handle this as a special case, so single item pops aren't listified |
||||
return [lindex [lindex $queues($name) 0] 0] |
||||
} |
||||
|
||||
# Otherwise, return a list of items |
||||
set index [expr {$count - 1}] |
||||
foreach item [lrange $queues($name) 0 $index] { |
||||
lappend result [lindex $item 0] |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
|
||||
# ::struct::prioqueue::_put -- |
||||
# |
||||
# Put an item into a queue. |
||||
# |
||||
# Arguments: |
||||
# name name of the queue object |
||||
# args list of the form "item1 prio1 item2 prio2 item3 prio3" |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::prioqueue::_put {name args} { |
||||
variable queues |
||||
variable queues_sorting |
||||
variable sortopt |
||||
variable sortdir |
||||
|
||||
if { [llength $args] == 0 || [llength $args] % 2} { |
||||
error "wrong # args: should be \"$name put item prio ?item prio ...?\"" |
||||
} |
||||
|
||||
# check for prio type before adding |
||||
switch -exact -- $queues_sorting($name) { |
||||
0 { |
||||
foreach {item prio} $args { |
||||
if {![string is integer -strict $prio]} { |
||||
error "priority \"$prio\" is not an integer type value" |
||||
} |
||||
} |
||||
} |
||||
1 { |
||||
foreach {item prio} $args { |
||||
if {![string is double -strict $prio]} { |
||||
error "priority \"$prio\" is not a real type value" |
||||
} |
||||
} |
||||
} |
||||
default { |
||||
#no restrictions for -ascii and -dictionary |
||||
} |
||||
} |
||||
|
||||
# sort by priorities |
||||
set opt [lindex $sortopt $queues_sorting($name)] |
||||
set dir [lindex $sortdir $queues_sorting($name)] |
||||
|
||||
# add only if check has passed |
||||
foreach {item prio} $args { |
||||
set new [list $prio $item] |
||||
set queues($name) [__linsertsorted [K $queues($name) [set queues($name) ""]] $new $opt $dir] |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ::struct::prioqueue::_remove -- |
||||
# |
||||
# Delete an item together with it's related priority value from the queue. |
||||
# |
||||
# Arguments: |
||||
# name name of the queue object |
||||
# item item to be removed |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
if {[package vcompare [package present Tcl] 8.5] < 0} { |
||||
# 8.4-: We have -index option for lsearch, so we use glob to allow |
||||
# us to create a pattern which can ignore the priority value. We |
||||
# quote everything in the item to prevent it from being |
||||
# glob-matched, exact matching is required. |
||||
|
||||
proc ::struct::prioqueue::_remove {name item} { |
||||
variable queues |
||||
set queuelist $queues($name) |
||||
set itemrep "* \\[join [split $item {}] "\\"]" |
||||
set foundat [lsearch -glob $queuelist $itemrep] |
||||
|
||||
# the item to remove was not found if foundat remains at -1, |
||||
# nothing to replace then |
||||
if {$foundat < 0} return |
||||
set queues($name) [lreplace $queuelist $foundat $foundat] |
||||
return |
||||
} |
||||
} else { |
||||
# 8.5+: We have the -index option, allowing us to exactly address |
||||
# the column used to search. |
||||
|
||||
proc ::struct::prioqueue::_remove {name item} { |
||||
variable queues |
||||
set queuelist $queues($name) |
||||
set foundat [lsearch -index 1 -exact $queuelist $item] |
||||
|
||||
# the item to remove was not found if foundat remains at -1, |
||||
# nothing to replace then |
||||
if {$foundat < 0} return |
||||
set queues($name) [lreplace $queuelist $foundat $foundat] |
||||
return |
||||
} |
||||
} |
||||
|
||||
# ::struct::prioqueue::_size -- |
||||
# |
||||
# Return the number of objects on a queue. |
||||
# |
||||
# Arguments: |
||||
# name name of the queue object. |
||||
# |
||||
# Results: |
||||
# count number of items on the queue. |
||||
|
||||
proc ::struct::prioqueue::_size {name} { |
||||
variable queues |
||||
return [llength $queues($name)] |
||||
} |
||||
|
||||
# ::struct::prioqueue::__linsertsorted |
||||
# |
||||
# Helper proc for inserting into a sorted list. |
||||
# |
||||
# |
||||
|
||||
proc ::struct::prioqueue::__linsertsorted {list newElement sortopt sortdir} { |
||||
|
||||
set cmpcmd __elementcompare${sortopt} |
||||
set pos -1 |
||||
set newPrio [lindex $newElement 0] |
||||
|
||||
# do a binary search |
||||
set lower -1 |
||||
set upper [llength $list] |
||||
set bound [expr {$upper+1}] |
||||
set pivot 0 |
||||
|
||||
if {$upper > 0} { |
||||
while {$lower +1 != $upper } { |
||||
|
||||
# get the pivot element |
||||
set pivot [expr {($lower + $upper) / 2}] |
||||
set element [lindex $list $pivot] |
||||
set prio [lindex $element 0] |
||||
|
||||
# check |
||||
set test [$cmpcmd $prio $newPrio $sortdir] |
||||
if {$test == 0} { |
||||
set pos $pivot |
||||
set upper $pivot |
||||
# now break as we need the last item |
||||
break |
||||
} elseif {$test > 0 } { |
||||
# search lower section |
||||
set upper $pivot |
||||
set bound $upper |
||||
set pos -1 |
||||
} else { |
||||
# search upper section |
||||
set lower $pivot |
||||
set pos $bound |
||||
} |
||||
} |
||||
|
||||
|
||||
if {$pos == -1} { |
||||
# we do an insert before the pivot element |
||||
set pos $pivot |
||||
} |
||||
|
||||
# loop to the last matching element to |
||||
# keep a stable insertion order |
||||
while {[$cmpcmd $prio $newPrio $sortdir]==0} { |
||||
incr pos |
||||
if {$pos > [llength $list]} {break} |
||||
set element [lindex $list $pos] |
||||
set prio [lindex $element 0] |
||||
} |
||||
|
||||
} else { |
||||
set pos 0 |
||||
} |
||||
|
||||
# do the insert without copying |
||||
linsert [K $list [set list ""]] $pos $newElement |
||||
} |
||||
|
||||
# ::struct::prioqueue::__elementcompare |
||||
# |
||||
# Compare helpers with the sort options. |
||||
# |
||||
# |
||||
|
||||
proc ::struct::prioqueue::__elementcompare-integer {prio newPrio sortdir} { |
||||
return [expr {$prio < $newPrio ? -1*$sortdir : ($prio != $newPrio)*$sortdir}] |
||||
} |
||||
|
||||
proc ::struct::prioqueue::__elementcompare-real {prio newPrio sortdir} { |
||||
return [expr {$prio < $newPrio ? -1*$sortdir : ($prio != $newPrio)*$sortdir}] |
||||
} |
||||
|
||||
proc ::struct::prioqueue::__elementcompare-ascii {prio newPrio sortdir} { |
||||
return [expr {[string compare $prio $newPrio]*$sortdir}] |
||||
} |
||||
|
||||
proc ::struct::prioqueue::__elementcompare-dictionary {prio newPrio sortdir} { |
||||
# need to use lsort to access -dictionary sorting |
||||
set tlist [lsort -increasing -dictionary [list $prio $newPrio]] |
||||
set e1 [string equal [lindex $tlist 0] $prio] |
||||
set e2 [string equal [lindex $tlist 1] $prio] |
||||
return [expr {$e1 > $e2 ? -1*$sortdir : ($e1 != $e2)*$sortdir}] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Get 'prioqueue::prioqueue' into the general structure namespace. |
||||
namespace import -force prioqueue::prioqueue |
||||
namespace export prioqueue |
||||
} |
||||
|
||||
package provide struct::prioqueue 1.5 |
||||
@ -0,0 +1,183 @@
|
||||
# queue.tcl -- |
||||
# |
||||
# Implementation of a queue data structure for Tcl. |
||||
# |
||||
# Copyright (c) 1998-2000 by Ajuba Solutions. |
||||
# Copyright (c) 2008 by Andreas Kupries |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: queue.tcl,v 1.16 2012/11/21 22:36:18 andreas_kupries Exp $ |
||||
|
||||
# @mdgen EXCLUDE: queue_c.tcl |
||||
|
||||
package require Tcl 8.5 9 |
||||
namespace eval ::struct::queue {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Management of queue implementations. |
||||
|
||||
# ::struct::queue::LoadAccelerator -- |
||||
# |
||||
# Loads a named implementation, if possible. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to load. |
||||
# |
||||
# Results: |
||||
# A boolean flag. True if the implementation |
||||
# was successfully loaded; and False otherwise. |
||||
|
||||
proc ::struct::queue::LoadAccelerator {key} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $key { |
||||
critcl { |
||||
# Critcl implementation of queue requires Tcl 8.4. |
||||
if {[catch {package require tcllibc}]} {return 0} |
||||
set r [llength [info commands ::struct::queue_critcl]] |
||||
} |
||||
tcl { |
||||
variable selfdir |
||||
if {![catch {package require TclOO 0.6.1-}]} { |
||||
source [file join $selfdir queue_oo.tcl] |
||||
} else { |
||||
source [file join $selfdir queue_tcl.tcl] |
||||
} |
||||
set r 1 |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator/impl. package $key:\ |
||||
must be one of [join [KnownImplementations] {, }]" |
||||
} |
||||
} |
||||
set accel($key) $r |
||||
return $r |
||||
} |
||||
|
||||
# ::struct::queue::SwitchTo -- |
||||
# |
||||
# Activates a loaded named implementation. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to activate. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::queue::SwitchTo {key} { |
||||
variable accel |
||||
variable loaded |
||||
|
||||
if {[string equal $key $loaded]} { |
||||
# No change, nothing to do. |
||||
return |
||||
} elseif {![string equal $key ""]} { |
||||
# Validate the target implementation of the switch. |
||||
|
||||
if {![info exists accel($key)]} { |
||||
return -code error "Unable to activate unknown implementation \"$key\"" |
||||
} elseif {![info exists accel($key)] || !$accel($key)} { |
||||
return -code error "Unable to activate missing implementation \"$key\"" |
||||
} |
||||
} |
||||
|
||||
# Deactivate the previous implementation, if there was any. |
||||
|
||||
if {![string equal $loaded ""]} { |
||||
rename ::struct::queue ::struct::queue_$loaded |
||||
} |
||||
|
||||
# Activate the new implementation, if there is any. |
||||
|
||||
if {![string equal $key ""]} { |
||||
rename ::struct::queue_$key ::struct::queue |
||||
} |
||||
|
||||
# Remember the active implementation, for deactivation by future |
||||
# switches. |
||||
|
||||
set loaded $key |
||||
return |
||||
} |
||||
|
||||
# ::struct::queue::Implementations -- |
||||
# |
||||
# Determines which implementations are |
||||
# present, i.e. loaded. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. |
||||
|
||||
proc ::struct::queue::Implementations {} { |
||||
variable accel |
||||
set res {} |
||||
foreach n [array names accel] { |
||||
if {!$accel($n)} continue |
||||
lappend res $n |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::struct::queue::KnownImplementations -- |
||||
# |
||||
# Determines which implementations are known |
||||
# as possible implementations. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. In the order |
||||
# of preference, most prefered first. |
||||
|
||||
proc ::struct::queue::KnownImplementations {} { |
||||
return {critcl tcl} |
||||
} |
||||
|
||||
proc ::struct::queue::Names {} { |
||||
return { |
||||
critcl {tcllibc based} |
||||
tcl {pure Tcl} |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Data structures. |
||||
|
||||
namespace eval ::struct::queue { |
||||
variable selfdir [file dirname [info script]] |
||||
variable accel |
||||
array set accel {tcl 0 critcl 0} |
||||
variable loaded {} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Choose an implementation, |
||||
## most prefered first. Loads only one of the |
||||
## possible implementations. And activates it. |
||||
|
||||
namespace eval ::struct::queue { |
||||
variable e |
||||
foreach e [KnownImplementations] { |
||||
if {[LoadAccelerator $e]} { |
||||
SwitchTo $e |
||||
break |
||||
} |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Export the constructor command. |
||||
namespace export queue |
||||
} |
||||
|
||||
package provide struct::queue 1.4.6 |
||||
@ -0,0 +1,151 @@
|
||||
# queuec.tcl -- |
||||
# |
||||
# Implementation of a queue data structure for Tcl. |
||||
# This code based on critcl, API compatible to the PTI [x]. |
||||
# [x] Pure Tcl Implementation. |
||||
# |
||||
# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: queue_c.tcl,v 1.2 2011/04/21 17:51:55 andreas_kupries Exp $ |
||||
|
||||
package require critcl |
||||
# @sak notprovided struct_queuec |
||||
package provide struct_queuec 1.3.1 |
||||
package require Tcl 8.5 9 |
||||
|
||||
namespace eval ::struct { |
||||
# Supporting code for the main command. |
||||
|
||||
critcl::cheaders queue/*.h |
||||
critcl::csources queue/*.c |
||||
|
||||
critcl::ccode { |
||||
/* -*- c -*- */ |
||||
|
||||
#include <util.h> |
||||
#include <q.h> |
||||
#include <ms.h> |
||||
#include <m.h> |
||||
|
||||
/* .................................................. */ |
||||
/* Global queue management, per interp |
||||
*/ |
||||
|
||||
typedef struct QDg { |
||||
long int counter; |
||||
char buf [50]; |
||||
} QDg; |
||||
|
||||
static void |
||||
QDgrelease (ClientData cd, Tcl_Interp* interp) |
||||
{ |
||||
ckfree((char*) cd); |
||||
} |
||||
|
||||
static CONST char* |
||||
QDnewName (Tcl_Interp* interp) |
||||
{ |
||||
#define KEY "tcllib/struct::queue/critcl" |
||||
|
||||
Tcl_InterpDeleteProc* proc = QDgrelease; |
||||
QDg* qdg; |
||||
|
||||
qdg = Tcl_GetAssocData (interp, KEY, &proc); |
||||
if (qdg == NULL) { |
||||
qdg = (QDg*) ckalloc (sizeof (QDg)); |
||||
qdg->counter = 0; |
||||
|
||||
Tcl_SetAssocData (interp, KEY, proc, |
||||
(ClientData) qdg); |
||||
} |
||||
|
||||
qdg->counter ++; |
||||
sprintf (qdg->buf, "queue%ld", qdg->counter); |
||||
return qdg->buf; |
||||
|
||||
#undef KEY |
||||
} |
||||
|
||||
static void |
||||
QDdeleteCmd (ClientData clientData) |
||||
{ |
||||
/* Release the whole queue. */ |
||||
qu_delete ((Q*) clientData); |
||||
} |
||||
} |
||||
|
||||
# Main command, queue creation. |
||||
|
||||
critcl::ccommand queue_critcl {dummy interp objc objv} { |
||||
/* Syntax |
||||
* - epsilon |1 |
||||
* - name |2 |
||||
*/ |
||||
|
||||
CONST char* name; |
||||
Q* qd; |
||||
Tcl_Obj* fqn; |
||||
Tcl_CmdInfo ci; |
||||
|
||||
#define USAGE "?name?" |
||||
|
||||
if ((objc != 2) && (objc != 1)) { |
||||
Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
if (objc < 2) { |
||||
name = QDnewName (interp); |
||||
} else { |
||||
name = Tcl_GetString (objv [1]); |
||||
} |
||||
|
||||
if (!Tcl_StringMatch (name, "::*")) { |
||||
/* Relative name. Prefix with current namespace */ |
||||
|
||||
Tcl_Eval (interp, "namespace current"); |
||||
fqn = Tcl_GetObjResult (interp); |
||||
fqn = Tcl_DuplicateObj (fqn); |
||||
Tcl_IncrRefCount (fqn); |
||||
|
||||
if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { |
||||
Tcl_AppendToObj (fqn, "::", -1); /* OK tcl9 */ |
||||
} |
||||
Tcl_AppendToObj (fqn, name, -1); /* OK tcl9 */ |
||||
} else { |
||||
fqn = Tcl_NewStringObj (name, -1); /* OK tcl9 */ |
||||
Tcl_IncrRefCount (fqn); |
||||
} |
||||
Tcl_ResetResult (interp); |
||||
|
||||
if (Tcl_GetCommandInfo (interp, |
||||
Tcl_GetString (fqn), |
||||
&ci)) { |
||||
Tcl_Obj* err; |
||||
|
||||
err = Tcl_NewObj (); |
||||
Tcl_AppendToObj (err, "command \"", -1); /* OK tcl9 */ |
||||
Tcl_AppendObjToObj (err, fqn); |
||||
Tcl_AppendToObj (err, "\" already exists, unable to create queue", -1); /* OK tcl9 */ |
||||
|
||||
Tcl_DecrRefCount (fqn); |
||||
Tcl_SetObjResult (interp, err); |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
qd = qu_new(); |
||||
qd->cmd = Tcl_CreateObjCommand2 (interp, Tcl_GetString (fqn), |
||||
qums_objcmd, (ClientData) qd, |
||||
QDdeleteCmd); |
||||
|
||||
Tcl_SetObjResult (interp, fqn); |
||||
Tcl_DecrRefCount (fqn); |
||||
return TCL_OK; |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
@ -0,0 +1,228 @@
|
||||
# queue.tcl -- |
||||
# |
||||
# Queue implementation for Tcl. |
||||
# |
||||
# Copyright (c) 1998-2000 by Ajuba Solutions. |
||||
# Copyright (c) 2008-2010 Andreas Kupries |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: queue_oo.tcl,v 1.2 2010/09/10 17:31:04 andreas_kupries Exp $ |
||||
|
||||
package require Tcl 8.5 9 |
||||
package require TclOO 0.6.1- ; # This includes 1 and higher. |
||||
|
||||
# Cleanup first |
||||
catch {namespace delete ::struct::queue::queue_oo} |
||||
catch {rename ::struct::queue::queue_oo {}} |
||||
oo::class create ::struct::queue::queue_oo { |
||||
|
||||
variable qat qret qadd |
||||
|
||||
# variable qat - Index in qret of next element to return |
||||
# variable qret - List of elements waiting for return |
||||
# variable qadd - List of elements added and not yet reached for return. |
||||
|
||||
constructor {} { |
||||
set qat 0 |
||||
set qret [list] |
||||
set qadd [list] |
||||
return |
||||
} |
||||
|
||||
# clear -- |
||||
# |
||||
# Clear a queue. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
method clear {} { |
||||
set qat 0 |
||||
set qret [list] |
||||
set qadd [list] |
||||
return |
||||
} |
||||
|
||||
# get -- |
||||
# |
||||
# Get an item from a queue. |
||||
# |
||||
# Arguments: |
||||
# count number of items to get; defaults to 1 |
||||
# |
||||
# Results: |
||||
# item first count items from the queue; if there are not enough |
||||
# items in the queue, throws an error. |
||||
|
||||
method get {{count 1}} { |
||||
if { $count < 1 } { |
||||
return -code error "invalid item count $count" |
||||
} elseif { $count > [my size] } { |
||||
return -code error "insufficient items in queue to fill request" |
||||
} |
||||
|
||||
my Shift? |
||||
|
||||
if { $count == 1 } { |
||||
# Handle this as a special case, so single item gets aren't |
||||
# listified |
||||
|
||||
set item [lindex $qret $qat] |
||||
incr qat |
||||
my Shift? |
||||
return $item |
||||
} |
||||
|
||||
# Otherwise, return a list of items |
||||
|
||||
if {$count > ([llength $qret] - $qat)} { |
||||
# Need all of qret (from qat on) and parts of qadd, maybe all. |
||||
set max [expr {$qat + $count - 1 - [llength $qret]}] |
||||
set result [concat [lrange $qret $qat end] [lrange $qadd 0 $max]] |
||||
my Shift |
||||
set qat $max |
||||
} else { |
||||
# Request can be satisified from qret alone. |
||||
set max [expr {$qat + $count - 1}] |
||||
set result [lrange $qret $qat $max] |
||||
set qat $max |
||||
} |
||||
|
||||
incr qat |
||||
my Shift? |
||||
return $result |
||||
} |
||||
|
||||
# peek -- |
||||
# |
||||
# Retrieve the value of an item on the queue without removing it. |
||||
# |
||||
# Arguments: |
||||
# count number of items to peek; defaults to 1 |
||||
# |
||||
# Results: |
||||
# items top count items from the queue; if there are not enough items |
||||
# to fulfill the request, throws an error. |
||||
|
||||
method peek {{count 1}} { |
||||
variable queues |
||||
if { $count < 1 } { |
||||
return -code error "invalid item count $count" |
||||
} elseif { $count > [my size] } { |
||||
return -code error "insufficient items in queue to fill request" |
||||
} |
||||
|
||||
my Shift? |
||||
|
||||
if { $count == 1 } { |
||||
# Handle this as a special case, so single item pops aren't |
||||
# listified |
||||
return [lindex $qret $qat] |
||||
} |
||||
|
||||
# Otherwise, return a list of items |
||||
|
||||
if {$count > [llength $qret] - $qat} { |
||||
# Need all of qret (from qat on) and parts of qadd, maybe all. |
||||
set over [expr {$qat + $count - 1 - [llength $qret]}] |
||||
return [concat [lrange $qret $qat end] [lrange $qadd 0 $over]] |
||||
} else { |
||||
# Request can be satisified from qret alone. |
||||
return [lrange $qret $qat [expr {$qat + $count - 1}]] |
||||
} |
||||
} |
||||
|
||||
# put -- |
||||
# |
||||
# Put an item into a queue. |
||||
# |
||||
# Arguments: |
||||
# args items to put. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
method put {args} { |
||||
if {![llength $args]} { |
||||
return -code error "wrong # args: should be \"[self] put item ?item ...?\"" |
||||
} |
||||
foreach item $args { |
||||
lappend qadd $item |
||||
} |
||||
return |
||||
} |
||||
|
||||
# unget -- |
||||
# |
||||
# Put an item into a queue. At the _front_! |
||||
# |
||||
# Arguments: |
||||
# item item to put at the front of the queue |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
method unget {item} { |
||||
if {![llength $qret]} { |
||||
set qret [list $item] |
||||
} elseif {$qat == 0} { |
||||
set qret [linsert [my K $qret [unset qret]] 0 $item] |
||||
} else { |
||||
# step back and modify return buffer |
||||
incr qat -1 |
||||
set qret [lreplace [my K $qret [unset qret]] $qat $qat $item] |
||||
} |
||||
return |
||||
} |
||||
|
||||
# size -- |
||||
# |
||||
# Return the number of objects on a queue. |
||||
# |
||||
# Results: |
||||
# count number of items on the queue. |
||||
|
||||
method size {} { |
||||
return [expr { |
||||
[llength $qret] + [llength $qadd] - $qat |
||||
}] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
method Shift? {} { |
||||
if {$qat < [llength $qret]} return |
||||
# inlined Shift |
||||
set qat 0 |
||||
set qret $qadd |
||||
set qadd [list] |
||||
return |
||||
} |
||||
|
||||
method Shift {} { |
||||
set qat 0 |
||||
set qret $qadd |
||||
set qadd [list] |
||||
return |
||||
} |
||||
|
||||
method K {x y} { set x } |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Get 'queue::queue' into the general structure namespace for |
||||
# pickup by the main management. |
||||
|
||||
proc queue_tcl {args} { |
||||
if {[llength $args]} { |
||||
uplevel 1 [::list ::struct::queue::queue_oo create {*}$args] |
||||
} else { |
||||
uplevel 1 [::list ::struct::queue::queue_oo new] |
||||
} |
||||
} |
||||
} |
||||
@ -0,0 +1,383 @@
|
||||
# queue.tcl -- |
||||
# |
||||
# Queue implementation for Tcl. |
||||
# |
||||
# Copyright (c) 1998-2000 by Ajuba Solutions. |
||||
# Copyright (c) 2008-2010 Andreas Kupries |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: queue_tcl.tcl,v 1.2 2010/03/24 06:13:00 andreas_kupries Exp $ |
||||
|
||||
namespace eval ::struct::queue { |
||||
# counter is used to give a unique name for unnamed queues |
||||
variable counter 0 |
||||
|
||||
# Only export one command, the one used to instantiate a new queue |
||||
namespace export queue_tcl |
||||
} |
||||
|
||||
# ::struct::queue::queue_tcl -- |
||||
# |
||||
# Create a new queue with a given name; if no name is given, use |
||||
# queueX, where X is a number. |
||||
# |
||||
# Arguments: |
||||
# name name of the queue; if null, generate one. |
||||
# |
||||
# Results: |
||||
# name name of the queue created |
||||
|
||||
proc ::struct::queue::queue_tcl {args} { |
||||
variable I::qat |
||||
variable I::qret |
||||
variable I::qadd |
||||
variable counter |
||||
|
||||
switch -exact -- [llength [info level 0]] { |
||||
1 { |
||||
# Missing name, generate one. |
||||
incr counter |
||||
set name "queue${counter}" |
||||
} |
||||
2 { |
||||
# Standard call. New empty queue. |
||||
set name [lindex $args 0] |
||||
} |
||||
default { |
||||
# Error. |
||||
return -code error \ |
||||
"wrong # args: should be \"queue ?name?\"" |
||||
} |
||||
} |
||||
|
||||
# FIRST, qualify the name. |
||||
if {![string match "::*" $name]} { |
||||
# Get caller's namespace; append :: if not global namespace. |
||||
set ns [uplevel 1 [list namespace current]] |
||||
if {"::" != $ns} { |
||||
append ns "::" |
||||
} |
||||
|
||||
set name "$ns$name" |
||||
} |
||||
if {[llength [info commands $name]]} { |
||||
return -code error \ |
||||
"command \"$name\" already exists, unable to create queue" |
||||
} |
||||
|
||||
# Initialize the queue as empty |
||||
set qat($name) 0 |
||||
set qret($name) [list] |
||||
set qadd($name) [list] |
||||
|
||||
# Create the command to manipulate the queue |
||||
interp alias {} $name {} ::struct::queue::QueueProc $name |
||||
|
||||
return $name |
||||
} |
||||
|
||||
########################## |
||||
# Private functions follow |
||||
|
||||
# ::struct::queue::QueueProc -- |
||||
# |
||||
# Command that processes all queue object commands. |
||||
# |
||||
# Arguments: |
||||
# name name of the queue object to manipulate. |
||||
# args command name and args for the command |
||||
# |
||||
# Results: |
||||
# Varies based on command to perform |
||||
|
||||
if {[package vsatisfies [package provide Tcl] 8.5 9]} { |
||||
# In 8.5+ we can do an ensemble for fast dispatch. |
||||
|
||||
proc ::struct::queue::QueueProc {name cmd args} { |
||||
# Shuffle method to front and then simply run the ensemble. |
||||
# Dispatch, argument checking, and error message generation |
||||
# are all done in the C-level. |
||||
|
||||
I $cmd $name {*}$args |
||||
} |
||||
|
||||
namespace eval ::struct::queue::I { |
||||
namespace export clear destroy get peek \ |
||||
put unget size |
||||
namespace ensemble create |
||||
} |
||||
|
||||
} else { |
||||
# Before 8.5 we have to code our own dispatch, including error |
||||
# checking. |
||||
|
||||
proc ::struct::queue::QueueProc {name cmd args} { |
||||
# Do minimal args checks here |
||||
if { [llength [info level 0]] == 2 } { |
||||
return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" |
||||
} |
||||
|
||||
# Split the args into command and args components |
||||
if { [llength [info commands ::struct::queue::I::$cmd]] == 0 } { |
||||
set optlist [lsort [info commands ::struct::queue::I::*]] |
||||
set xlist {} |
||||
foreach p $optlist { |
||||
set p [namespace tail $p] |
||||
if {($p eq "K") || ($p eq "Shift") || ($p eq "Shift?")} continue |
||||
lappend xlist $p |
||||
} |
||||
set optlist [linsert [join $xlist ", "] "end-1" "or"] |
||||
return -code error \ |
||||
"bad option \"$cmd\": must be $optlist" |
||||
} |
||||
|
||||
uplevel 1 [linsert $args 0 ::struct::queue::I::$cmd $name] |
||||
} |
||||
} |
||||
|
||||
namespace eval ::struct::queue::I { |
||||
# The arrays hold all of the queues which were made. |
||||
variable qat ; # Index in qret of next element to return |
||||
variable qret ; # List of elements waiting for return |
||||
variable qadd ; # List of elements added and not yet reached for return. |
||||
} |
||||
|
||||
# ::struct::queue::I::clear -- |
||||
# |
||||
# Clear a queue. |
||||
# |
||||
# Arguments: |
||||
# name name of the queue object. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::queue::I::clear {name} { |
||||
variable qat |
||||
variable qret |
||||
variable qadd |
||||
set qat($name) 0 |
||||
set qret($name) [list] |
||||
set qadd($name) [list] |
||||
return |
||||
} |
||||
|
||||
# ::struct::queue::I::destroy -- |
||||
# |
||||
# Destroy a queue object by removing it's storage space and |
||||
# eliminating it's proc. |
||||
# |
||||
# Arguments: |
||||
# name name of the queue object. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::queue::I::destroy {name} { |
||||
variable qat ; unset qat($name) |
||||
variable qret ; unset qret($name) |
||||
variable qadd ; unset qadd($name) |
||||
interp alias {} $name {} |
||||
return |
||||
} |
||||
|
||||
# ::struct::queue::I::get -- |
||||
# |
||||
# Get an item from a queue. |
||||
# |
||||
# Arguments: |
||||
# name name of the queue object. |
||||
# count number of items to get; defaults to 1 |
||||
# |
||||
# Results: |
||||
# item first count items from the queue; if there are not enough |
||||
# items in the queue, throws an error. |
||||
|
||||
proc ::struct::queue::I::get {name {count 1}} { |
||||
if { $count < 1 } { |
||||
error "invalid item count $count" |
||||
} elseif { $count > [size $name] } { |
||||
error "insufficient items in queue to fill request" |
||||
} |
||||
|
||||
Shift? $name |
||||
|
||||
variable qat ; upvar 0 qat($name) AT |
||||
variable qret ; upvar 0 qret($name) RET |
||||
variable qadd ; upvar 0 qadd($name) ADD |
||||
|
||||
if { $count == 1 } { |
||||
# Handle this as a special case, so single item gets aren't |
||||
# listified |
||||
|
||||
set item [lindex $RET $AT] |
||||
incr AT |
||||
Shift? $name |
||||
return $item |
||||
} |
||||
|
||||
# Otherwise, return a list of items |
||||
|
||||
if {$count > ([llength $RET] - $AT)} { |
||||
# Need all of RET (from AT on) and parts of ADD, maybe all. |
||||
set max [expr {$count - ([llength $RET] - $AT) - 1}] |
||||
set result [concat [lrange $RET $AT end] [lrange $ADD 0 $max]] |
||||
Shift $name |
||||
set AT $max |
||||
} else { |
||||
# Request can be satisified from RET alone. |
||||
set max [expr {$AT + $count - 1}] |
||||
set result [lrange $RET $AT $max] |
||||
set AT $max |
||||
} |
||||
|
||||
incr AT |
||||
Shift? $name |
||||
return $result |
||||
} |
||||
|
||||
# ::struct::queue::I::peek -- |
||||
# |
||||
# Retrieve the value of an item on the queue without removing it. |
||||
# |
||||
# Arguments: |
||||
# name name of the queue object. |
||||
# count number of items to peek; defaults to 1 |
||||
# |
||||
# Results: |
||||
# items top count items from the queue; if there are not enough items |
||||
# to fulfill the request, throws an error. |
||||
|
||||
proc ::struct::queue::I::peek {name {count 1}} { |
||||
variable queues |
||||
if { $count < 1 } { |
||||
error "invalid item count $count" |
||||
} elseif { $count > [size $name] } { |
||||
error "insufficient items in queue to fill request" |
||||
} |
||||
|
||||
Shift? $name |
||||
|
||||
variable qat ; upvar 0 qat($name) AT |
||||
variable qret ; upvar 0 qret($name) RET |
||||
variable qadd ; upvar 0 qadd($name) ADD |
||||
|
||||
if { $count == 1 } { |
||||
# Handle this as a special case, so single item pops aren't |
||||
# listified |
||||
return [lindex $RET $AT] |
||||
} |
||||
|
||||
# Otherwise, return a list of items |
||||
|
||||
if {$count > [llength $RET] - $AT} { |
||||
# Need all of RET (from AT on) and parts of ADD, maybe all. |
||||
set over [expr {$count - ([llength $RET] - $AT) - 1}] |
||||
return [concat [lrange $RET $AT end] [lrange $ADD 0 $over]] |
||||
} else { |
||||
# Request can be satisified from RET alone. |
||||
return [lrange $RET $AT [expr {$AT + $count - 1}]] |
||||
} |
||||
} |
||||
|
||||
# ::struct::queue::I::put -- |
||||
# |
||||
# Put an item into a queue. |
||||
# |
||||
# Arguments: |
||||
# name name of the queue object |
||||
# args items to put. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::queue::I::put {name args} { |
||||
variable qadd |
||||
if { [llength $args] == 0 } { |
||||
error "wrong # args: should be \"$name put item ?item ...?\"" |
||||
} |
||||
foreach item $args { |
||||
lappend qadd($name) $item |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ::struct::queue::I::unget -- |
||||
# |
||||
# Put an item into a queue. At the _front_! |
||||
# |
||||
# Arguments: |
||||
# name name of the queue object |
||||
# item item to put at the front of the queue |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::queue::I::unget {name item} { |
||||
variable qat ; upvar 0 qat($name) AT |
||||
variable qret ; upvar 0 qret($name) RET |
||||
|
||||
if {![llength $RET]} { |
||||
set RET [list $item] |
||||
} elseif {$AT == 0} { |
||||
set RET [linsert [K $RET [unset RET]] 0 $item] |
||||
} else { |
||||
# step back and modify return buffer |
||||
incr AT -1 |
||||
set RET [lreplace [K $RET [unset RET]] $AT $AT $item] |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ::struct::queue::I::size -- |
||||
# |
||||
# Return the number of objects on a queue. |
||||
# |
||||
# Arguments: |
||||
# name name of the queue object. |
||||
# |
||||
# Results: |
||||
# count number of items on the queue. |
||||
|
||||
proc ::struct::queue::I::size {name} { |
||||
variable qat |
||||
variable qret |
||||
variable qadd |
||||
return [expr { |
||||
[llength $qret($name)] + [llength $qadd($name)] - $qat($name) |
||||
}] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
proc ::struct::queue::I::Shift? {name} { |
||||
variable qat |
||||
variable qret |
||||
if {$qat($name) < [llength $qret($name)]} return |
||||
Shift $name |
||||
return |
||||
} |
||||
|
||||
proc ::struct::queue::I::Shift {name} { |
||||
variable qat |
||||
variable qret |
||||
variable qadd |
||||
set qat($name) 0 |
||||
set qret($name) $qadd($name) |
||||
set qadd($name) [list] |
||||
return |
||||
} |
||||
|
||||
proc ::struct::queue::I::K {x y} { set x } |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Get 'queue::queue' into the general structure namespace for |
||||
# pickup by the main management. |
||||
namespace import -force queue::queue_tcl |
||||
} |
||||
|
||||
@ -0,0 +1,187 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. |
||||
# |
||||
# Copyright (c) 2004-2008 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
# @mdgen EXCLUDE: sets_c.tcl |
||||
|
||||
package require Tcl 8.5 9 |
||||
|
||||
namespace eval ::struct::set {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Management of set implementations. |
||||
|
||||
# ::struct::set::LoadAccelerator -- |
||||
# |
||||
# Loads a named implementation, if possible. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to load. |
||||
# |
||||
# Results: |
||||
# A boolean flag. True if the implementation |
||||
# was successfully loaded; and False otherwise. |
||||
|
||||
proc ::struct::set::LoadAccelerator {key} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $key { |
||||
critcl { |
||||
if {[catch {package require tcllibc}]} {return 0} |
||||
set r [llength [info commands ::struct::set_critcl]] |
||||
} |
||||
tcl { |
||||
variable selfdir |
||||
source [file join $selfdir sets_tcl.tcl] |
||||
set r 1 |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator/impl. package $key:\ |
||||
must be one of [join [KnownImplementations] {, }]" |
||||
} |
||||
} |
||||
set accel($key) $r |
||||
return $r |
||||
} |
||||
|
||||
# ::struct::set::SwitchTo -- |
||||
# |
||||
# Activates a loaded named implementation. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to activate. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::set::SwitchTo {key} { |
||||
variable accel |
||||
variable loaded |
||||
|
||||
if {[string equal $key $loaded]} { |
||||
# No change, nothing to do. |
||||
return |
||||
} elseif {![string equal $key ""]} { |
||||
# Validate the target implementation of the switch. |
||||
|
||||
if {![info exists accel($key)]} { |
||||
return -code error "Unable to activate unknown implementation \"$key\"" |
||||
} elseif {![info exists accel($key)] || !$accel($key)} { |
||||
return -code error "Unable to activate missing implementation \"$key\"" |
||||
} |
||||
} |
||||
|
||||
# Deactivate the previous implementation, if there was any. |
||||
|
||||
if {![string equal $loaded ""]} { |
||||
rename ::struct::set ::struct::set_$loaded |
||||
} |
||||
|
||||
# Activate the new implementation, if there is any. |
||||
|
||||
if {![string equal $key ""]} { |
||||
rename ::struct::set_$key ::struct::set |
||||
} |
||||
|
||||
# Remember the active implementation, for deactivation by future |
||||
# switches. |
||||
|
||||
set loaded $key |
||||
return |
||||
} |
||||
|
||||
proc ::struct::set::Loaded {} { |
||||
variable loaded |
||||
return $loaded |
||||
} |
||||
|
||||
# ::struct::set::Implementations -- |
||||
# |
||||
# Determines which implementations are |
||||
# present, i.e. loaded. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. |
||||
|
||||
proc ::struct::set::Implementations {} { |
||||
variable accel |
||||
set res {} |
||||
foreach n [array names accel] { |
||||
if {!$accel($n)} continue |
||||
lappend res $n |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::struct::set::KnownImplementations -- |
||||
# |
||||
# Determines which implementations are known |
||||
# as possible implementations. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. In the order |
||||
# of preference, most prefered first. |
||||
|
||||
proc ::struct::set::KnownImplementations {} { |
||||
return {critcl tcl} |
||||
} |
||||
|
||||
proc ::struct::set::Names {} { |
||||
return { |
||||
critcl {tcllibc based} |
||||
tcl {pure Tcl} |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Data structures. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable selfdir [file dirname [info script]] |
||||
variable accel |
||||
array set accel {tcl 0 critcl 0} |
||||
variable loaded {} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Choose an implementation, |
||||
## most prefered first. Loads only one of the |
||||
## possible implementations. And activates it. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable e |
||||
foreach e [KnownImplementations] { |
||||
if {[LoadAccelerator $e]} { |
||||
SwitchTo $e |
||||
break |
||||
} |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Export the constructor command. |
||||
namespace export set |
||||
} |
||||
|
||||
package provide struct::set 2.2.4 |
||||
@ -0,0 +1,91 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets_tcl.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. C implementation. |
||||
# |
||||
# Copyright (c) 2007 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
package require critcl |
||||
# @sak notprovided struct_setc |
||||
package provide struct_setc 2.1.1 |
||||
package require Tcl 8.5 9 |
||||
|
||||
namespace eval ::struct { |
||||
# Supporting code for the main command. |
||||
|
||||
catch { |
||||
#critcl::cheaders -g |
||||
#critcl::debug memory symbols |
||||
} |
||||
|
||||
critcl::cheaders sets/*.h |
||||
critcl::csources sets/*.c |
||||
|
||||
critcl::ccode { |
||||
/* -*- c -*- */ |
||||
|
||||
#include <m.h> |
||||
} |
||||
|
||||
# Main command, set creation. |
||||
|
||||
critcl::ccommand set_critcl {dummy interp objc objv} { |
||||
/* Syntax - dispatcher to the sub commands. |
||||
*/ |
||||
|
||||
static CONST char* methods [] = { |
||||
"add", "contains", "difference", "empty", |
||||
"equal","exclude", "include", "intersect", |
||||
"intersect3", "size", "subsetof", "subtract", |
||||
"symdiff", "union", |
||||
NULL |
||||
}; |
||||
enum methods { |
||||
S_add, S_contains, S_difference, S_empty, |
||||
S_equal,S_exclude, S_include, S_intersect, |
||||
S_intersect3, S_size, S_subsetof, S_subtract, |
||||
S_symdiff, S_union |
||||
}; |
||||
|
||||
int m; |
||||
|
||||
if (objc < 2) { |
||||
Tcl_WrongNumArgs (interp, objc, objv, "cmd ?arg ...?"); /* OK tcl9 */ |
||||
return TCL_ERROR; |
||||
} else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", |
||||
0, &m) != TCL_OK) { |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
/* Dispatch to methods. They check the #args in detail before performing |
||||
* the requested functionality |
||||
*/ |
||||
|
||||
switch (m) { |
||||
case S_add: return sm_ADD (NULL, interp, objc, objv); |
||||
case S_contains: return sm_CONTAINS (NULL, interp, objc, objv); |
||||
case S_difference: return sm_DIFFERENCE (NULL, interp, objc, objv); |
||||
case S_empty: return sm_EMPTY (NULL, interp, objc, objv); |
||||
case S_equal: return sm_EQUAL (NULL, interp, objc, objv); |
||||
case S_exclude: return sm_EXCLUDE (NULL, interp, objc, objv); |
||||
case S_include: return sm_INCLUDE (NULL, interp, objc, objv); |
||||
case S_intersect: return sm_INTERSECT (NULL, interp, objc, objv); |
||||
case S_intersect3: return sm_INTERSECT3 (NULL, interp, objc, objv); |
||||
case S_size: return sm_SIZE (NULL, interp, objc, objv); |
||||
case S_subsetof: return sm_SUBSETOF (NULL, interp, objc, objv); |
||||
case S_subtract: return sm_SUBTRACT (NULL, interp, objc, objv); |
||||
case S_symdiff: return sm_SYMDIFF (NULL, interp, objc, objv); |
||||
case S_union: return sm_UNION (NULL, interp, objc, objv); |
||||
} |
||||
/* Not coming to this place */ |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
@ -0,0 +1,452 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets_tcl.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. |
||||
# |
||||
# Copyright (c) 2004-2008 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets_tcl.tcl,v 1.4 2008/03/09 04:38:47 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
package require Tcl 8.5 9 |
||||
|
||||
namespace eval ::struct::set { |
||||
# Only export one command, the one used to instantiate a new tree |
||||
namespace export set_tcl |
||||
} |
||||
|
||||
########################## |
||||
# Public functions |
||||
|
||||
# ::struct::set::set -- |
||||
# |
||||
# Command that access all set commands. |
||||
# |
||||
# Arguments: |
||||
# cmd Name of the subcommand to dispatch to. |
||||
# args Arguments for the subcommand. |
||||
# |
||||
# Results: |
||||
# Whatever the result of the subcommand is. |
||||
|
||||
proc ::struct::set::set_tcl {cmd args} { |
||||
# Do minimal args checks here |
||||
if { [llength [info level 0]] == 1 } { |
||||
return -code error "wrong # args: should be \"$cmd ?arg arg ...?\"" |
||||
} |
||||
::set sub S_$cmd |
||||
if { [llength [info commands ::struct::set::$sub]] == 0 } { |
||||
::set optlist [info commands ::struct::set::S_*] |
||||
::set xlist {} |
||||
foreach p $optlist { |
||||
lappend xlist [string range $p 17 end] |
||||
} |
||||
return -code error \ |
||||
"bad option \"$cmd\": must be [linsert [join [lsort $xlist] ", "] "end-1" "or"]" |
||||
} |
||||
return [uplevel 1 [linsert $args 0 ::struct::set::$sub]] |
||||
} |
||||
|
||||
########################## |
||||
# Implementations of the functionality. |
||||
# |
||||
|
||||
# ::struct::set::S_empty -- |
||||
# |
||||
# Determines emptiness of the set |
||||
# |
||||
# Parameters: |
||||
# set -- The set to check for emptiness. |
||||
# |
||||
# Results: |
||||
# A boolean value. True indicates that the set is empty. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
# |
||||
# Notes: |
||||
|
||||
proc ::struct::set::S_empty {set} { |
||||
return [expr {[llength $set] == 0}] |
||||
} |
||||
|
||||
# ::struct::set::S_size -- |
||||
# |
||||
# Computes the cardinality of the set. |
||||
# |
||||
# Parameters: |
||||
# set -- The set to inspect. |
||||
# |
||||
# Results: |
||||
# An integer greater than or equal to zero. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_size {set} { |
||||
return [llength [Cleanup $set]] |
||||
} |
||||
|
||||
# ::struct::set::S_contains -- |
||||
# |
||||
# Determines if the item is in the set. |
||||
# |
||||
# Parameters: |
||||
# set -- The set to inspect. |
||||
# item -- The element to look for. |
||||
# |
||||
# Results: |
||||
# A boolean value. True indicates that the element is present. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_contains {set item} { |
||||
return [expr {[lsearch -exact $set $item] >= 0}] |
||||
} |
||||
|
||||
# ::struct::set::S_union -- |
||||
# |
||||
# Computes the union of the arguments. |
||||
# |
||||
# Parameters: |
||||
# args -- List of sets to unify. |
||||
# |
||||
# Results: |
||||
# The union of the arguments. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_union {args} { |
||||
switch -exact -- [llength $args] { |
||||
0 {return {}} |
||||
1 {return [lindex $args 0]} |
||||
} |
||||
foreach setX $args { |
||||
foreach x $setX {::set ($x) {}} |
||||
} |
||||
return [array names {}] |
||||
} |
||||
|
||||
|
||||
# ::struct::set::S_intersect -- |
||||
# |
||||
# Computes the intersection of the arguments. |
||||
# |
||||
# Parameters: |
||||
# args -- List of sets to intersect. |
||||
# |
||||
# Results: |
||||
# The intersection of the arguments |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_intersect {args} { |
||||
switch -exact -- [llength $args] { |
||||
0 {return {}} |
||||
1 {return [lindex $args 0]} |
||||
} |
||||
::set res [lindex $args 0] |
||||
foreach set [lrange $args 1 end] { |
||||
if {[llength $res] && [llength $set]} { |
||||
::set res [Intersect $res $set] |
||||
} else { |
||||
# Squash 'res'. Otherwise we get the wrong result if res |
||||
# is not empty, but 'set' is. |
||||
::set res {} |
||||
break |
||||
} |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
proc ::struct::set::Intersect {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return {}} |
||||
|
||||
# This is slower than local vars, but more robust |
||||
if {[llength $B] > [llength $A]} { |
||||
::set res $A |
||||
::set A $B |
||||
::set B $res |
||||
} |
||||
::set res {} |
||||
foreach x $A {::set ($x) {}} |
||||
foreach x $B { |
||||
if {[info exists ($x)]} { |
||||
lappend res $x |
||||
} |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::struct::set::S_difference -- |
||||
# |
||||
# Compute difference of two sets. |
||||
# |
||||
# Parameters: |
||||
# A, B -- Sets to compute the difference for. |
||||
# |
||||
# Results: |
||||
# A - B |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_difference {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return $A} |
||||
|
||||
array set tmp {} |
||||
foreach x $A {::set tmp($x) .} |
||||
foreach x $B {catch {unset tmp($x)}} |
||||
return [array names tmp] |
||||
} |
||||
|
||||
if {0} { |
||||
# Tcllib SF Bug 1002143. We cannot use the implementation below. |
||||
# It will treat set elements containing '(' and ')' as array |
||||
# elements, and this screws up the storage of elements as the name |
||||
# of local vars something fierce. No way around this. Disabling |
||||
# this code and always using the other implementation (s.a.) is |
||||
# the only possible fix. |
||||
|
||||
if {[package vcompare [package provide Tcl] 8.4] < 0} { |
||||
# Tcl 8.[23]. Use explicit array to perform the operation. |
||||
} else { |
||||
# Tcl 8.4+, has 'unset -nocomplain' |
||||
|
||||
proc ::struct::set::S_difference {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return $A} |
||||
|
||||
# Get the variable B out of the way, avoid collisions |
||||
# prepare for "pure list optimization" |
||||
::set ::struct::set::tmp [lreplace $B -1 -1 unset -nocomplain] |
||||
unset B |
||||
|
||||
# unset A early: no local variables left |
||||
foreach [lindex [list $A [unset A]] 0] {.} {break} |
||||
|
||||
eval $::struct::set::tmp |
||||
return [info locals] |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ::struct::set::S_symdiff -- |
||||
# |
||||
# Compute symmetric difference of two sets. |
||||
# |
||||
# Parameters: |
||||
# A, B -- The sets to compute the s.difference for. |
||||
# |
||||
# Results: |
||||
# The symmetric difference of the two input sets. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_symdiff {A B} { |
||||
# symdiff == (A-B) + (B-A) == (A+B)-(A*B) |
||||
if {[llength $A] == 0} {return $B} |
||||
if {[llength $B] == 0} {return $A} |
||||
return [S_union \ |
||||
[S_difference $A $B] \ |
||||
[S_difference $B $A]] |
||||
} |
||||
|
||||
# ::struct::set::S_intersect3 -- |
||||
# |
||||
# Return intersection and differences for two sets. |
||||
# |
||||
# Parameters: |
||||
# A, B -- The sets to inspect. |
||||
# |
||||
# Results: |
||||
# List containing A*B, A-B, and B-A |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_intersect3 {A B} { |
||||
return [list \ |
||||
[S_intersect $A $B] \ |
||||
[S_difference $A $B] \ |
||||
[S_difference $B $A]] |
||||
} |
||||
|
||||
# ::struct::set::S_equal -- |
||||
# |
||||
# Compares two sets for equality. |
||||
# |
||||
# Parameters: |
||||
# a First set to compare. |
||||
# b Second set to compare. |
||||
# |
||||
# Results: |
||||
# A boolean. True if the lists are equal. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_equal {A B} { |
||||
::set A [Cleanup $A] |
||||
::set B [Cleanup $B] |
||||
|
||||
# Equal if of same cardinality and difference is empty. |
||||
|
||||
if {[::llength $A] != [::llength $B]} {return 0} |
||||
return [expr {[llength [S_difference $A $B]] == 0}] |
||||
} |
||||
|
||||
|
||||
proc ::struct::set::Cleanup {A} { |
||||
# unset A to avoid collisions |
||||
if {[llength $A] < 2} {return $A} |
||||
# We cannot use variables to avoid an explicit array. The set |
||||
# elements may look like namespace vars (i.e. contain ::), and |
||||
# such elements break that, cannot be proc-local variables. |
||||
array set S {} |
||||
foreach item $A {set S($item) .} |
||||
return [array names S] |
||||
} |
||||
|
||||
# ::struct::set::S_include -- |
||||
# |
||||
# Add an element to a set. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to extend. |
||||
# element -- The item to add to the set. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is extended |
||||
# by the element (if the element was not already present). |
||||
|
||||
proc ::struct::set::S_include {Avar element} { |
||||
# Avar = Avar + {element} |
||||
upvar 1 $Avar A |
||||
if {![info exists A] || ![S_contains $A $element]} { |
||||
lappend A $element |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_exclude -- |
||||
# |
||||
# Remove an element from a set. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to shrink. |
||||
# element -- The item to remove from the set. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is shrunk, |
||||
# the element remove (if the element was actually present). |
||||
|
||||
proc ::struct::set::S_exclude {Avar element} { |
||||
# Avar = Avar - {element} |
||||
upvar 1 $Avar A |
||||
if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} |
||||
while {[::set pos [lsearch -exact $A $element]] >= 0} { |
||||
::set A [lreplace [K $A [::set A {}]] $pos $pos] |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_add -- |
||||
# |
||||
# Add a set to a set. Similar to 'union', but the first argument |
||||
# is a variable. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to extend. |
||||
# B -- The set to add to the set in Avar. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is extended |
||||
# by all the elements in B. |
||||
|
||||
proc ::struct::set::S_add {Avar B} { |
||||
# Avar = Avar + B |
||||
upvar 1 $Avar A |
||||
if {![info exists A]} {set A {}} |
||||
::set A [S_union [K $A [::set A {}]] $B] |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_subtract -- |
||||
# |
||||
# Remove a set from a set. Similar to 'difference', but the first argument |
||||
# is a variable. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to shrink. |
||||
# B -- The set to remove from the set in Avar. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is shrunk, |
||||
# all elements of B are removed. |
||||
|
||||
proc ::struct::set::S_subtract {Avar B} { |
||||
# Avar = Avar - B |
||||
upvar 1 $Avar A |
||||
if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} |
||||
::set A [S_difference [K $A [::set A {}]] $B] |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_subsetof -- |
||||
# |
||||
# A predicate checking if the first set is a subset |
||||
# or equal to the second set. |
||||
# |
||||
# Parameters: |
||||
# A -- The possible subset. |
||||
# B -- The set to compare to. |
||||
# |
||||
# Results: |
||||
# A boolean value, true if A is subset of or equal to B |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_subsetof {A B} { |
||||
# A subset|== B <=> (A == A*B) |
||||
return [S_equal $A [S_intersect $A $B]] |
||||
} |
||||
|
||||
# ::struct::set::K -- |
||||
# Performance helper command. |
||||
|
||||
proc ::struct::set::K {x y} {::set x} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Put 'set::set' into the general structure namespace |
||||
# for pickup by the main management. |
||||
|
||||
namespace import -force set::set_tcl |
||||
} |
||||
@ -0,0 +1,437 @@
|
||||
# skiplist.tcl -- |
||||
# |
||||
# Implementation of a skiplist data structure for Tcl. |
||||
# |
||||
# To quote the inventor of skip lists, William Pugh: |
||||
# Skip lists are a probabilistic data structure that seem likely |
||||
# to supplant balanced trees as the implementation method of |
||||
# choice for many applications. Skip list algorithms have the |
||||
# same asymptotic expected time bounds as balanced trees and are |
||||
# simpler, faster and use less space. |
||||
# |
||||
# For more details on how skip lists work, see Pugh, William. Skip |
||||
# lists: a probabilistic alternative to balanced trees in |
||||
# Communications of the ACM, June 1990, 33(6) 668-676. Also, see |
||||
# ftp://ftp.cs.umd.edu/pub/skipLists/ |
||||
# |
||||
# Copyright (c) 2000 by Keith Vetter |
||||
# This software is licensed under a BSD license as described in tcl/tk |
||||
# license.txt file but with the copyright held by Keith Vetter. |
||||
# |
||||
# TODO: |
||||
# customize key comparison to a user supplied routine |
||||
|
||||
namespace eval ::struct {} |
||||
|
||||
namespace eval ::struct::skiplist { |
||||
# Data storage in the skiplist module |
||||
# ------------------------------- |
||||
# |
||||
# For each skiplist, we have the following arrays |
||||
# state - holds the current level plus some magic constants |
||||
# nodes - all the nodes in the skiplist, including a dummy header node |
||||
|
||||
# counter is used to give a unique name for unnamed skiplists |
||||
variable counter 0 |
||||
|
||||
# Internal constants |
||||
variable MAXLEVEL 16 |
||||
variable PROB .5 |
||||
variable MAXINT [expr {0x7FFFFFFF}] |
||||
|
||||
# commands is the list of subcommands recognized by the skiplist |
||||
variable commands [list \ |
||||
"destroy" \ |
||||
"delete" \ |
||||
"insert" \ |
||||
"search" \ |
||||
"size" \ |
||||
"walk" \ |
||||
] |
||||
|
||||
# State variables that can be set in the instantiation |
||||
variable vars [list maxlevel probability] |
||||
|
||||
# Only export one command, the one used to instantiate a new skiplist |
||||
namespace export skiplist |
||||
} |
||||
|
||||
# ::struct::skiplist::skiplist -- |
||||
# |
||||
# Create a new skiplist with a given name; if no name is given, use |
||||
# skiplistX, where X is a number. |
||||
# |
||||
# Arguments: |
||||
# name name of the skiplist; if null, generate one. |
||||
# |
||||
# Results: |
||||
# name name of the skiplist created |
||||
|
||||
proc ::struct::skiplist::skiplist {{name ""} args} { |
||||
set usage "skiplist name ?-maxlevel ##? ?-probability ##?" |
||||
variable counter |
||||
|
||||
if { [llength [info level 0]] == 1 } { |
||||
incr counter |
||||
set name "skiplist${counter}" |
||||
} |
||||
|
||||
if { ![string equal [info commands ::$name] ""] } { |
||||
error "command \"$name\" already exists, unable to create skiplist" |
||||
} |
||||
|
||||
# Handle the optional arguments |
||||
set more_eval "" |
||||
for {set i 0} {$i < [llength $args]} {incr i} { |
||||
set flag [lindex $args $i] |
||||
incr i |
||||
if { $i >= [llength $args] } { |
||||
error "value for \"$flag\" missing: should be \"$usage\"" |
||||
} |
||||
set value [lindex $args $i] |
||||
switch -glob -- $flag { |
||||
"-maxl*" { |
||||
set n [catch {set value [expr $value]}] |
||||
if {$n || $value <= 0} { |
||||
error "value for the maxlevel option must be greater than 0" |
||||
} |
||||
append more_eval "; set state(maxlevel) $value" |
||||
} |
||||
"-prob*" { |
||||
set n [catch {set value [expr $value]}] |
||||
if {$n || $value <= 0 || $value >= 1} { |
||||
error "probability must be between 0 and 1" |
||||
} |
||||
append more_eval "; set state(prob) $value" |
||||
} |
||||
default { |
||||
error "unknown option \"$flag\": should be \"$usage\"" |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Set up the namespace for this skiplist |
||||
namespace eval ::struct::skiplist::skiplist$name { |
||||
variable state |
||||
variable nodes |
||||
|
||||
# NB. maxlevel and prob may be overridden by $more_eval at the end |
||||
set state(maxlevel) $::struct::skiplist::MAXLEVEL |
||||
set state(prob) $::struct::skiplist::PROB |
||||
set state(level) 1 |
||||
set state(cnt) 0 |
||||
set state(size) 0 |
||||
|
||||
set nodes(nil,key) $::struct::skiplist::MAXINT |
||||
set nodes(header,key) "---" |
||||
set nodes(header,value) "---" |
||||
|
||||
for {set i 1} {$i < $state(maxlevel)} {incr i} { |
||||
set nodes(header,$i) nil |
||||
} |
||||
} $more_eval |
||||
|
||||
# Create the command to manipulate the skiplist |
||||
interp alias {} ::$name {} ::struct::skiplist::SkiplistProc $name |
||||
|
||||
return $name |
||||
} |
||||
|
||||
########################### |
||||
# Private functions follow |
||||
|
||||
# ::struct::skiplist::SkiplistProc -- |
||||
# |
||||
# Command that processes all skiplist object commands. |
||||
# |
||||
# Arguments: |
||||
# name name of the skiplist object to manipulate. |
||||
# args command name and args for the command |
||||
# |
||||
# Results: |
||||
# Varies based on command to perform |
||||
|
||||
proc ::struct::skiplist::SkiplistProc {name {cmd ""} args} { |
||||
# Do minimal args checks here |
||||
if { [llength [info level 0]] == 2 } { |
||||
error "wrong # args: should be \"$name option ?arg arg ...?\"" |
||||
} |
||||
|
||||
# Split the args into command and args components |
||||
if { [llength [info commands ::struct::skiplist::_$cmd]] == 0 } { |
||||
variable commands |
||||
set optlist [join $commands ", "] |
||||
set optlist [linsert $optlist "end-1" "or"] |
||||
error "bad option \"$cmd\": must be $optlist" |
||||
} |
||||
eval [linsert $args 0 ::struct::skiplist::_$cmd $name] |
||||
} |
||||
|
||||
## ::struct::skiplist::_destroy -- |
||||
# |
||||
# Destroy a skiplist, including its associated command and data storage. |
||||
# |
||||
# Arguments: |
||||
# name name of the skiplist. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::skiplist::_destroy {name} { |
||||
namespace delete ::struct::skiplist::skiplist$name |
||||
interp alias {} ::$name {} |
||||
} |
||||
|
||||
# ::struct::skiplist::_search -- |
||||
# |
||||
# Searches for a key in a skiplist |
||||
# |
||||
# Arguments: |
||||
# name name of the skiplist. |
||||
# key key for the node to search for |
||||
# |
||||
# Results: |
||||
# 0 if not found |
||||
# [list 1 node_value] if found |
||||
|
||||
proc ::struct::skiplist::_search {name key} { |
||||
upvar ::struct::skiplist::skiplist${name}::state state |
||||
upvar ::struct::skiplist::skiplist${name}::nodes nodes |
||||
|
||||
set x header |
||||
for {set i $state(level)} {$i >= 1} {incr i -1} { |
||||
while {1} { |
||||
set fwd $nodes($x,$i) |
||||
if {$nodes($fwd,key) == $::struct::skiplist::MAXINT} break |
||||
if {$nodes($fwd,key) >= $key} break |
||||
set x $fwd |
||||
} |
||||
} |
||||
set x $nodes($x,1) |
||||
if {$nodes($x,key) == $key} { |
||||
return [list 1 $nodes($x,value)] |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
# ::struct::skiplist::_insert -- |
||||
# |
||||
# Add a node to a skiplist. |
||||
# |
||||
# Arguments: |
||||
# name name of the skiplist. |
||||
# key key for the node to insert |
||||
# value value of the node to insert |
||||
# |
||||
# Results: |
||||
# 0 if new node was created |
||||
# level if existing node was updated |
||||
|
||||
proc ::struct::skiplist::_insert {name key value} { |
||||
upvar ::struct::skiplist::skiplist${name}::state state |
||||
upvar ::struct::skiplist::skiplist${name}::nodes nodes |
||||
|
||||
set x header |
||||
for {set i $state(level)} {$i >= 1} {incr i -1} { |
||||
while {1} { |
||||
set fwd $nodes($x,$i) |
||||
if {$nodes($fwd,key) == $::struct::skiplist::MAXINT} break |
||||
if {$nodes($fwd,key) >= $key} break |
||||
set x $fwd |
||||
} |
||||
set update($i) $x |
||||
} |
||||
set x $nodes($x,1) |
||||
|
||||
# Does the node already exist? |
||||
if {$nodes($x,key) == $key} { |
||||
set nodes($x,value) $value |
||||
return 0 |
||||
} |
||||
|
||||
# Here to insert item |
||||
incr state(size) |
||||
set lvl [randomLevel $state(prob) $state(level) $state(maxlevel)] |
||||
|
||||
# Did the skip list level increase??? |
||||
if {$lvl > $state(level)} { |
||||
for {set i [expr {$state(level) + 1}]} {$i <= $lvl} {incr i} { |
||||
set update($i) header |
||||
} |
||||
set state(level) $lvl |
||||
} |
||||
|
||||
# Create a unique new node name and fill in the key, value parts |
||||
set x [incr state(cnt)] |
||||
set nodes($x,key) $key |
||||
set nodes($x,value) $value |
||||
|
||||
for {set i 1} {$i <= $lvl} {incr i} { |
||||
set nodes($x,$i) $nodes($update($i),$i) |
||||
set nodes($update($i),$i) $x |
||||
} |
||||
|
||||
return $lvl |
||||
} |
||||
|
||||
# ::struct::skiplist::_delete -- |
||||
# |
||||
# Deletes a node from a skiplist |
||||
# |
||||
# Arguments: |
||||
# name name of the skiplist. |
||||
# key key for the node to delete |
||||
# |
||||
# Results: |
||||
# 1 if we deleted a node |
||||
# 0 otherwise |
||||
|
||||
proc ::struct::skiplist::_delete {name key} { |
||||
upvar ::struct::skiplist::skiplist${name}::state state |
||||
upvar ::struct::skiplist::skiplist${name}::nodes nodes |
||||
|
||||
set x header |
||||
for {set i $state(level)} {$i >= 1} {incr i -1} { |
||||
while {1} { |
||||
set fwd $nodes($x,$i) |
||||
if {$nodes($fwd,key) >= $key} break |
||||
set x $fwd |
||||
} |
||||
set update($i) $x |
||||
} |
||||
set x $nodes($x,1) |
||||
|
||||
# Did we find a node to delete? |
||||
if {$nodes($x,key) != $key} { |
||||
return 0 |
||||
} |
||||
|
||||
# Here when we found a node to delete |
||||
incr state(size) -1 |
||||
|
||||
# Unlink this node from all the linked lists that include to it |
||||
for {set i 1} {$i <= $state(level)} {incr i} { |
||||
set fwd $nodes($update($i),$i) |
||||
if {$nodes($fwd,key) != $key} break |
||||
set nodes($update($i),$i) $nodes($x,$i) |
||||
} |
||||
|
||||
# Delete all traces of this node |
||||
foreach v [array names nodes($x,*)] { |
||||
unset nodes($v) |
||||
} |
||||
|
||||
# Fix up the level in case it went down |
||||
while {$state(level) > 1} { |
||||
if {! [string equal "nil" $nodes(header,$state(level))]} break |
||||
incr state(level) -1 |
||||
} |
||||
|
||||
return 1 |
||||
} |
||||
|
||||
# ::struct::skiplist::_size -- |
||||
# |
||||
# Returns how many nodes are in the skiplist |
||||
# |
||||
# Arguments: |
||||
# name name of the skiplist. |
||||
# |
||||
# Results: |
||||
# number of nodes in the skiplist |
||||
|
||||
proc ::struct::skiplist::_size {name} { |
||||
upvar ::struct::skiplist::skiplist${name}::state state |
||||
|
||||
return $state(size) |
||||
} |
||||
|
||||
# ::struct::skiplist::_walk -- |
||||
# |
||||
# Walks a skiplist performing a specified command on each node. |
||||
# Command is executed at the global level with the actual command |
||||
# executed is: command key value |
||||
# |
||||
# Arguments: |
||||
# name name of the skiplist. |
||||
# cmd command to run on each node |
||||
# |
||||
# Results: |
||||
# none. |
||||
|
||||
proc ::struct::skiplist::_walk {name cmd} { |
||||
upvar ::struct::skiplist::skiplist${name}::nodes nodes |
||||
|
||||
for {set x $nodes(header,1)} {$x != "nil"} {set x $nodes($x,1)} { |
||||
# Evaluate the command at this node |
||||
set cmdcpy $cmd |
||||
lappend cmdcpy $nodes($x,key) $nodes($x,value) |
||||
uplevel 2 $cmdcpy |
||||
} |
||||
} |
||||
|
||||
# ::struct::skiplist::randomLevel -- |
||||
# |
||||
# Generates a random level for a new node. We limit it to 1 greater |
||||
# than the current level. |
||||
# |
||||
# Arguments: |
||||
# prob probability to use in generating level |
||||
# level current biggest level |
||||
# maxlevel biggest possible level |
||||
# |
||||
# Results: |
||||
# an integer between 1 and $maxlevel |
||||
|
||||
proc ::struct::skiplist::randomLevel {prob level maxlevel} { |
||||
|
||||
set lvl 1 |
||||
while {(rand() < $prob) && ($lvl < $maxlevel)} { |
||||
incr lvl |
||||
} |
||||
|
||||
if {$lvl > $level} { |
||||
set lvl [expr {$level + 1}] |
||||
} |
||||
|
||||
return $lvl |
||||
} |
||||
|
||||
# ::struct::skiplist::_dump -- |
||||
# |
||||
# Dumps out a skip list. Useful for debugging. |
||||
# |
||||
# Arguments: |
||||
# name name of the skiplist. |
||||
# |
||||
# Results: |
||||
# none. |
||||
|
||||
proc ::struct::skiplist::_dump {name} { |
||||
upvar ::struct::skiplist::skiplist${name}::state state |
||||
upvar ::struct::skiplist::skiplist${name}::nodes nodes |
||||
|
||||
|
||||
puts "Current level $state(level)" |
||||
puts "Maxlevel: $state(maxlevel)" |
||||
puts "Probability: $state(prob)" |
||||
puts "" |
||||
puts "NODE KEY FORWARD" |
||||
for {set x header} {$x != "nil"} {set x $nodes($x,1)} { |
||||
puts -nonewline [format "%-6s %3s %4s" $x $nodes($x,key) $nodes($x,1)] |
||||
for {set i 2} {[info exists nodes($x,$i)]} {incr i} { |
||||
puts -nonewline [format %4s $nodes($x,$i)] |
||||
} |
||||
puts "" |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Get 'skiplist::skiplist' into the general structure namespace. |
||||
namespace import -force skiplist::skiplist |
||||
namespace export skiplist |
||||
} |
||||
package provide struct::skiplist 1.4 |
||||
@ -0,0 +1,183 @@
|
||||
# stack.tcl -- |
||||
# |
||||
# Implementation of a stack data structure for Tcl. |
||||
# |
||||
# Copyright (c) 1998-2000 by Ajuba Solutions. |
||||
# Copyright (c) 2008 by Andreas Kupries |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: stack.tcl,v 1.20 2012/11/21 22:36:18 andreas_kupries Exp $ |
||||
|
||||
# @mdgen EXCLUDE: stack_c.tcl |
||||
|
||||
package require Tcl 8.5 9 |
||||
namespace eval ::struct::stack {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Management of stack implementations. |
||||
|
||||
# ::struct::stack::LoadAccelerator -- |
||||
# |
||||
# Loads a named implementation, if possible. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to load. |
||||
# |
||||
# Results: |
||||
# A boolean flag. True if the implementation |
||||
# was successfully loaded; and False otherwise. |
||||
|
||||
proc ::struct::stack::LoadAccelerator {key} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $key { |
||||
critcl { |
||||
# Critcl implementation of stack requires Tcl 8.4. |
||||
if {[catch {package require tcllibc}]} {return 0} |
||||
set r [llength [info commands ::struct::stack_critcl]] |
||||
} |
||||
tcl { |
||||
variable selfdir |
||||
if {![catch {package require TclOO 0.6.1-} mx]} { |
||||
source [file join $selfdir stack_oo.tcl] |
||||
} else { |
||||
source [file join $selfdir stack_tcl.tcl] |
||||
} |
||||
set r 1 |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator/impl. package $key:\ |
||||
must be one of [join [KnownImplementations] {, }]" |
||||
} |
||||
} |
||||
set accel($key) $r |
||||
return $r |
||||
} |
||||
|
||||
# ::struct::stack::SwitchTo -- |
||||
# |
||||
# Activates a loaded named implementation. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to activate. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::stack::SwitchTo {key} { |
||||
variable accel |
||||
variable loaded |
||||
|
||||
if {[string equal $key $loaded]} { |
||||
# No change, nothing to do. |
||||
return |
||||
} elseif {![string equal $key ""]} { |
||||
# Validate the target implementation of the switch. |
||||
|
||||
if {![info exists accel($key)]} { |
||||
return -code error "Unable to activate unknown implementation \"$key\"" |
||||
} elseif {![info exists accel($key)] || !$accel($key)} { |
||||
return -code error "Unable to activate missing implementation \"$key\"" |
||||
} |
||||
} |
||||
|
||||
# Deactivate the previous implementation, if there was any. |
||||
|
||||
if {![string equal $loaded ""]} { |
||||
rename ::struct::stack ::struct::stack_$loaded |
||||
} |
||||
|
||||
# Activate the new implementation, if there is any. |
||||
|
||||
if {![string equal $key ""]} { |
||||
rename ::struct::stack_$key ::struct::stack |
||||
} |
||||
|
||||
# Remember the active implementation, for deactivation by future |
||||
# switches. |
||||
|
||||
set loaded $key |
||||
return |
||||
} |
||||
|
||||
# ::struct::stack::Implementations -- |
||||
# |
||||
# Determines which implementations are |
||||
# present, i.e. loaded. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. |
||||
|
||||
proc ::struct::stack::Implementations {} { |
||||
variable accel |
||||
set res {} |
||||
foreach n [array names accel] { |
||||
if {!$accel($n)} continue |
||||
lappend res $n |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::struct::stack::KnownImplementations -- |
||||
# |
||||
# Determines which implementations are known |
||||
# as possible implementations. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. In the order |
||||
# of preference, most prefered first. |
||||
|
||||
proc ::struct::stack::KnownImplementations {} { |
||||
return {critcl tcl} |
||||
} |
||||
|
||||
proc ::struct::stack::Names {} { |
||||
return { |
||||
critcl {tcllibc based} |
||||
tcl {pure Tcl} |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Data structures. |
||||
|
||||
namespace eval ::struct::stack { |
||||
variable selfdir [file dirname [info script]] |
||||
variable accel |
||||
array set accel {tcl 0 critcl 0} |
||||
variable loaded {} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Choose an implementation, |
||||
## most prefered first. Loads only one of the |
||||
## possible implementations. And activates it. |
||||
|
||||
namespace eval ::struct::stack { |
||||
variable e |
||||
foreach e [KnownImplementations] { |
||||
if {[LoadAccelerator $e]} { |
||||
SwitchTo $e |
||||
break |
||||
} |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Export the constructor command. |
||||
namespace export stack |
||||
} |
||||
|
||||
package provide struct::stack 1.5.4 |
||||
@ -0,0 +1,156 @@
|
||||
# stackc.tcl -- |
||||
# |
||||
# Implementation of a stack data structure for Tcl. |
||||
# This code based on critcl, API compatible to the PTI [x]. |
||||
# [x] Pure Tcl Implementation. |
||||
# |
||||
# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: stack_c.tcl,v 1.1 2008/06/19 23:03:35 andreas_kupries Exp $ |
||||
|
||||
package require critcl |
||||
# @sak notprovided struct_stackc |
||||
package provide struct_stackc 1.3.1 |
||||
package require Tcl 8.5 9 |
||||
|
||||
namespace eval ::struct { |
||||
# Supporting code for the main command. |
||||
|
||||
catch { |
||||
#critcl::cheaders -g |
||||
#critcl::debug memory symbols |
||||
} |
||||
|
||||
critcl::cheaders stack/*.h |
||||
critcl::csources stack/*.c |
||||
|
||||
critcl::ccode { |
||||
/* -*- c -*- */ |
||||
|
||||
#include <util.h> |
||||
#include <s.h> |
||||
#include <ms.h> |
||||
#include <m.h> |
||||
|
||||
/* .................................................. */ |
||||
/* Global stack management, per interp |
||||
*/ |
||||
|
||||
typedef struct SDg { |
||||
long int counter; |
||||
char buf [50]; |
||||
} SDg; |
||||
|
||||
static void |
||||
SDgrelease (ClientData cd, Tcl_Interp* interp) |
||||
{ |
||||
ckfree((char*) cd); |
||||
} |
||||
|
||||
static CONST char* |
||||
SDnewName (Tcl_Interp* interp) |
||||
{ |
||||
#define KEY "tcllib/struct::stack/critcl" |
||||
|
||||
Tcl_InterpDeleteProc* proc = SDgrelease; |
||||
SDg* sdg; |
||||
|
||||
sdg = Tcl_GetAssocData (interp, KEY, &proc); |
||||
if (sdg == NULL) { |
||||
sdg = (SDg*) ckalloc (sizeof (SDg)); |
||||
sdg->counter = 0; |
||||
|
||||
Tcl_SetAssocData (interp, KEY, proc, |
||||
(ClientData) sdg); |
||||
} |
||||
|
||||
sdg->counter ++; |
||||
sprintf (sdg->buf, "stack%ld", sdg->counter); |
||||
return sdg->buf; |
||||
|
||||
#undef KEY |
||||
} |
||||
|
||||
static void |
||||
SDdeleteCmd (ClientData clientData) |
||||
{ |
||||
/* Release the whole stack. */ |
||||
st_delete ((S*) clientData); |
||||
} |
||||
} |
||||
|
||||
# Main command, stack creation. |
||||
|
||||
critcl::ccommand stack_critcl {dummy interp objc objv} { |
||||
/* Syntax |
||||
* - epsilon |1 |
||||
* - name |2 |
||||
*/ |
||||
|
||||
CONST char* name; |
||||
S* sd; |
||||
Tcl_Obj* fqn; |
||||
Tcl_CmdInfo ci; |
||||
|
||||
#define USAGE "?name?" |
||||
|
||||
if ((objc != 2) && (objc != 1)) { |
||||
Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
if (objc < 2) { |
||||
name = SDnewName (interp); |
||||
} else { |
||||
name = Tcl_GetString (objv [1]); |
||||
} |
||||
|
||||
if (!Tcl_StringMatch (name, "::*")) { |
||||
/* Relative name. Prefix with current namespace */ |
||||
|
||||
Tcl_Eval (interp, "namespace current"); |
||||
fqn = Tcl_GetObjResult (interp); |
||||
fqn = Tcl_DuplicateObj (fqn); |
||||
Tcl_IncrRefCount (fqn); |
||||
|
||||
if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { |
||||
Tcl_AppendToObj (fqn, "::", -1); /* OK tcl9 */ |
||||
} |
||||
Tcl_AppendToObj (fqn, name, -1); /* OK tcl9 */ |
||||
} else { |
||||
fqn = Tcl_NewStringObj (name, -1); /* OK tcl9 */ |
||||
Tcl_IncrRefCount (fqn); |
||||
} |
||||
Tcl_ResetResult (interp); |
||||
|
||||
if (Tcl_GetCommandInfo (interp, |
||||
Tcl_GetString (fqn), |
||||
&ci)) { |
||||
Tcl_Obj* err; |
||||
|
||||
err = Tcl_NewObj (); |
||||
Tcl_AppendToObj (err, "command \"", -1); /* OK tcl9 */ |
||||
Tcl_AppendObjToObj (err, fqn); |
||||
Tcl_AppendToObj (err, "\" already exists, unable to create stack", -1); /* OK tcl9 */ |
||||
|
||||
Tcl_DecrRefCount (fqn); |
||||
Tcl_SetObjResult (interp, err); |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
sd = st_new(); |
||||
sd->cmd = Tcl_CreateObjCommand2 (interp, Tcl_GetString (fqn), |
||||
stms_objcmd, (ClientData) sd, |
||||
SDdeleteCmd); |
||||
|
||||
Tcl_SetObjResult (interp, fqn); |
||||
Tcl_DecrRefCount (fqn); |
||||
return TCL_OK; |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
@ -0,0 +1,296 @@
|
||||
# stack.tcl -- |
||||
# |
||||
# Stack implementation for Tcl 8.6+, or 8.5 + TclOO |
||||
# |
||||
# Copyright (c) 2010 Andreas Kupries |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: stack_oo.tcl,v 1.4 2010/09/10 17:31:04 andreas_kupries Exp $ |
||||
|
||||
package require Tcl 8.5 9 |
||||
package require TclOO 0.6.1- ; # This includes 1 and higher. |
||||
|
||||
# Cleanup first |
||||
catch {namespace delete ::struct::stack::stack_oo} |
||||
catch {rename ::struct::stack::stack_oo {}} |
||||
|
||||
oo::class create ::struct::stack::stack_oo { |
||||
|
||||
variable mystack |
||||
|
||||
constructor {} { |
||||
set mystack {} |
||||
return |
||||
} |
||||
|
||||
# clear -- |
||||
# |
||||
# Clear a stack. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
method clear {} { |
||||
set mystack {} |
||||
return |
||||
} |
||||
|
||||
# get -- |
||||
# |
||||
# Retrieve the whole contents of the stack. |
||||
# |
||||
# Results: |
||||
# items list of all items in the stack. |
||||
|
||||
method get {} { |
||||
return [lreverse $mystack] |
||||
} |
||||
|
||||
method getr {} { |
||||
return $mystack |
||||
} |
||||
|
||||
# peek -- |
||||
# |
||||
# Retrieve the value of an item on the stack without popping it. |
||||
# |
||||
# Arguments: |
||||
# count number of items to pop; defaults to 1 |
||||
# |
||||
# Results: |
||||
# items top count items from the stack; if there are not enough items |
||||
# to fulfill the request, throws an error. |
||||
|
||||
method peek {{count 1}} { |
||||
if { $count < 1 } { |
||||
return -code error "invalid item count $count" |
||||
} elseif { $count > [llength $mystack] } { |
||||
return -code error "insufficient items on stack to fill request" |
||||
} |
||||
|
||||
if { $count == 1 } { |
||||
# Handle this as a special case, so single item peeks are not |
||||
# listified |
||||
return [lindex $mystack end] |
||||
} |
||||
|
||||
# Otherwise, return a list of items |
||||
incr count -1 |
||||
return [lreverse [lrange $mystack end-$count end]] |
||||
} |
||||
|
||||
method peekr {{count 1}} { |
||||
if { $count < 1 } { |
||||
return -code error "invalid item count $count" |
||||
} elseif { $count > [llength $mystack] } { |
||||
return -code error "insufficient items on stack to fill request" |
||||
} |
||||
|
||||
if { $count == 1 } { |
||||
# Handle this as a special case, so single item peeks are not |
||||
# listified |
||||
return [lindex $mystack end] |
||||
} |
||||
|
||||
# Otherwise, return a list of items, in reversed order. |
||||
incr count -1 |
||||
return [lrange $mystack end-$count end] |
||||
} |
||||
|
||||
# trim -- |
||||
# |
||||
# Pop items off a stack until a maximum size is reached. |
||||
# |
||||
# Arguments: |
||||
# count requested size of the stack. |
||||
# |
||||
# Results: |
||||
# item List of items trimmed, may be empty. |
||||
|
||||
method trim {newsize} { |
||||
if { ![string is integer -strict $newsize]} { |
||||
return -code error "expected integer but got \"$newsize\"" |
||||
} elseif { $newsize < 0 } { |
||||
return -code error "invalid size $newsize" |
||||
} elseif { $newsize >= [llength $mystack] } { |
||||
# Stack is smaller than requested, do nothing. |
||||
return {} |
||||
} |
||||
|
||||
# newsize < [llength $mystack] |
||||
# pop '[llength $mystack]' - newsize elements. |
||||
|
||||
if {!$newsize} { |
||||
set result [lreverse [my K $mystack [unset mystack]]] |
||||
set mystack {} |
||||
} else { |
||||
set result [lreverse [lrange $mystack $newsize end]] |
||||
set mystack [lreplace [my K $mystack [unset mystack]] $newsize end] |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
method trim* {newsize} { |
||||
if { ![string is integer -strict $newsize]} { |
||||
return -code error "expected integer but got \"$newsize\"" |
||||
} elseif { $newsize < 0 } { |
||||
return -code error "invalid size $newsize" |
||||
} |
||||
|
||||
if { $newsize >= [llength $mystack] } { |
||||
# Stack is smaller than requested, do nothing. |
||||
return |
||||
} |
||||
|
||||
# newsize < [llength $mystack] |
||||
# pop '[llength $mystack]' - newsize elements. |
||||
|
||||
# No results, compared to trim. |
||||
|
||||
if {!$newsize} { |
||||
set mystack {} |
||||
} else { |
||||
set mystack [lreplace [my K $mystack [unset mystack]] $newsize end] |
||||
} |
||||
|
||||
return |
||||
} |
||||
|
||||
# pop -- |
||||
# |
||||
# Pop an item off a stack. |
||||
# |
||||
# Arguments: |
||||
# count number of items to pop; defaults to 1 |
||||
# |
||||
# Results: |
||||
# item top count items from the stack; if the stack is empty, |
||||
# returns a list of count nulls. |
||||
|
||||
method pop {{count 1}} { |
||||
if { $count < 1 } { |
||||
return -code error "invalid item count $count" |
||||
} |
||||
|
||||
set ssize [llength $mystack] |
||||
|
||||
if { $count > $ssize } { |
||||
return -code error "insufficient items on stack to fill request" |
||||
} |
||||
|
||||
if { $count == 1 } { |
||||
# Handle this as a special case, so single item pops are not |
||||
# listified |
||||
set item [lindex $mystack end] |
||||
if {$count == $ssize} { |
||||
set mystack [list] |
||||
} else { |
||||
set mystack [lreplace [my K $mystack [unset mystack]] end end] |
||||
} |
||||
return $item |
||||
} |
||||
|
||||
# Otherwise, return a list of items, and remove the items from the |
||||
# stack. |
||||
if {$count == $ssize} { |
||||
set result [lreverse [my K $mystack [unset mystack]]] |
||||
set mystack [list] |
||||
} else { |
||||
incr count -1 |
||||
set result [lreverse [lrange $mystack end-$count end]] |
||||
set mystack [lreplace [my K $mystack [unset mystack]] end-$count end] |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# push -- |
||||
# |
||||
# Push an item onto a stack. |
||||
# |
||||
# Arguments: |
||||
# args items to push. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
method push {args} { |
||||
if {![llength $args]} { |
||||
return -code error "wrong # args: should be \"[self] push item ?item ...?\"" |
||||
} |
||||
|
||||
lappend mystack {*}$args |
||||
return |
||||
} |
||||
|
||||
# rotate -- |
||||
# |
||||
# Rotate the top count number of items by step number of steps. |
||||
# |
||||
# Arguments: |
||||
# count number of items to rotate. |
||||
# steps number of steps to rotate. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
method rotate {count steps} { |
||||
set len [llength $mystack] |
||||
if { $count > $len } { |
||||
return -code error "insufficient items on stack to fill request" |
||||
} |
||||
|
||||
# Rotation algorithm: |
||||
# do |
||||
# Find the insertion point in the stack |
||||
# Move the end item to the insertion point |
||||
# repeat $steps times |
||||
|
||||
set start [expr {$len - $count}] |
||||
set steps [expr {$steps % $count}] |
||||
|
||||
if {$steps == 0} return |
||||
|
||||
for {set i 0} {$i < $steps} {incr i} { |
||||
set item [lindex $mystack end] |
||||
set mystack [linsert \ |
||||
[lreplace \ |
||||
[my K $mystack [unset mystack]] \ |
||||
end end] $start $item] |
||||
} |
||||
return |
||||
} |
||||
|
||||
# size -- |
||||
# |
||||
# Return the number of objects on a stack. |
||||
# |
||||
# Results: |
||||
# count number of items on the stack. |
||||
|
||||
method size {} { |
||||
return [llength $mystack] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
method K {x y} { set x } |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Get 'stack::stack' into the general structure namespace for |
||||
# pickup by the main management. |
||||
|
||||
proc stack_tcl {args} { |
||||
if {[llength $args]} { |
||||
uplevel 1 [::list ::struct::stack::stack_oo create {*}$args] |
||||
} else { |
||||
uplevel 1 [::list ::struct::stack::stack_oo new] |
||||
} |
||||
} |
||||
} |
||||
@ -0,0 +1,505 @@
|
||||
# stack.tcl -- |
||||
# |
||||
# Stack implementation for Tcl. |
||||
# |
||||
# Copyright (c) 1998-2000 by Ajuba Solutions. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: stack_tcl.tcl,v 1.3 2010/03/15 17:17:38 andreas_kupries Exp $ |
||||
|
||||
namespace eval ::struct::stack { |
||||
# counter is used to give a unique name for unnamed stacks |
||||
variable counter 0 |
||||
|
||||
# Only export one command, the one used to instantiate a new stack |
||||
namespace export stack_tcl |
||||
} |
||||
|
||||
# ::struct::stack::stack_tcl -- |
||||
# |
||||
# Create a new stack with a given name; if no name is given, use |
||||
# stackX, where X is a number. |
||||
# |
||||
# Arguments: |
||||
# name name of the stack; if null, generate one. |
||||
# |
||||
# Results: |
||||
# name name of the stack created |
||||
|
||||
proc ::struct::stack::stack_tcl {args} { |
||||
variable I::stacks |
||||
variable counter |
||||
|
||||
switch -exact -- [llength [info level 0]] { |
||||
1 { |
||||
# Missing name, generate one. |
||||
incr counter |
||||
set name "stack${counter}" |
||||
} |
||||
2 { |
||||
# Standard call. New empty stack. |
||||
set name [lindex $args 0] |
||||
} |
||||
default { |
||||
# Error. |
||||
return -code error \ |
||||
"wrong # args: should be \"stack ?name?\"" |
||||
} |
||||
} |
||||
|
||||
# FIRST, qualify the name. |
||||
if {![string match "::*" $name]} { |
||||
# Get caller's namespace; append :: if not global namespace. |
||||
set ns [uplevel 1 [list namespace current]] |
||||
if {"::" != $ns} { |
||||
append ns "::" |
||||
} |
||||
|
||||
set name "$ns$name" |
||||
} |
||||
if {[llength [info commands $name]]} { |
||||
return -code error \ |
||||
"command \"$name\" already exists, unable to create stack" |
||||
} |
||||
|
||||
set stacks($name) [list ] |
||||
|
||||
# Create the command to manipulate the stack |
||||
interp alias {} $name {} ::struct::stack::StackProc $name |
||||
|
||||
return $name |
||||
} |
||||
|
||||
########################## |
||||
# Private functions follow |
||||
|
||||
# ::struct::stack::StackProc -- |
||||
# |
||||
# Command that processes all stack object commands. |
||||
# |
||||
# Arguments: |
||||
# name name of the stack object to manipulate. |
||||
# args command name and args for the command |
||||
# |
||||
# Results: |
||||
# Varies based on command to perform |
||||
|
||||
if {[package vsatisfies [package provide Tcl] 8.5 9]} { |
||||
# In 8.5+ we can do an ensemble for fast dispatch. |
||||
|
||||
proc ::struct::stack::StackProc {name cmd args} { |
||||
# Shuffle method to front and then simply run the ensemble. |
||||
# Dispatch, argument checking, and error message generation |
||||
# are all done in the C-level. |
||||
|
||||
I $cmd $name {*}$args |
||||
} |
||||
|
||||
namespace eval ::struct::stack::I { |
||||
namespace export clear destroy get getr peek peekr \ |
||||
trim trim* pop push rotate size |
||||
namespace ensemble create |
||||
} |
||||
|
||||
} else { |
||||
# Before 8.5 we have to code our own dispatch, including error |
||||
# checking. |
||||
|
||||
proc ::struct::stack::StackProc {name cmd args} { |
||||
# Do minimal args checks here |
||||
if { [llength [info level 0]] == 2 } { |
||||
return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" |
||||
} |
||||
|
||||
# Split the args into command and args components |
||||
if {![llength [info commands ::struct::stack::I::$cmd]]} { |
||||
set optlist [lsort [info commands ::struct::stack::I::*]] |
||||
set xlist {} |
||||
foreach p $optlist { |
||||
set p [namespace tail $p] |
||||
if {($p eq "K") || ($p eq "lreverse")} continue |
||||
lappend xlist $p |
||||
} |
||||
set optlist [linsert [join $xlist ", "] "end-1" "or"] |
||||
return -code error \ |
||||
"bad option \"$cmd\": must be $optlist" |
||||
} |
||||
|
||||
uplevel 1 [linsert $args 0 ::struct::stack::I::$cmd $name] |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
namespace eval ::struct::stack::I { |
||||
# The stacks array holds all of the stacks you've made |
||||
variable stacks |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
# ::struct::stack::I::clear -- |
||||
# |
||||
# Clear a stack. |
||||
# |
||||
# Arguments: |
||||
# name name of the stack object. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::stack::I::clear {name} { |
||||
variable stacks |
||||
set stacks($name) {} |
||||
return |
||||
} |
||||
|
||||
# ::struct::stack::I::destroy -- |
||||
# |
||||
# Destroy a stack object by removing it's storage space and |
||||
# eliminating it's proc. |
||||
# |
||||
# Arguments: |
||||
# name name of the stack object. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::stack::I::destroy {name} { |
||||
variable stacks |
||||
unset stacks($name) |
||||
interp alias {} $name {} |
||||
return |
||||
} |
||||
|
||||
# ::struct::stack::I::get -- |
||||
# |
||||
# Retrieve the whole contents of the stack. |
||||
# |
||||
# Arguments: |
||||
# name name of the stack object. |
||||
# |
||||
# Results: |
||||
# items list of all items in the stack. |
||||
|
||||
proc ::struct::stack::I::get {name} { |
||||
variable stacks |
||||
return [lreverse $stacks($name)] |
||||
} |
||||
|
||||
proc ::struct::stack::I::getr {name} { |
||||
variable stacks |
||||
return $stacks($name) |
||||
} |
||||
|
||||
# ::struct::stack::I::peek -- |
||||
# |
||||
# Retrieve the value of an item on the stack without popping it. |
||||
# |
||||
# Arguments: |
||||
# name name of the stack object. |
||||
# count number of items to pop; defaults to 1 |
||||
# |
||||
# Results: |
||||
# items top count items from the stack; if there are not enough items |
||||
# to fulfill the request, throws an error. |
||||
|
||||
proc ::struct::stack::I::peek {name {count 1}} { |
||||
variable stacks |
||||
upvar 0 stacks($name) mystack |
||||
|
||||
if { $count < 1 } { |
||||
return -code error "invalid item count $count" |
||||
} elseif { $count > [llength $mystack] } { |
||||
return -code error "insufficient items on stack to fill request" |
||||
} |
||||
|
||||
if { $count == 1 } { |
||||
# Handle this as a special case, so single item peeks are not |
||||
# listified |
||||
return [lindex $mystack end] |
||||
} |
||||
|
||||
# Otherwise, return a list of items |
||||
incr count -1 |
||||
return [lreverse [lrange $mystack end-$count end]] |
||||
} |
||||
|
||||
proc ::struct::stack::I::peekr {name {count 1}} { |
||||
variable stacks |
||||
upvar 0 stacks($name) mystack |
||||
|
||||
if { $count < 1 } { |
||||
return -code error "invalid item count $count" |
||||
} elseif { $count > [llength $mystack] } { |
||||
return -code error "insufficient items on stack to fill request" |
||||
} |
||||
|
||||
if { $count == 1 } { |
||||
# Handle this as a special case, so single item peeks are not |
||||
# listified |
||||
return [lindex $mystack end] |
||||
} |
||||
|
||||
# Otherwise, return a list of items, in reversed order. |
||||
incr count -1 |
||||
return [lrange $mystack end-$count end] |
||||
} |
||||
|
||||
# ::struct::stack::I::trim -- |
||||
# |
||||
# Pop items off a stack until a maximum size is reached. |
||||
# |
||||
# Arguments: |
||||
# name name of the stack object. |
||||
# count requested size of the stack. |
||||
# |
||||
# Results: |
||||
# item List of items trimmed, may be empty. |
||||
|
||||
proc ::struct::stack::I::trim {name newsize} { |
||||
variable stacks |
||||
upvar 0 stacks($name) mystack |
||||
|
||||
if { ![string is integer -strict $newsize]} { |
||||
return -code error "expected integer but got \"$newsize\"" |
||||
} elseif { $newsize < 0 } { |
||||
return -code error "invalid size $newsize" |
||||
} elseif { $newsize >= [llength $mystack] } { |
||||
# Stack is smaller than requested, do nothing. |
||||
return {} |
||||
} |
||||
|
||||
# newsize < [llength $mystack] |
||||
# pop '[llength $mystack]' - newsize elements. |
||||
|
||||
if {!$newsize} { |
||||
set result [lreverse [K $mystack [unset mystack]]] |
||||
set mystack {} |
||||
} else { |
||||
set result [lreverse [lrange $mystack $newsize end]] |
||||
set mystack [lreplace [K $mystack [unset mystack]] $newsize end] |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
proc ::struct::stack::I::trim* {name newsize} { |
||||
if { ![string is integer -strict $newsize]} { |
||||
return -code error "expected integer but got \"$newsize\"" |
||||
} elseif { $newsize < 0 } { |
||||
return -code error "invalid size $newsize" |
||||
} |
||||
|
||||
variable stacks |
||||
upvar 0 stacks($name) mystack |
||||
|
||||
if { $newsize >= [llength $mystack] } { |
||||
# Stack is smaller than requested, do nothing. |
||||
return |
||||
} |
||||
|
||||
# newsize < [llength $mystack] |
||||
# pop '[llength $mystack]' - newsize elements. |
||||
|
||||
# No results, compared to trim. |
||||
|
||||
if {!$newsize} { |
||||
set mystack {} |
||||
} else { |
||||
set mystack [lreplace [K $mystack [unset mystack]] $newsize end] |
||||
} |
||||
|
||||
return |
||||
} |
||||
|
||||
# ::struct::stack::I::pop -- |
||||
# |
||||
# Pop an item off a stack. |
||||
# |
||||
# Arguments: |
||||
# name name of the stack object. |
||||
# count number of items to pop; defaults to 1 |
||||
# |
||||
# Results: |
||||
# item top count items from the stack; if the stack is empty, |
||||
# returns a list of count nulls. |
||||
|
||||
proc ::struct::stack::I::pop {name {count 1}} { |
||||
variable stacks |
||||
upvar 0 stacks($name) mystack |
||||
|
||||
if { $count < 1 } { |
||||
return -code error "invalid item count $count" |
||||
} |
||||
set ssize [llength $mystack] |
||||
if { $count > $ssize } { |
||||
return -code error "insufficient items on stack to fill request" |
||||
} |
||||
|
||||
if { $count == 1 } { |
||||
# Handle this as a special case, so single item pops are not |
||||
# listified |
||||
set item [lindex $mystack end] |
||||
if {$count == $ssize} { |
||||
set mystack [list] |
||||
} else { |
||||
set mystack [lreplace [K $mystack [unset mystack]] end end] |
||||
} |
||||
return $item |
||||
} |
||||
|
||||
# Otherwise, return a list of items, and remove the items from the |
||||
# stack. |
||||
if {$count == $ssize} { |
||||
set result [lreverse [K $mystack [unset mystack]]] |
||||
set mystack [list] |
||||
} else { |
||||
incr count -1 |
||||
set result [lreverse [lrange $mystack end-$count end]] |
||||
set mystack [lreplace [K $mystack [unset mystack]] end-$count end] |
||||
} |
||||
return $result |
||||
|
||||
# ------------------------------------------------------- |
||||
|
||||
set newsize [expr {[llength $mystack] - $count}] |
||||
|
||||
if {!$newsize} { |
||||
set result [lreverse [K $mystack [unset mystack]]] |
||||
set mystack {} |
||||
} else { |
||||
set result [lreverse [lrange $mystack $newsize end]] |
||||
set mystack [lreplace [K $mystack [unset mystack]] $newsize end] |
||||
} |
||||
|
||||
if {$count == 1} { |
||||
set result [lindex $result 0] |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
# ::struct::stack::I::push -- |
||||
# |
||||
# Push an item onto a stack. |
||||
# |
||||
# Arguments: |
||||
# name name of the stack object |
||||
# args items to push. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
if {[package vsatisfies [package provide Tcl] 8.5 9]} { |
||||
|
||||
proc ::struct::stack::I::push {name args} { |
||||
if {![llength $args]} { |
||||
return -code error "wrong # args: should be \"$name push item ?item ...?\"" |
||||
} |
||||
|
||||
variable stacks |
||||
upvar 0 stacks($name) mystack |
||||
|
||||
lappend mystack {*}$args |
||||
return |
||||
} |
||||
} else { |
||||
proc ::struct::stack::I::push {name args} { |
||||
if {![llength $args]} { |
||||
return -code error "wrong # args: should be \"$name push item ?item ...?\"" |
||||
} |
||||
|
||||
variable stacks |
||||
upvar 0 stacks($name) mystack |
||||
|
||||
if {[llength $args] == 1} { |
||||
lappend mystack [lindex $args 0] |
||||
} else { |
||||
eval [linsert $args 0 lappend mystack] |
||||
} |
||||
return |
||||
} |
||||
} |
||||
|
||||
# ::struct::stack::I::rotate -- |
||||
# |
||||
# Rotate the top count number of items by step number of steps. |
||||
# |
||||
# Arguments: |
||||
# name name of the stack object. |
||||
# count number of items to rotate. |
||||
# steps number of steps to rotate. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::stack::I::rotate {name count steps} { |
||||
variable stacks |
||||
upvar 0 stacks($name) mystack |
||||
set len [llength $mystack] |
||||
if { $count > $len } { |
||||
return -code error "insufficient items on stack to fill request" |
||||
} |
||||
|
||||
# Rotation algorithm: |
||||
# do |
||||
# Find the insertion point in the stack |
||||
# Move the end item to the insertion point |
||||
# repeat $steps times |
||||
|
||||
set start [expr {$len - $count}] |
||||
set steps [expr {$steps % $count}] |
||||
|
||||
if {$steps == 0} return |
||||
|
||||
for {set i 0} {$i < $steps} {incr i} { |
||||
set item [lindex $mystack end] |
||||
set mystack [linsert \ |
||||
[lreplace \ |
||||
[K $mystack [unset mystack]] \ |
||||
end end] $start $item] |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ::struct::stack::I::size -- |
||||
# |
||||
# Return the number of objects on a stack. |
||||
# |
||||
# Arguments: |
||||
# name name of the stack object. |
||||
# |
||||
# Results: |
||||
# count number of items on the stack. |
||||
|
||||
proc ::struct::stack::I::size {name} { |
||||
variable stacks |
||||
return [llength $stacks($name)] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
proc ::struct::stack::I::K {x y} { set x } |
||||
|
||||
if {![llength [info commands lreverse]]} { |
||||
proc ::struct::stack::I::lreverse {x} { |
||||
# assert (llength(x) > 1) |
||||
set l [llength $x] |
||||
if {$l <= 1} { return $x } |
||||
set r [list] |
||||
while {$l} { lappend r [lindex $x [incr l -1]] } |
||||
return $r |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Get 'stack::stack' into the general structure namespace for |
||||
# pickup by the main management. |
||||
namespace import -force stack::stack_tcl |
||||
} |
||||
@ -0,0 +1,18 @@
|
||||
package require Tcl 8.5 9 |
||||
package require struct::graph 2.0 |
||||
package require struct::queue 1.2.1 |
||||
package require struct::stack 1.2.1 |
||||
package require struct::tree 2.0 |
||||
package require struct::matrix 2.0 |
||||
package require struct::pool 1.2.1 |
||||
package require struct::record 1.2.1 |
||||
package require struct::list 1.4 |
||||
package require struct::set 2.1 |
||||
package require struct::prioqueue 1.3 |
||||
package require struct::skiplist 1.4 |
||||
|
||||
namespace eval ::struct { |
||||
namespace export * |
||||
} |
||||
|
||||
package provide struct 2.2 |
||||
@ -0,0 +1,17 @@
|
||||
package require Tcl 8.5 9 |
||||
package require struct::graph 1.2.2 |
||||
package require struct::queue 1.2.1 |
||||
package require struct::stack 1.2.1 |
||||
package require struct::tree 1.2.1 |
||||
package require struct::matrix 1.2.1 |
||||
package require struct::pool 1.2.1 |
||||
package require struct::record 1.2.1 |
||||
package require struct::list 1.4 |
||||
package require struct::prioqueue 1.3 |
||||
package require struct::skiplist 1.4 |
||||
|
||||
namespace eval ::struct { |
||||
namespace export * |
||||
} |
||||
|
||||
package provide struct 1.5 |
||||
@ -0,0 +1,182 @@
|
||||
# tree.tcl -- |
||||
# |
||||
# Implementation of a tree data structure for Tcl. |
||||
# |
||||
# Copyright (c) 1998-2000 by Ajuba Solutions. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: tree.tcl,v 1.45 2009/06/22 18:21:59 andreas_kupries Exp $ |
||||
|
||||
# @mdgen EXCLUDE: tree_c.tcl |
||||
|
||||
package require Tcl 8.5 9 |
||||
package require struct::list |
||||
|
||||
namespace eval ::struct::tree {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Management of tree implementations. |
||||
|
||||
# ::struct::tree::LoadAccelerator -- |
||||
# |
||||
# Loads a named implementation, if possible. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to load. |
||||
# |
||||
# Results: |
||||
# A boolean flag. True if the implementation |
||||
# was successfully loaded; and False otherwise. |
||||
|
||||
proc ::struct::tree::LoadAccelerator {key} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $key { |
||||
critcl { |
||||
# Critcl implementation of tree requires Tcl 8.4. |
||||
if {[catch {package require tcllibc}]} {return 0} |
||||
set r [llength [info commands ::struct::tree_critcl]] |
||||
} |
||||
tcl { |
||||
variable selfdir |
||||
source [file join $selfdir tree_tcl.tcl] |
||||
set r 1 |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator/impl. package $key:\ |
||||
must be one of [join [KnownImplementations] {, }]" |
||||
} |
||||
} |
||||
set accel($key) $r |
||||
return $r |
||||
} |
||||
|
||||
# ::struct::tree::SwitchTo -- |
||||
# |
||||
# Activates a loaded named implementation. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to activate. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::tree::SwitchTo {key} { |
||||
variable accel |
||||
variable loaded |
||||
|
||||
if {[string equal $key $loaded]} { |
||||
# No change, nothing to do. |
||||
return |
||||
} elseif {![string equal $key ""]} { |
||||
# Validate the target implementation of the switch. |
||||
|
||||
if {![info exists accel($key)]} { |
||||
return -code error "Unable to activate unknown implementation \"$key\"" |
||||
} elseif {![info exists accel($key)] || !$accel($key)} { |
||||
return -code error "Unable to activate missing implementation \"$key\"" |
||||
} |
||||
} |
||||
|
||||
# Deactivate the previous implementation, if there was any. |
||||
|
||||
if {![string equal $loaded ""]} { |
||||
rename ::struct::tree ::struct::tree_$loaded |
||||
rename ::struct::tree::prune ::struct::tree::prune_$loaded |
||||
} |
||||
|
||||
# Activate the new implementation, if there is any. |
||||
|
||||
if {![string equal $key ""]} { |
||||
rename ::struct::tree_$key ::struct::tree |
||||
rename ::struct::tree::prune_$key ::struct::tree::prune |
||||
} |
||||
|
||||
# Remember the active implementation, for deactivation by future |
||||
# switches. |
||||
|
||||
set loaded $key |
||||
return |
||||
} |
||||
|
||||
# ::struct::tree::Implementations -- |
||||
# |
||||
# Determines which implementations are |
||||
# present, i.e. loaded. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. |
||||
|
||||
proc ::struct::tree::Implementations {} { |
||||
variable accel |
||||
set res {} |
||||
foreach n [array names accel] { |
||||
if {!$accel($n)} continue |
||||
lappend res $n |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::struct::tree::KnownImplementations -- |
||||
# |
||||
# Determines which implementations are known |
||||
# as possible implementations. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. In the order |
||||
# of preference, most prefered first. |
||||
|
||||
proc ::struct::tree::KnownImplementations {} { |
||||
return {critcl tcl} |
||||
} |
||||
|
||||
proc ::struct::tree::Names {} { |
||||
return { |
||||
critcl {tcllibc based} |
||||
tcl {pure Tcl} |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Data structures. |
||||
|
||||
namespace eval ::struct::tree { |
||||
variable selfdir [file dirname [info script]] |
||||
variable accel |
||||
array set accel {tcl 0 critcl 0} |
||||
variable loaded {} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Choose an implementation, |
||||
## most prefered first. Loads only one of the |
||||
## possible implementations. And activates it. |
||||
|
||||
namespace eval ::struct::tree { |
||||
variable e |
||||
foreach e [KnownImplementations] { |
||||
if {[LoadAccelerator $e]} { |
||||
SwitchTo $e |
||||
break |
||||
} |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Export the constructor command. |
||||
namespace export tree |
||||
} |
||||
|
||||
package provide struct::tree 2.1.3 |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,206 @@
|
||||
# treec.tcl -- |
||||
# |
||||
# Implementation of a tree data structure for Tcl. |
||||
# This code based on critcl, API compatible to the PTI [x]. |
||||
# [x] Pure Tcl Implementation. |
||||
# |
||||
# Copyright (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
|
||||
package require critcl |
||||
# @sak notprovided struct_treec |
||||
package provide struct_treec 2.1.1 |
||||
package require Tcl 8.5 9 |
||||
|
||||
namespace eval ::struct { |
||||
# Supporting code for the main command. |
||||
|
||||
catch { |
||||
#critcl::cheaders -g |
||||
#critcl::debug memory symbols |
||||
} |
||||
|
||||
critcl::cheaders tree/*.h |
||||
critcl::csources tree/*.c |
||||
|
||||
critcl::ccode { |
||||
/* -*- c -*- */ |
||||
|
||||
#include <util.h> |
||||
#include <t.h> |
||||
#include <tn.h> |
||||
#include <ms.h> |
||||
#include <m.h> |
||||
|
||||
/* .................................................. */ |
||||
/* Global tree management, per interp |
||||
*/ |
||||
|
||||
typedef struct TDg { |
||||
long int counter; |
||||
char buf [50]; |
||||
} TDg; |
||||
|
||||
static void |
||||
TDgrelease (ClientData cd, Tcl_Interp* interp) |
||||
{ |
||||
ckfree((char*) cd); |
||||
} |
||||
|
||||
static CONST char* |
||||
TDnewName (Tcl_Interp* interp) |
||||
{ |
||||
#define KEY "tcllib/struct::tree/critcl" |
||||
|
||||
Tcl_InterpDeleteProc* proc = TDgrelease; |
||||
TDg* tdg; |
||||
|
||||
tdg = Tcl_GetAssocData (interp, KEY, &proc); |
||||
if (tdg == NULL) { |
||||
tdg = (TDg*) ckalloc (sizeof (TDg)); |
||||
tdg->counter = 0; |
||||
|
||||
Tcl_SetAssocData (interp, KEY, proc, |
||||
(ClientData) tdg); |
||||
} |
||||
|
||||
tdg->counter ++; |
||||
sprintf (tdg->buf, "tree%ld", tdg->counter); |
||||
return tdg->buf; |
||||
|
||||
#undef KEY |
||||
} |
||||
|
||||
static void |
||||
TDdeleteCmd (ClientData clientData) |
||||
{ |
||||
/* Release the whole tree. */ |
||||
t_delete ((T*) clientData); |
||||
} |
||||
} |
||||
|
||||
# Main command, tree creation. |
||||
|
||||
critcl::ccommand tree_critcl {dummy interp objc objv} { |
||||
/* Syntax |
||||
* - epsilon |1 |
||||
* - name |2 |
||||
* - name =|:=|as|deserialize source |4 |
||||
*/ |
||||
|
||||
CONST char* name; |
||||
T* td; |
||||
Tcl_Obj* fqn; |
||||
Tcl_CmdInfo ci; |
||||
|
||||
#define USAGE "?name ?=|:=|as|deserialize source??" |
||||
|
||||
if ((objc != 4) && (objc != 2) && (objc != 1)) { |
||||
Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
if (objc < 2) { |
||||
name = TDnewName (interp); |
||||
} else { |
||||
name = Tcl_GetString (objv [1]); |
||||
} |
||||
|
||||
if (!Tcl_StringMatch (name, "::*")) { |
||||
/* Relative name. Prefix with current namespace */ |
||||
|
||||
Tcl_Eval (interp, "namespace current"); |
||||
fqn = Tcl_GetObjResult (interp); |
||||
fqn = Tcl_DuplicateObj (fqn); |
||||
Tcl_IncrRefCount (fqn); |
||||
|
||||
if (!Tcl_StringMatch (Tcl_GetString (fqn), "::")) { |
||||
Tcl_AppendToObj (fqn, "::", -1); /* OK tcl9 */ |
||||
} |
||||
Tcl_AppendToObj (fqn, name, -1); /* OK tcl9 */ |
||||
} else { |
||||
fqn = Tcl_NewStringObj (name, -1); /* OK tcl9 */ |
||||
Tcl_IncrRefCount (fqn); |
||||
} |
||||
Tcl_ResetResult (interp); |
||||
|
||||
if (Tcl_GetCommandInfo (interp, |
||||
Tcl_GetString (fqn), |
||||
&ci)) { |
||||
Tcl_Obj* err; |
||||
|
||||
err = Tcl_NewObj (); |
||||
Tcl_AppendToObj (err, "command \"", -1); /* OK tcl9 */ |
||||
Tcl_AppendObjToObj (err, fqn); |
||||
Tcl_AppendToObj (err, "\" already exists, unable to create tree", -1); /* OK tcl9 */ |
||||
|
||||
Tcl_DecrRefCount (fqn); |
||||
Tcl_SetObjResult (interp, err); |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
if (objc == 4) { |
||||
Tcl_Obj* type = objv[2]; |
||||
Tcl_Obj* src = objv[3]; |
||||
int srctype; |
||||
|
||||
static CONST char* types [] = { |
||||
":=", "=", "as", "deserialize", NULL |
||||
}; |
||||
enum types { |
||||
T_ASSIGN, T_IS, T_AS, T_DESER |
||||
}; |
||||
|
||||
if (Tcl_GetIndexFromObj (interp, type, types, "type", |
||||
0, &srctype) != TCL_OK) { |
||||
Tcl_DecrRefCount (fqn); |
||||
Tcl_ResetResult (interp); |
||||
Tcl_WrongNumArgs (interp, 1, objv, USAGE); /* OK tcl9 */ |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
td = t_new (); |
||||
|
||||
switch (srctype) { |
||||
case T_ASSIGN: |
||||
case T_AS: |
||||
case T_IS: |
||||
if (tms_assign (interp, td, src) != TCL_OK) { |
||||
t_delete (td); |
||||
Tcl_DecrRefCount (fqn); |
||||
return TCL_ERROR; |
||||
} |
||||
break; |
||||
|
||||
case T_DESER: |
||||
if (t_deserialize (td, interp, src) != TCL_OK) { |
||||
t_delete (td); |
||||
Tcl_DecrRefCount (fqn); |
||||
return TCL_ERROR; |
||||
} |
||||
break; |
||||
} |
||||
} else { |
||||
td = t_new (); |
||||
} |
||||
|
||||
td->cmd = Tcl_CreateObjCommand2 (interp, Tcl_GetString (fqn), |
||||
tms_objcmd, (ClientData) td, |
||||
TDdeleteCmd); |
||||
|
||||
Tcl_SetObjResult (interp, fqn); |
||||
Tcl_DecrRefCount (fqn); |
||||
return TCL_OK; |
||||
} |
||||
|
||||
namespace eval tree { |
||||
critcl::ccommand prune_critcl {dummy interp objc objv} { |
||||
return 5; |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,186 @@
|
||||
2013-11-22 Andreas Kupries <andreask@activestate.com> |
||||
|
||||
* tar.man: Reviewed the work on the pyk-tar branch. Brought |
||||
* tar.tcl: new testsuite up to spec. Reviewed the skip fix, |
||||
* tar.test: modified it to reinstate the skip limit per round |
||||
* test-support.tcl: without getting the bug back. Bumped version |
||||
to 0.9. Thanks to PoorYorick for the initial work on the bug, |
||||
fix, and testsuite. This also fixes ticket [6b7aa0aecc]. |
||||
|
||||
2013-08-12 Andreas Kupries <andreask@activestate.com> |
||||
|
||||
* tar.man (tar::untar, contents, stat, get): Extended the |
||||
* tar.tcl: procedures to detect and properly handle @LongName |
||||
* pkgIndex.tcl: header entries as generated by GNU tar. These |
||||
entries contain the file name for the next header entry as file |
||||
data, for files whose name is longer than the 100-char field of |
||||
the regular header. Version bumped to 0.8. This is a new |
||||
feature. |
||||
|
||||
2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.15 ======================== |
||||
* |
||||
|
||||
2012-09-11 Andreas Kupries <andreask@activestate.com> |
||||
|
||||
* tar.tcl (seekorskip): Fixed seekorskip which prevented its use |
||||
* pkgIndex.tcl: from a non-seekable channel, like stdin. The issue |
||||
was that the original attempt to seek before skipping not just |
||||
failed, but apparently still moved the read pointer in some way |
||||
which skipped over irreplacable input, breaking the next call of |
||||
readHeader. Using [tell] to check seekability does not break in |
||||
this manner. Bumped version to 0.7.1. |
||||
|
||||
2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.14 ======================== |
||||
* |
||||
|
||||
2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.13 ======================== |
||||
* |
||||
|
||||
2011-01-20 Andreas Kupries <andreask@activestate.com> |
||||
|
||||
* tar.tcl: [Bug 3162548]: Applied patch by Alexandre Ferrieux, |
||||
* tar.man: extending various tar commands to be able to use |
||||
* pkgIndex.tcl: the -chan option, and channels instead of files. |
||||
Version bumped to 0.7 |
||||
|
||||
2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.12 ======================== |
||||
* |
||||
|
||||
2009-12-03 Andreas Kupries <andreask@activestate.com> |
||||
|
||||
* tar.man: [Patch 2840147]. Applied. New options -prefix and |
||||
* tar.tcl: -quick for tar::add. -prefix allows specifying a |
||||
* tar.pcx: prefix for filenames in the archive, and -quick 1 |
||||
* pkgIndex.tcl: changes back to the seek-from-end algorithm for |
||||
finding the place where to add the new files. The new default |
||||
scans from start (robust). Bumped version to 0.6. |
||||
|
||||
2009-05-12 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
|
||||
* tar.tcl: add support for reading pre-posix archives. |
||||
if a file isnt writable when extracting, try deleting |
||||
before giving up. |
||||
|
||||
2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.11.1 ======================== |
||||
* |
||||
|
||||
2008-11-26 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
|
||||
* tar.man: add and clarify documentation |
||||
|
||||
2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.11 ======================== |
||||
* |
||||
|
||||
2008-06-14 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* tar.pcx: New file. Syntax definitions for the public commands of |
||||
the tar package. |
||||
|
||||
2007-09-12 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.10 ======================== |
||||
* |
||||
|
||||
2007-03-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* tar.man: Fixed all warnings due to use of now deprecated |
||||
commands. Added a section about how to give feedback. |
||||
|
||||
2007-02-08 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
|
||||
* tar.tcl: bug fix in recursion algorithm that missed |
||||
some files in deep subdirs. incremented version |
||||
|
||||
2007-01-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* tar.tcl: Bumped version to 0.3, for the bugfix described |
||||
* tar.man: by the last entry. |
||||
* pkgIndex.tcl: |
||||
|
||||
2006-12-20 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
|
||||
* tar.tcl: fix in parseOpts which affected -file and -glob |
||||
arguments to tar::untar |
||||
* tar.man: clarifications to add, create, and untar |
||||
|
||||
2006-10-03 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.9 ======================== |
||||
* |
||||
|
||||
2006-29-06 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
|
||||
* tar.tcl: fixed bug in parseOpts |
||||
|
||||
2005-11-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* pkgIndex.tcl: Corrected buggy commit, synchronized version |
||||
* tar.man: numbers across all relevant files. |
||||
|
||||
2005-11-08 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
|
||||
* tar.tcl: bumped version to 0.2 because of new feature |
||||
* tar.man: tar::remove |
||||
|
||||
2005-11-07 Andreas Kupries <andreask@activestate.com> |
||||
|
||||
* tar.man: Fixed error, incorrect placement of [call] markup |
||||
outside of list. |
||||
|
||||
2005-11-04 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
|
||||
* tar.man: added tar::remove command and documentation for it |
||||
* tar.tcl: |
||||
|
||||
2005-10-06 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.8 ======================== |
||||
* |
||||
|
||||
2005-09-30 Andreas Kupries <andreask@activestate.com> |
||||
|
||||
* tar.tcl: qualified all [open] calls with :: to ensure usag of |
||||
the builtin. Apparently mitigates conflict between this package |
||||
and the vfs::tar module. |
||||
|
||||
2004-10-05 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* |
||||
* Released and tagged Tcllib 1.7 ======================== |
||||
* |
||||
|
||||
2004-10-02 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
|
||||
* tar.man: Added keywords and title/module description to the |
||||
documentation. |
||||
|
||||
2004-09-10 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
|
||||
* tar.tcl: Fixed typo bug in ::tar::add |
||||
* tar.man: Added info for ::tar::stat |
||||
|
||||
2004-08-23 Andreas Kupries <andreask@activestate.com> |
||||
|
||||
* tar.man: Fixed problems in the documentation. |
||||
|
||||
@ -0,0 +1,5 @@
|
||||
if {![package vsatisfies [package provide Tcl] 8.5 9]} { |
||||
# PRAGMA: returnok |
||||
return |
||||
} |
||||
package ifneeded tar 0.12 [list source [file join $dir tar.tcl]] |
||||
@ -0,0 +1,202 @@
|
||||
[comment {-*- mode: tcl ; fill-column: 80 -*- doctools manpage}] |
||||
[vset PACKAGE_VERSION 0.12] |
||||
[manpage_begin tar n [vset PACKAGE_VERSION]] |
||||
[keywords archive] |
||||
[keywords {tape archive}] |
||||
[keywords tar] |
||||
[moddesc {Tar file handling}] |
||||
[titledesc {Tar file creation, extraction & manipulation}] |
||||
[category {File formats}] |
||||
[require Tcl "8.5 9"] |
||||
[require tar [opt [vset PACKAGE_VERSION]]] |
||||
[description] |
||||
|
||||
[para] [strong Note]: Starting with version 0.8 the tar reader commands |
||||
(contents, stats, get, untar) support the GNU LongName extension (header type |
||||
'L') for large paths. |
||||
|
||||
[para] |
||||
|
||||
[section BEWARE] |
||||
|
||||
For all commands, when using [option -chan] ... |
||||
|
||||
[list_begin enumerated] |
||||
|
||||
[enum] It is assumed that the channel was opened for reading, and configured for |
||||
binary input. |
||||
|
||||
[enum] It is assumed that the channel position is at the beginning of a legal |
||||
tar file. |
||||
|
||||
[enum] The commands will [emph modify] the channel position as they perform their |
||||
task. |
||||
|
||||
[enum] The commands will [emph not] close the channel. |
||||
|
||||
[enum] In other words, the commands leave the channel in a state very likely |
||||
unsuitable for use by further [cmd tar] commands. Still doing so will |
||||
very likely results in errors, bad data, etc. pp. |
||||
|
||||
[enum] It is the responsibility of the user to seek the channel back to a |
||||
suitable position. |
||||
|
||||
[enum] When using a channel transformation which is not generally seekable, for |
||||
example [cmd gunzip], then it is the responsibility of the user to (a) |
||||
unstack the transformation before seeking the channel back to a suitable |
||||
position, and (b) for restacking it after. |
||||
|
||||
[list_end] |
||||
|
||||
[section COMMANDS] |
||||
|
||||
[list_begin definitions] |
||||
|
||||
[call [cmd ::tar::contents] [arg tarball] [opt [option -chan]]] |
||||
|
||||
Returns a list of the files contained in [arg tarball]. The order is not sorted and depends on the order |
||||
files were stored in the archive. |
||||
[para] |
||||
|
||||
If the option [option -chan] is present [arg tarball] is interpreted as an open channel. |
||||
It is assumed that the channel was opened for reading, and configured for binary input. |
||||
The command will [emph not] close the channel. |
||||
|
||||
[call [cmd ::tar::stat] [arg tarball] [opt file] [opt [option -chan]]] |
||||
|
||||
Returns a nested dict containing information on the named [opt file] in [arg tarball], |
||||
or all files if none is specified. The top level are pairs of filename and info. The info is a dict with the keys |
||||
"[const mode] [const uid] [const gid] [const size] [const mtime] [const type] [const linkname] [const uname] [const gname] |
||||
[const devmajor] [const devminor]" |
||||
|
||||
[example { |
||||
% ::tar::stat tarball.tar |
||||
foo.jpg {mode 0644 uid 1000 gid 0 size 7580 mtime 811903867 type file linkname {} uname user gname wheel devmajor 0 devminor 0} |
||||
}] |
||||
|
||||
[para] |
||||
If the option [option -chan] is present [arg tarball] is interpreted as an open channel. |
||||
It is assumed that the channel was opened for reading, and configured for binary input. |
||||
The command will [emph not] close the channel. |
||||
|
||||
[call [cmd ::tar::untar] [arg tarball] [arg args]] |
||||
|
||||
Extracts [arg tarball]. [arg -file] and [arg -glob] limit the extraction |
||||
to files which exactly match or pattern match the given argument. No error is |
||||
thrown if no files match. Returns a list of filenames extracted and the file |
||||
size. The size will be null for non regular files. Leading path seperators are |
||||
stripped so paths will always be relative. |
||||
|
||||
[list_begin options] |
||||
[opt_def -dir dirName] |
||||
Directory to extract to. Uses [cmd pwd] if none is specified |
||||
[opt_def -file fileName] |
||||
Only extract the file with this name. The name is matched against the complete path |
||||
stored in the archive including directories. |
||||
[opt_def -glob pattern] |
||||
Only extract files patching this glob style pattern. The pattern is matched against the complete path |
||||
stored in the archive. |
||||
[opt_def -nooverwrite] |
||||
Dont overwrite files that already exist |
||||
[opt_def -nomtime] |
||||
Leave the file modification time as the current time instead of setting it to the value in the archive. |
||||
[opt_def -noperms] |
||||
In Unix, leave the file permissions as the current umask instead of setting them to the values in the archive. |
||||
|
||||
[opt_def -chan] |
||||
If this option is present [arg tarball] is interpreted as an open channel. |
||||
It is assumed that the channel was opened for reading, and configured for binary input. |
||||
The command will [emph not] close the channel. |
||||
|
||||
[list_end] |
||||
[para] |
||||
|
||||
[example { |
||||
% foreach {file size} [::tar::untar tarball.tar -glob *.jpg] { |
||||
puts "Extracted $file ($size bytes)" |
||||
} |
||||
}] |
||||
|
||||
[call [cmd ::tar::get] [arg tarball] [arg fileName] [opt [option -chan]]] |
||||
|
||||
Returns the contents of [arg fileName] from the [arg tarball]. |
||||
|
||||
[para][example { |
||||
% set readme [::tar::get tarball.tar doc/README] { |
||||
% puts $readme |
||||
} |
||||
}] |
||||
|
||||
[para] If the option [option -chan] is present [arg tarball] is |
||||
interpreted as an open channel. It is assumed that the channel was |
||||
opened for reading, and configured for binary input. The command will |
||||
[emph not] close the channel. |
||||
|
||||
[para] An error is thrown when [arg fileName] is not found in the tar |
||||
archive. |
||||
|
||||
[call [cmd ::tar::create] [arg tarball] [arg files] [arg args]] |
||||
|
||||
Creates a new tar file containing the [arg files]. [arg files] must be specified |
||||
as a single argument which is a proper list of filenames. |
||||
|
||||
[list_begin options] |
||||
[opt_def -dereference] |
||||
Normally [cmd create] will store links as an actual link pointing at a file that may |
||||
or may not exist in the archive. Specifying this option will cause the actual file point to |
||||
by the link to be stored instead. |
||||
|
||||
[opt_def -chan] |
||||
If this option is present [arg tarball] is interpreted as an open channel. |
||||
It is assumed that the channel was opened for writing, and configured for binary output. |
||||
The command will [emph not] close the channel. |
||||
|
||||
[list_end] |
||||
[para] |
||||
|
||||
[example { |
||||
% ::tar::create new.tar [glob -nocomplain file*] |
||||
% ::tar::contents new.tar |
||||
file1 file2 file3 |
||||
}] |
||||
|
||||
[call [cmd ::tar::add] [arg tarball] [arg files] [arg args]] |
||||
|
||||
Appends [arg files] to the end of the existing [arg tarball]. [arg files] must be specified |
||||
as a single argument which is a proper list of filenames. |
||||
|
||||
[list_begin options] |
||||
[opt_def -dereference] |
||||
Normally [cmd add] will store links as an actual link pointing at a file that may |
||||
or may not exist in the archive. Specifying this option will cause the actual file point to |
||||
by the link to be stored instead. |
||||
[opt_def -prefix string] |
||||
Normally [cmd add] will store files under exactly the name specified as |
||||
argument. Specifying a [opt -prefix] causes the [arg string] to be |
||||
prepended to every name. |
||||
[opt_def -quick] |
||||
The only sure way to find the position in the [arg tarball] where new |
||||
files can be added is to read it from start, but if [arg tarball] was |
||||
written with a "blocksize" of 1 (as this package does) then one can |
||||
alternatively find this position by seeking from the end. The |
||||
[opt -quick] option tells [cmd add] to do the latter. |
||||
[list_end] |
||||
[para] |
||||
|
||||
[call [cmd ::tar::remove] [arg tarball] [arg files]] |
||||
|
||||
Removes [arg files] from the [arg tarball]. No error will result if the file does not exist in the |
||||
tarball. Directory write permission and free disk space equivalent to at least the size of the tarball |
||||
will be needed. |
||||
|
||||
[example { |
||||
% ::tar::remove new.tar {file2 file3} |
||||
% ::tar::contents new.tar |
||||
file3 |
||||
}] |
||||
|
||||
[list_end] |
||||
|
||||
[vset CATEGORY tar] |
||||
[include ../common-text/feedback.inc] |
||||
[manpage_end] |
||||
@ -0,0 +1,83 @@
|
||||
# -*- tcl -*- tar.pcx |
||||
# Syntax of the commands provided by package tar. |
||||
# |
||||
# For use by TclDevKit's static syntax checker (v4.1+). |
||||
# See http://www.activestate.com/solutions/tcl/ |
||||
# See http://aspn.activestate.com/ASPN/docs/Tcl_Dev_Kit/4.0/Checker.html#pcx_api |
||||
# for the specification of the format of the code in this file. |
||||
# |
||||
|
||||
package require pcx |
||||
pcx::register tar |
||||
pcx::tcldep 0.4 needs tcl 8.2 |
||||
pcx::tcldep 0.5 needs tcl 8.2 |
||||
pcx::tcldep 0.6 needs tcl 8.2 |
||||
|
||||
namespace eval ::tar {} |
||||
|
||||
#pcx::message FOO {... text ...} type |
||||
#pcx::scan <VERSION> <NAME> <RULE> |
||||
|
||||
pcx::check 0.4 std ::tar::add \ |
||||
{checkSimpleArgs 2 -1 { |
||||
checkFileName |
||||
{checkListValues 1 -1 checkFileName} |
||||
{checkSwitches 1 { |
||||
{-dereference checkBoolean} |
||||
} {}} |
||||
}} |
||||
pcx::check 0.6 std ::tar::add \ |
||||
{checkSimpleArgs 2 -1 { |
||||
checkFileName |
||||
{checkListValues 1 -1 checkFileName} |
||||
{checkSwitches 1 { |
||||
{-dereference checkBoolean} |
||||
{-quick checkBoolean} |
||||
{-prefix checkWord} |
||||
} {}} |
||||
}} |
||||
pcx::check 0.4 std ::tar::contents \ |
||||
{checkSimpleArgs 1 1 { |
||||
checkFileName |
||||
}} |
||||
pcx::check 0.4 std ::tar::create \ |
||||
{checkSimpleArgs 2 -1 { |
||||
checkFileName |
||||
{checkListValues 1 -1 checkFileName} |
||||
{checkSwitches 1 { |
||||
{-chan checkChannelID} |
||||
{-dereference checkBoolean} |
||||
} {}} |
||||
}} |
||||
pcx::check 0.4 std ::tar::get \ |
||||
{checkSimpleArgs 2 2 { |
||||
checkFileName |
||||
checkFileName |
||||
}} |
||||
pcx::check 0.4 std ::tar::remove \ |
||||
{checkSimpleArgs 2 2 { |
||||
checkFileName |
||||
{checkListValues 1 -1 checkFileName} |
||||
}} |
||||
pcx::check 0.4 std ::tar::stat \ |
||||
{checkSimpleArgs 1 2 { |
||||
checkFileName |
||||
checkFileName |
||||
}} |
||||
pcx::check 0.4 std ::tar::untar \ |
||||
{checkSimpleArgs 1 -1 { |
||||
checkFileName |
||||
{checkSwitches 1 { |
||||
{-chan checkChannelID} |
||||
{-dir checkFileName} |
||||
{-file checkFileName} |
||||
{-glob checkPattern} |
||||
{-nomtime checkBoolean} |
||||
{-nooverwrite checkBoolean} |
||||
{-noperms checkBoolean} |
||||
} {}} |
||||
}} |
||||
|
||||
# Initialization via pcx::init. |
||||
# Use a ::tar::init procedure for non-standard initialization. |
||||
pcx::complete |
||||
@ -0,0 +1,550 @@
|
||||
# tar.tcl -- |
||||
# |
||||
# Creating, extracting, and listing posix tar archives |
||||
# |
||||
# Copyright (c) 2004 Aaron Faupell <afaupell@users.sourceforge.net> |
||||
# Copyright (c) 2013 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
# (GNU tar @LongLink support). |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: tar.tcl,v 1.17 2012/09/11 17:22:24 andreas_kupries Exp $ |
||||
|
||||
package require Tcl 8.5 9 |
||||
package provide tar 0.12 |
||||
|
||||
namespace eval ::tar {} |
||||
|
||||
proc ::tar::parseOpts {acc opts} { |
||||
array set flags $acc |
||||
foreach {x y} $acc {upvar $x $x} |
||||
|
||||
set len [llength $opts] |
||||
set i 0 |
||||
while {$i < $len} { |
||||
set name [string trimleft [lindex $opts $i] -] |
||||
if {![info exists flags($name)]} { |
||||
return -errorcode {TAR INVALID OPTION} \ |
||||
-code error "unknown option \"$name\"" |
||||
} |
||||
if {$flags($name) == 1} { |
||||
set $name [lindex $opts [expr {$i + 1}]] |
||||
incr i $flags($name) |
||||
} elseif {$flags($name) > 1} { |
||||
set $name [lrange $opts [expr {$i + 1}] [expr {$i + $flags($name)}]] |
||||
incr i $flags($name) |
||||
} else { |
||||
set $name 1 |
||||
} |
||||
incr i |
||||
} |
||||
} |
||||
|
||||
proc ::tar::pad {size} { |
||||
set pad [expr {512 - ($size % 512)}] |
||||
if {$pad == 512} {return 0} |
||||
return $pad |
||||
} |
||||
|
||||
proc ::tar::seekorskip {ch off wh} { |
||||
if {[tell $ch] < 0} { |
||||
if {$wh!="current"} { |
||||
return -code error -errorcode [list TAR INVALID WHENCE $wh] \ |
||||
"WHENCE=$wh not supported on non-seekable channel $ch" |
||||
} |
||||
skip $ch $off |
||||
return |
||||
} |
||||
seek $ch $off $wh |
||||
return |
||||
} |
||||
|
||||
proc ::tar::skip {ch skipover} { |
||||
while {$skipover > 0} { |
||||
set requested $skipover |
||||
|
||||
# Limit individual skips to 64K, as a compromise between speed |
||||
# of skipping (Number of read requests), and memory usage |
||||
# (Note how skipped block is read into memory!). While the |
||||
# read data is immediately discarded it still generates memory |
||||
# allocation traffic, gets copied, etc. Trying to skip the |
||||
# block in one go without the limit may cause us to run out of |
||||
# (virtual) memory, or just induce swapping, for nothing. |
||||
|
||||
if {$requested > 65536} { |
||||
set requested 65536 |
||||
} |
||||
|
||||
set skipped [string length [read $ch $requested]] |
||||
|
||||
# Stop in short read into the end of the file. |
||||
if {!$skipped && [eof $ch]} break |
||||
|
||||
# Keep track of how much is (not) skipped yet. |
||||
incr skipover -$skipped |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc ::tar::readHeader {data} { |
||||
binary scan $data a100a8a8a8a12a12a8a1a100a6a2a32a32a8a8a155 \ |
||||
name mode uid gid size mtime cksum type \ |
||||
linkname magic version uname gname devmajor devminor prefix |
||||
|
||||
foreach x {name type linkname} { |
||||
set $x [string trim [set $x] "\x00"] |
||||
} |
||||
foreach x {uid gid size mtime cksum} { |
||||
set $x [format %d 0[string trim [set $x] " \x00"]] |
||||
} |
||||
set mode [string trim $mode " \x00"] |
||||
|
||||
if {$magic == "ustar "} { |
||||
# gnu tar |
||||
# not fully supported |
||||
foreach x {uname gname prefix} { |
||||
set $x [string trim [set $x] "\x00"] |
||||
} |
||||
foreach x {devmajor devminor} { |
||||
set $x [format %d 0[string trim [set $x] " \x00"]] |
||||
} |
||||
} elseif {$magic == "ustar\x00"} { |
||||
# posix tar |
||||
foreach x {uname gname prefix} { |
||||
set $x [string trim [set $x] "\x00"] |
||||
} |
||||
foreach x {devmajor devminor} { |
||||
set $x [format %d 0[string trim [set $x] " \x00"]] |
||||
} |
||||
} else { |
||||
# old style tar |
||||
foreach x {uname gname devmajor devminor prefix} { set $x {} } |
||||
if {$type == ""} { |
||||
if {[string match */ $name]} { |
||||
set type 5 |
||||
} else { |
||||
set type 0 |
||||
} |
||||
} |
||||
} |
||||
|
||||
return [list name $name mode $mode uid $uid gid $gid size $size mtime $mtime \ |
||||
cksum $cksum type $type linkname $linkname magic $magic \ |
||||
version $version uname $uname gname $gname devmajor $devmajor \ |
||||
devminor $devminor prefix $prefix] |
||||
} |
||||
|
||||
proc ::tar::contents {file args} { |
||||
set chan 0 |
||||
parseOpts {chan 0} $args |
||||
if {$chan} { |
||||
set fh $file |
||||
} else { |
||||
set fh [::open $file] |
||||
fconfigure $fh -encoding binary -translation lf -eofchar {} |
||||
} |
||||
set ret {} |
||||
while {![eof $fh]} { |
||||
array set header [readHeader [read $fh 512]] |
||||
HandleLongLink $fh header |
||||
if {$header(name) == ""} break |
||||
if {$header(prefix) != ""} {append header(prefix) /} |
||||
lappend ret $header(prefix)$header(name) |
||||
seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current |
||||
} |
||||
if {!$chan} { |
||||
close $fh |
||||
} |
||||
return $ret |
||||
} |
||||
|
||||
proc ::tar::stat {tar {file {}} args} { |
||||
set chan 0 |
||||
parseOpts {chan 0} $args |
||||
if {$chan} { |
||||
set fh $tar |
||||
} else { |
||||
set fh [::open $tar] |
||||
fconfigure $fh -encoding binary -translation lf -eofchar {} |
||||
} |
||||
set ret {} |
||||
while {![eof $fh]} { |
||||
array set header [readHeader [read $fh 512]] |
||||
HandleLongLink $fh header |
||||
if {$header(name) == ""} break |
||||
if {$header(prefix) != ""} {append header(prefix) /} |
||||
seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current |
||||
if {$file != "" && "$header(prefix)$header(name)" != $file} {continue} |
||||
set header(type) [string map {0 file 5 directory 3 characterSpecial 4 blockSpecial 6 fifo 2 link} $header(type)] |
||||
set header(mode) [string range $header(mode) 2 end] |
||||
lappend ret $header(prefix)$header(name) [list mode $header(mode) uid $header(uid) gid $header(gid) \ |
||||
size $header(size) mtime $header(mtime) type $header(type) linkname $header(linkname) \ |
||||
uname $header(uname) gname $header(gname) devmajor $header(devmajor) devminor $header(devminor)] |
||||
} |
||||
if {!$chan} { |
||||
close $fh |
||||
} |
||||
return $ret |
||||
} |
||||
|
||||
proc ::tar::get {tar file args} { |
||||
set chan 0 |
||||
parseOpts {chan 0} $args |
||||
if {$chan} { |
||||
set fh $tar |
||||
} else { |
||||
set fh [::open $tar] |
||||
fconfigure $fh -encoding binary -translation lf -eofchar {} |
||||
} |
||||
while {![eof $fh]} { |
||||
set data [read $fh 512] |
||||
array set header [readHeader $data] |
||||
HandleLongLink $fh header |
||||
if {$header(name) eq ""} break |
||||
if {$header(prefix) ne ""} {append header(prefix) /} |
||||
set name [string trimleft $header(prefix)$header(name) /] |
||||
if {$name eq $file} { |
||||
set file [read $fh $header(size)] |
||||
if {!$chan} { |
||||
close $fh |
||||
} |
||||
return $file |
||||
} |
||||
seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current |
||||
} |
||||
if {!$chan} { |
||||
close $fh |
||||
} |
||||
return -code error -errorcode {TAR MISSING FILE} \ |
||||
"Tar \"$tar\": File \"$file\" not found" |
||||
} |
||||
|
||||
proc ::tar::untar {tar args} { |
||||
set nooverwrite 0 |
||||
set data 0 |
||||
set nomtime 0 |
||||
set noperms 0 |
||||
set chan 0 |
||||
parseOpts {dir 1 file 1 glob 1 nooverwrite 0 nomtime 0 noperms 0 chan 0} $args |
||||
if {![info exists dir]} {set dir [pwd]} |
||||
set pattern * |
||||
if {[info exists file]} { |
||||
set pattern [string map {* \\* ? \\? \\ \\\\ \[ \\\[ \] \\\]} $file] |
||||
} elseif {[info exists glob]} { |
||||
set pattern $glob |
||||
} |
||||
|
||||
set ret {} |
||||
if {$chan} { |
||||
set fh $tar |
||||
} else { |
||||
set fh [::open $tar] |
||||
fconfigure $fh -encoding binary -translation lf -eofchar {} |
||||
} |
||||
while {![eof $fh]} { |
||||
array set header [readHeader [read $fh 512]] |
||||
HandleLongLink $fh header |
||||
if {$header(name) == ""} break |
||||
if {$header(prefix) != ""} {append header(prefix) /} |
||||
set name [string trimleft $header(prefix)$header(name) /] |
||||
if {![string match $pattern $name] || ($nooverwrite && [file exists $name])} { |
||||
seekorskip $fh [expr {$header(size) + [pad $header(size)]}] current |
||||
continue |
||||
} |
||||
|
||||
set name [file join $dir $name] |
||||
if {![file isdirectory [file dirname $name]]} { |
||||
file mkdir [file dirname $name] |
||||
lappend ret [file dirname $name] {} |
||||
} |
||||
if {[string match {[0346]} $header(type)]} { |
||||
if {[catch {::open $name w+} new]} { |
||||
# sometimes if we dont have write permission we can still delete |
||||
catch {file delete -force $name} |
||||
set new [::open $name w+] |
||||
} |
||||
fconfigure $new -encoding binary -translation lf -eofchar {} |
||||
fcopy $fh $new -size $header(size) |
||||
close $new |
||||
lappend ret $name $header(size) |
||||
} elseif {$header(type) == 5} { |
||||
file mkdir $name |
||||
lappend ret $name {} |
||||
} elseif {[string match {[12]} $header(type)] && $::tcl_platform(platform) == "unix"} { |
||||
catch {file delete $name} |
||||
if {![catch {file link [string map {1 -hard 2 -symbolic} $header(type)] $name $header(linkname)}]} { |
||||
lappend ret $name {} |
||||
} |
||||
} |
||||
seekorskip $fh [pad $header(size)] current |
||||
if {![file exists $name]} continue |
||||
|
||||
if {$::tcl_platform(platform) == "unix"} { |
||||
if {!$noperms} { |
||||
catch {file attributes $name -permissions 0o[string range $header(mode) 2 end]} |
||||
} |
||||
catch {file attributes $name -owner $header(uid) -group $header(gid)} |
||||
catch {file attributes $name -owner $header(uname) -group $header(gname)} |
||||
} |
||||
if {!$nomtime} { |
||||
file mtime $name $header(mtime) |
||||
} |
||||
} |
||||
if {!$chan} { |
||||
close $fh |
||||
} |
||||
return $ret |
||||
} |
||||
|
||||
## |
||||
# ::tar::statFile |
||||
# |
||||
# Returns stat info about a filesystem object, in the form of an info |
||||
# dictionary like that returned by ::tar::readHeader. |
||||
# |
||||
# The mode, uid, gid, mtime, and type entries are always present. |
||||
# The size and linkname entries are present if relevant for this type |
||||
# of object. The uname and gname entries are present if the OS supports |
||||
# them. No devmajor or devminor entry is present. |
||||
## |
||||
|
||||
proc ::tar::statFile {name followlinks} { |
||||
if {$followlinks} { |
||||
file stat $name stat |
||||
} else { |
||||
file lstat $name stat |
||||
} |
||||
|
||||
set ret {} |
||||
|
||||
if {$::tcl_platform(platform) == "unix"} { |
||||
# Tcl 9 returns the permission as 0o octal number. Since this |
||||
# is written to the tar file and the file format expects "00" |
||||
# we have to rewrite. |
||||
lappend ret mode 1[string map {o 0} [file attributes $name -permissions]] |
||||
lappend ret uname [file attributes $name -owner] |
||||
lappend ret gname [file attributes $name -group] |
||||
if {$stat(type) == "link"} { |
||||
lappend ret linkname [file link $name] |
||||
} |
||||
} else { |
||||
lappend ret mode [lindex {100644 100755} [expr {$stat(type) == "directory"}]] |
||||
} |
||||
|
||||
lappend ret uid $stat(uid) gid $stat(gid) mtime $stat(mtime) \ |
||||
type $stat(type) |
||||
|
||||
if {$stat(type) == "file"} {lappend ret size $stat(size)} |
||||
|
||||
return $ret |
||||
} |
||||
|
||||
## |
||||
# ::tar::formatHeader |
||||
# |
||||
# Opposite operation to ::tar::readHeader; takes a file name and info |
||||
# dictionary as arguments, returns a corresponding (POSIX-tar) header. |
||||
# |
||||
# The following dictionary entries must be present: |
||||
# mode |
||||
# type |
||||
# |
||||
# The following dictionary entries are used if present, otherwise |
||||
# the indicated default is used: |
||||
# uid 0 |
||||
# gid 0 |
||||
# size 0 |
||||
# mtime [clock seconds] |
||||
# linkname {} |
||||
# uname {} |
||||
# gname {} |
||||
# |
||||
# All other dictionary entries, including devmajor and devminor, are |
||||
# presently ignored. |
||||
## |
||||
|
||||
proc ::tar::formatHeader {name info} { |
||||
array set A { |
||||
linkname "" |
||||
uname "" |
||||
gname "" |
||||
size 0 |
||||
gid 0 |
||||
uid 0 |
||||
} |
||||
set A(mtime) [clock seconds] |
||||
array set A $info |
||||
array set A {devmajor "" devminor ""} |
||||
|
||||
set type [string map {file 0 directory 5 characterSpecial 3 \ |
||||
blockSpecial 4 fifo 6 link 2 socket A} $A(type)] |
||||
|
||||
set osize [format %o $A(size)] |
||||
set ogid [format %o $A(gid)] |
||||
set ouid [format %o $A(uid)] |
||||
set omtime [format %o $A(mtime)] |
||||
|
||||
set name [string trimleft $name /] |
||||
if {[string length $name] > 255} { |
||||
return -code error -errorcode {TAR BAD PATH LENGTH} \ |
||||
"path name over 255 chars" |
||||
} elseif {[string length $name] > 100} { |
||||
set common [string range $name end-99 154] |
||||
if {[set splitpoint [string first / $common]] == -1} { |
||||
return -code error -errorcode {TAR BAD PATH UNSPLITTABLE} \ |
||||
"path name cannot be split into prefix and name" |
||||
} |
||||
set prefix [string range $name 0 end-100][string range $common 0 $splitpoint-1] |
||||
set name [string range $common $splitpoint+1 end][string range $name 155 end] |
||||
} else { |
||||
set prefix "" |
||||
} |
||||
|
||||
set header [binary format a100A8A8A8A12A12A8a1a100A6a2a32a32a8a8a155a12 \ |
||||
$name $A(mode)\x00 $ouid\x00 $ogid\x00\ |
||||
$osize\x00 $omtime\x00 {} $type \ |
||||
$A(linkname) ustar\x00 00 $A(uname) $A(gname)\ |
||||
$A(devmajor) $A(devminor) $prefix {}] |
||||
|
||||
binary scan $header c* tmp |
||||
set cksum 0 |
||||
foreach x $tmp {incr cksum $x} |
||||
|
||||
return [string replace $header 148 155 [binary format A8 [format %o $cksum]\x00]] |
||||
} |
||||
|
||||
|
||||
proc ::tar::recurseDirs {files followlinks} { |
||||
foreach x $files { |
||||
if {[file isdirectory $x] && ([file type $x] != "link" || $followlinks)} { |
||||
if {[set more [glob -dir $x -nocomplain *]] != ""} { |
||||
eval lappend files [recurseDirs $more $followlinks] |
||||
} else { |
||||
lappend files $x |
||||
} |
||||
} |
||||
} |
||||
return $files |
||||
} |
||||
|
||||
proc ::tar::writefile {in out followlinks name} { |
||||
puts -nonewline $out [formatHeader $name [statFile $in $followlinks]] |
||||
set size 0 |
||||
if {[file type $in] == "file" || ($followlinks && [file type $in] == "link")} { |
||||
set in [::open $in] |
||||
fconfigure $in -encoding binary -translation lf -eofchar {} |
||||
set size [fcopy $in $out] |
||||
close $in |
||||
} |
||||
puts -nonewline $out [string repeat \x00 [pad $size]] |
||||
} |
||||
|
||||
proc ::tar::create {tar files args} { |
||||
set dereference 0 |
||||
set chan 0 |
||||
parseOpts {dereference 0 chan 0} $args |
||||
|
||||
if {$chan} { |
||||
set fh $tar |
||||
} else { |
||||
set fh [::open $tar w+] |
||||
fconfigure $fh -encoding binary -translation lf -eofchar {} |
||||
} |
||||
foreach x [recurseDirs $files $dereference] { |
||||
writefile $x $fh $dereference $x |
||||
} |
||||
puts -nonewline $fh [string repeat \x00 1024] |
||||
|
||||
if {!$chan} { |
||||
close $fh |
||||
} |
||||
return $tar |
||||
} |
||||
|
||||
proc ::tar::add {tar files args} { |
||||
set dereference 0 |
||||
set prefix "" |
||||
set quick 0 |
||||
parseOpts {dereference 0 prefix 1 quick 0} $args |
||||
|
||||
set fh [::open $tar r+] |
||||
fconfigure $fh -encoding binary -translation lf -eofchar {} |
||||
|
||||
if {$quick} then { |
||||
seek $fh -1024 end |
||||
} else { |
||||
set data [read $fh 512] |
||||
while {[regexp {[^\0]} $data]} { |
||||
array set header [readHeader $data] |
||||
seek $fh [expr {$header(size) + [pad $header(size)]}] current |
||||
set data [read $fh 512] |
||||
} |
||||
seek $fh -512 current |
||||
} |
||||
|
||||
foreach x [recurseDirs $files $dereference] { |
||||
writefile $x $fh $dereference $prefix$x |
||||
} |
||||
puts -nonewline $fh [string repeat \x00 1024] |
||||
|
||||
close $fh |
||||
return $tar |
||||
} |
||||
|
||||
proc ::tar::remove {tar files} { |
||||
set n 0 |
||||
while {[file exists $tar$n.tmp]} {incr n} |
||||
set tfh [::open $tar$n.tmp w] |
||||
set fh [::open $tar r] |
||||
|
||||
fconfigure $fh -encoding binary -translation lf -eofchar {} |
||||
fconfigure $tfh -encoding binary -translation lf -eofchar {} |
||||
|
||||
while {![eof $fh]} { |
||||
array set header [readHeader [read $fh 512]] |
||||
if {$header(name) == ""} { |
||||
puts -nonewline $tfh [string repeat \x00 1024] |
||||
break |
||||
} |
||||
if {$header(prefix) != ""} {append header(prefix) /} |
||||
set name $header(prefix)$header(name) |
||||
set len [expr {$header(size) + [pad $header(size)]}] |
||||
if {[lsearch $files $name] > -1} { |
||||
seek $fh $len current |
||||
} else { |
||||
seek $fh -512 current |
||||
fcopy $fh $tfh -size [expr {$len + 512}] |
||||
} |
||||
} |
||||
|
||||
close $fh |
||||
close $tfh |
||||
|
||||
file rename -force $tar$n.tmp $tar |
||||
} |
||||
|
||||
proc ::tar::HandleLongLink {fh hv} { |
||||
upvar 1 $hv header thelongname thelongname |
||||
|
||||
# @LongName Part I. |
||||
if {$header(type) == "L"} { |
||||
# Size == Length of name. Read it, and pad to full 512 |
||||
# size. After that is a regular header for the actual |
||||
# file, where we have to insert the name. This is handled |
||||
# by the next iteration and the part II below. |
||||
set thelongname [string trimright [read $fh $header(size)] \000] |
||||
seekorskip $fh [pad $header(size)] current |
||||
return -code continue |
||||
} |
||||
# Not supported yet: type 'K' for LongLink (long symbolic links). |
||||
|
||||
# @LongName, part II, get data from previous entry, if defined. |
||||
if {[info exists thelongname]} { |
||||
set header(name) $thelongname |
||||
# Prevent leakage to further entries. |
||||
unset thelongname |
||||
} |
||||
|
||||
return |
||||
} |
||||
@ -0,0 +1,139 @@
|
||||
# -*- tcl -*- |
||||
# These tests are in the public domain |
||||
# ------------------------------------------------------------------------- |
||||
|
||||
source [file join \ |
||||
[file dirname [file dirname [file normalize [info script]]]] \ |
||||
devtools testutilities.tcl] |
||||
|
||||
testsNeedTcl 8.5 ; # Virt channel support! |
||||
testsNeedTcltest 1.0 |
||||
|
||||
# Check if we have TclOO available. |
||||
tcltest::testConstraint tcloo [expr {![catch {package require TclOO}]}] |
||||
|
||||
support { |
||||
if {[tcltest::testConstraint tcloo]} { |
||||
use virtchannel_base/memchan.tcl tcl::chan::memchan |
||||
} |
||||
useLocalFile tests/support.tcl |
||||
} |
||||
testing { |
||||
useLocal tar.tcl tar |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
test tar-stream {stream} -constraints tcloo -setup { |
||||
setup1 |
||||
} -body { |
||||
string length [read $chan1] |
||||
} -cleanup { |
||||
cleanup1 |
||||
} -result 128000 |
||||
|
||||
test tar-pad {pad} -body { |
||||
tar::pad 230 |
||||
} -result {282} |
||||
|
||||
test tar-skip {skip} -constraints tcloo -setup { |
||||
setup1 |
||||
} -body { |
||||
tar::skip $chan1 10 |
||||
lappend res [read $chan1 10] |
||||
tar::skip $chan1 72313 |
||||
lappend res [read $chan1 10] |
||||
} -cleanup { |
||||
cleanup1 |
||||
} -result {{6 7 8 9 10} {07 13908 1}} |
||||
|
||||
test tar-seekorskip-backwards {seekorskip} -constraints tcl8.6plus -setup setup1 -body { |
||||
# The zlib push stuff is Tcl 8.6+. Properly restrict the test. |
||||
zlib push gzip $chan1 |
||||
catch {tar::seekorskip $chan1 -10 start} cres |
||||
lappend res $cres |
||||
catch {tar::seekorskip $chan1 10 start} cres |
||||
lappend res $cres |
||||
catch {tar::seekorskip $chan1 -10 end} cres |
||||
lappend res $cres |
||||
catch {tar::seekorskip $chan1 10 end} cres |
||||
lappend res $cres |
||||
lappend res [read $chan1 10] |
||||
} -cleanup cleanup1 -match glob \ |
||||
-result [list \ |
||||
{WHENCE=start not supported*} \ |
||||
{WHENCE=start not supported*} \ |
||||
{WHENCE=end not supported*} \ |
||||
{WHENCE=end not supported*} \ |
||||
{1 2 3 4 5 } \ |
||||
] |
||||
|
||||
test tar-header {header} -body { |
||||
set file1 [dict get $filesys Dir1 File1] |
||||
dict set file1 path /Dir1/File1 |
||||
set header [header_posix $file1] |
||||
set parsed [string trim [tar::readHeader $header]] |
||||
set golden "name /Dir1/File1 mode 755 uid 13103 gid 18103 size 100 mtime 5706756101 cksum 3676 type 0 linkname {} magic ustar\0 version 00 uname {} gname {} devmajor 0 devminor 0 prefix {}" |
||||
set len [string length $parsed] |
||||
foreach {key value} $golden { |
||||
if {[set value1 [dict get $parsed $key]] ne $value } { |
||||
lappend res [list $key $value $value1] |
||||
} |
||||
} |
||||
} -result {} |
||||
|
||||
test tar-add {add} -constraints tcloo -setup { |
||||
setup1 |
||||
} -body { |
||||
tar::create $chan1 [list $tmpdir/one/a $tmpdir/one/two/a $tmpdir/one/three/a] -chan |
||||
seek $chan1 0 |
||||
lappend res {*}[tar::contents $chan1 -chan] |
||||
seek $chan1 0 |
||||
lappend res [string trim [tar::get $chan1 $tmpdir/one/two/a -chan]] |
||||
} -cleanup { |
||||
cleanup1 |
||||
} -result {tartest/one/a tartest/one/two/a tartest/one/three/a hello2} |
||||
|
||||
|
||||
test tar-bug-2840180 {Ticket 2840180} -setup { |
||||
setup2 |
||||
} -body { |
||||
tar::create $chan1 [list $tmpdir/[large-path]/a] -chan |
||||
seek $chan1 0 |
||||
|
||||
# What the package sees. |
||||
lappend res {*}[tar::contents $chan1 -chan] |
||||
close $chan1 |
||||
|
||||
# What a regular tar package sees. |
||||
lappend res [exec 2> $tmpfile.err tar tvf $tmpfile] |
||||
join $res \n |
||||
} -cleanup { |
||||
cleanup2 |
||||
} -match glob -result [join [list \ |
||||
tartest/[large-path]/a \ |
||||
"* tartest/[large-path]/a" \ |
||||
] \n] |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
test tar-tkt-9f4c0e3e95-1.0 {Ticket 9f4c0e3e95, A} -setup { |
||||
set tarfile [setup-tkt-9f4c0e3e95] |
||||
} -body { |
||||
string trim [tar::get $tarfile 02] |
||||
} -cleanup { |
||||
cleanup-tkt-9f4c0e3e95 |
||||
unset tarfile |
||||
} -result {zero-two} |
||||
|
||||
test tar-tkt-9f4c0e3e95-1.1 {Ticket 9f4c0e3e95, B, } -setup { |
||||
set tarfile [setup-tkt-9f4c0e3e95] |
||||
} -body { |
||||
tar::get $tarfile 0b10 |
||||
} -cleanup { |
||||
cleanup-tkt-9f4c0e3e95 |
||||
unset tarfile |
||||
} -returnCodes error -result {Tar "tartest/t.tar": File "0b10" not found} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
testsuiteCleanup |
||||
@ -0,0 +1,149 @@
|
||||
|
||||
proc stream {{size 128000}} { |
||||
set chan [tcl::chan::memchan] |
||||
set line {} |
||||
while 1 { |
||||
incr i |
||||
set istring $i |
||||
set ilen [string length $istring] |
||||
if {$line ne {}} { |
||||
append line { } |
||||
incr size -1 |
||||
} |
||||
append line $istring |
||||
incr size -$ilen |
||||
if {$size < 1} { |
||||
set line [string range $line 0 end-[expr {abs(1-$size)}]] |
||||
puts $chan $line |
||||
break |
||||
} |
||||
|
||||
if {$i % 10 == 0} { |
||||
puts $chan $line |
||||
incr size -1 ;# for the [puts] newline |
||||
set line {} |
||||
} |
||||
} |
||||
|
||||
seek $chan 0 |
||||
return $chan |
||||
} |
||||
|
||||
proc header_posix {tarball} { |
||||
dict with tarball {} |
||||
tar::formatHeader $path \ |
||||
[dict create \ |
||||
mode $mode \ |
||||
type $type \ |
||||
uid $uid \ |
||||
gid $gid \ |
||||
size $size \ |
||||
mtime $mtime] |
||||
} |
||||
|
||||
proc setup1 {} { |
||||
variable chan1 |
||||
variable res {} |
||||
variable tmpdir tartest |
||||
|
||||
tcltest::makeDirectory $tmpdir |
||||
|
||||
foreach directory { |
||||
one |
||||
one/two |
||||
one/three |
||||
} { |
||||
tcltest::makeDirectory $tmpdir/$directory |
||||
set chan [open $tmpdir/$directory/a w] |
||||
puts $chan hello[incr i] |
||||
close $chan |
||||
} |
||||
set chan1 [stream] |
||||
} |
||||
|
||||
proc large-path {} { |
||||
return aaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbaaaaa/bbbbtcllib/modules/tar |
||||
} |
||||
|
||||
proc setup2 {} { |
||||
variable chan1 |
||||
variable res {} |
||||
variable tmpdir tartest |
||||
variable tmpfile tarX |
||||
|
||||
tcltest::makeDirectory $tmpdir |
||||
tcltest::makeFile {} $tmpfile |
||||
|
||||
foreach directory [list [large-path]] { |
||||
tcltest::makeDirectory $tmpdir/$directory |
||||
set chan [open $tmpdir/$directory/a w] |
||||
puts $chan hello[incr i] |
||||
close $chan |
||||
} |
||||
set chan1 [open $tmpfile w+] |
||||
} |
||||
|
||||
proc cleanup1 {} { |
||||
variable chan1 |
||||
close $chan1 |
||||
tcltest::removeDirectory tartest |
||||
return |
||||
} |
||||
|
||||
proc cleanup2 {} { |
||||
variable chan1 |
||||
variable tmpdir |
||||
variable tmpfile |
||||
catch { close $chan1 } |
||||
tcltest::removeDirectory $tmpdir |
||||
tcltest::removeFile $tmpfile |
||||
tcltest::removeFile $tmpfile.err |
||||
return |
||||
} |
||||
|
||||
variable filesys { |
||||
Dir1 { |
||||
File1 { |
||||
type 0 |
||||
mode 755 |
||||
uid 13103 |
||||
gid 18103 |
||||
size 100 |
||||
mtime 5706756101 |
||||
} |
||||
} |
||||
|
||||
Dir2 { |
||||
File1 { |
||||
type 0 |
||||
mode 644 |
||||
uid 15103 |
||||
gid 19103 |
||||
size 100 |
||||
mtime 5706776103 |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc setup-tkt-9f4c0e3e95 {} { |
||||
variable tmpdir tartest |
||||
|
||||
tcltest::makeDirectory $tmpdir |
||||
tcltest::makeFile {zero-two} $tmpdir/02 |
||||
tcltest::makeFile {number two} $tmpdir/2 |
||||
|
||||
set here [pwd] |
||||
cd $tmpdir |
||||
tar::create t.tar {2 02} |
||||
cd $here |
||||
|
||||
return $tmpdir/t.tar |
||||
} |
||||
|
||||
proc cleanup-tkt-9f4c0e3e95 {} { |
||||
variable tmpdir |
||||
tcltest::removeFile $tmpdir/2 |
||||
tcltest::removeFile $tmpdir/02 |
||||
tcltest::removeDirectory $tmpdir |
||||
return |
||||
} |
||||
@ -0,0 +1,56 @@
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Terminal packages - ANSI |
||||
## Generic commands to define commands for code sequences. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
namespace eval ::term::ansi::code {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API. Escape clauses, plain and bracket |
||||
## Used by 'define'd commands. |
||||
|
||||
proc ::term::ansi::code::esc {str} {return \033$str} |
||||
proc ::term::ansi::code::escb {str} {esc \[$str} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API. Define command for named control code, or constant. |
||||
## (Simple definitions without arguments) |
||||
|
||||
proc ::term::ansi::code::define {name escape code} { |
||||
proc [Qualified $name] {} [list ::term::ansi::code::$escape $code] |
||||
} |
||||
|
||||
proc ::term::ansi::code::const {name code} { |
||||
proc [Qualified $name] {} [list return $code] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal helper to construct fully-qualified names. |
||||
|
||||
proc ::term::ansi::code::Qualified {name} { |
||||
if {![string match ::* $name]} { |
||||
# Get the caller's namespace; append :: if it is not the |
||||
# global namespace, for separation from the actual name. |
||||
set ns [uplevel 2 [list namespace current]] |
||||
if {$ns ne "::"} {append ns ::} |
||||
set name $ns$name |
||||
} |
||||
return $name |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
namespace eval ::term::ansi::code { |
||||
namespace export esc escb define const |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide term::ansi::code 0.3 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -0,0 +1,108 @@
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Terminal packages - ANSI - Attribute codes |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
package require term::ansi::code ; # Constants |
||||
|
||||
namespace eval ::term::ansi::code::attr {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API. Symbolic names. |
||||
|
||||
proc ::term::ansi::code::attr::names {} { |
||||
variable attr |
||||
return $attr |
||||
} |
||||
|
||||
proc ::term::ansi::code::attr::import {{ns attr} args} { |
||||
if {![llength $args]} {set args *} |
||||
set args ::term::ansi::code::attr::[join $args " ::term::ansi::code::attr::"] |
||||
uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal - Setup |
||||
|
||||
proc ::term::ansi::code::attr::DEF {name value} { |
||||
variable attr |
||||
const $name $value |
||||
lappend attr $name |
||||
namespace export $name |
||||
return |
||||
} |
||||
|
||||
proc ::term::ansi::code::attr::INIT {} { |
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
# Colors. Foreground <=> Text |
||||
DEF fgblack 30 ; # Black |
||||
DEF fgred 31 ; # Red |
||||
DEF fggreen 32 ; # Green |
||||
DEF fgyellow 33 ; # Yellow |
||||
DEF fgblue 34 ; # Blue |
||||
DEF fgmagenta 35 ; # Magenta |
||||
DEF fgcyan 36 ; # Cyan |
||||
DEF fgwhite 37 ; # White |
||||
DEF fgdefault 39 ; # Default (Black) |
||||
|
||||
# Colors. Background. |
||||
DEF bgblack 40 ; # Black |
||||
DEF bgred 41 ; # Red |
||||
DEF bggreen 42 ; # Green |
||||
DEF bgyellow 43 ; # Yellow |
||||
DEF bgblue 44 ; # Blue |
||||
DEF bgmagenta 45 ; # Magenta |
||||
DEF bgcyan 46 ; # Cyan |
||||
DEF bgwhite 47 ; # White |
||||
DEF bgdefault 49 ; # Default (Transparent) |
||||
|
||||
# Non-color attributes. Activation. |
||||
DEF bold 1 ; # Bold |
||||
DEF dim 2 ; # Dim |
||||
DEF italic 3 ; # Italics |
||||
DEF underline 4 ; # Underscore |
||||
DEF blink 5 ; # Blink |
||||
DEF revers 7 ; # Reverse |
||||
DEF hidden 8 ; # Hidden |
||||
DEF strike 9 ; # StrikeThrough |
||||
|
||||
# Non-color attributes. Deactivation. |
||||
DEF nobold 22 ; # Bold |
||||
DEF nodim __ ; # Dim |
||||
DEF noitalic 23 ; # Italics |
||||
DEF nounderline 24 ; # Underscore |
||||
DEF noblink 25 ; # Blink |
||||
DEF norevers 27 ; # Reverse |
||||
DEF nohidden 28 ; # Hidden |
||||
DEF nostrike 29 ; # StrikeThrough |
||||
|
||||
# Remainder |
||||
DEF reset 0 ; # Reset |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Data structures. |
||||
|
||||
namespace eval ::term::ansi::code::attr { |
||||
namespace import ::term::ansi::code::const |
||||
variable attr {} |
||||
} |
||||
|
||||
::term::ansi::code::attr::INIT |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide term::ansi::code::attr 0.2 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -0,0 +1,272 @@
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Terminal packages - ANSI - Control codes |
||||
|
||||
## References |
||||
# [0] Google: ansi terminal control |
||||
# [1] http://vt100.net/docs/vt100-ug/chapter3.html |
||||
# [2] http://www.termsys.demon.co.uk/vtansi.htm |
||||
# [3] http://rrbrandt.dyndns.org:60000/docs/tut/redes/ansi.php |
||||
# [4] http://www.dee.ufcg.edu.br/~rrbrandt/tools/ansi.html |
||||
# [5] http://www.ecma-international.org/publications/standards/Ecma-048.htm |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
package require term::ansi::code |
||||
package require term::ansi::code::attr |
||||
|
||||
namespace eval ::term::ansi::code::ctrl {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API. Symbolic names. |
||||
|
||||
proc ::term::ansi::code::ctrl::names {} { |
||||
variable ctrl |
||||
return $ctrl |
||||
} |
||||
|
||||
proc ::term::ansi::code::ctrl::import {{ns ctrl} args} { |
||||
if {![llength $args]} {set args *} |
||||
set args ::term::ansi::code::ctrl::[join $args " ::term::ansi::code::ctrl::"] |
||||
uplevel 1 [list namespace eval $ns [linsert $args 0 namespace import]] |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
## TODO = symbolic key codes for skd. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal - Setup |
||||
|
||||
proc ::term::ansi::code::ctrl::DEF {name esc value} { |
||||
variable ctrl |
||||
define $name $esc $value |
||||
lappend ctrl $name |
||||
namespace export $name |
||||
return |
||||
} |
||||
|
||||
proc ::term::ansi::code::ctrl::DEFC {name arguments script} { |
||||
variable ctrl |
||||
proc $name $arguments $script |
||||
lappend ctrl $name |
||||
namespace export $name |
||||
return |
||||
} |
||||
|
||||
proc ::term::ansi::code::ctrl::INIT {} { |
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
# Erasing |
||||
|
||||
DEF eeol escb K ; # Erase (to) End Of Line |
||||
DEF esol escb 1K ; # Erase (to) Start Of Line |
||||
DEF el escb 2K ; # Erase (current) Line |
||||
DEF ed escb J ; # Erase Down (to bottom) |
||||
DEF eu escb 1J ; # Erase Up (to top) |
||||
DEF es escb 2J ; # Erase Screen |
||||
|
||||
# Scrolling |
||||
|
||||
DEF sd esc D ; # Scroll Down |
||||
DEF su esc M ; # Scroll Up |
||||
|
||||
# Cursor Handling |
||||
|
||||
DEF ch escb H ; # Cursor Home |
||||
DEF sc escb s ; # Save Cursor |
||||
DEF rc escb u ; # Restore Cursor (Unsave) |
||||
DEF sca esc 7 ; # Save Cursor + Attributes |
||||
DEF rca esc 8 ; # Restore Cursor + Attributes |
||||
|
||||
# Tabbing |
||||
|
||||
DEF st esc H ; # Set Tab (@ current position) |
||||
DEF ct escb g ; # Clear Tab (@ current position) |
||||
DEF cat escb 3g ; # Clear All Tabs |
||||
|
||||
# Device Introspection |
||||
|
||||
DEF qdc escb c ; # Query Device Code |
||||
DEF qds escb 5n ; # Query Device Status |
||||
DEF qcp escb 6n ; # Query Cursor Position |
||||
DEF rd esc c ; # Reset Device |
||||
|
||||
# Linewrap on/off |
||||
|
||||
DEF elw escb 7h ; # Enable Line Wrap |
||||
DEF dlw escb 7l ; # Disable Line Wrap |
||||
|
||||
# Graphics Mode (aka use alternate font on/off) |
||||
|
||||
DEF eg esc F ; # Enter Graphics Mode |
||||
DEF lg esc G ; # Exit Graphics Mode |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Complex, parameterized codes |
||||
|
||||
# Select Character Set |
||||
# Choose which char set is used for default and |
||||
# alternate font. This does not change whether |
||||
# default or alternate font are used |
||||
|
||||
DEFC scs0 {tag} {esc ($tag} ; # Set default character set |
||||
DEFC scs1 {tag} {esc )$tag} ; # Set alternate character set |
||||
|
||||
# tags in A : United Kingdom Set |
||||
# B : ASCII Set |
||||
# 0 : Special Graphics |
||||
# 1 : Alternate Character ROM Standard Character Set |
||||
# 2 : Alternate Character ROM Special Graphics |
||||
|
||||
# Set Display Attributes |
||||
|
||||
DEFC sda {args} {escb [join $args \;]m} |
||||
|
||||
# Force Cursor Position (aka Go To) |
||||
|
||||
DEFC fcp {r c} {escb ${r}\;${c}f} |
||||
|
||||
# Cursor Up, Down, Forward, Backward |
||||
|
||||
DEFC cu {{n 1}} {escb [expr {$n == 1 ? "A" : "${n}A"}]} |
||||
DEFC cd {{n 1}} {escb [expr {$n == 1 ? "B" : "${n}B"}]} |
||||
DEFC cf {{n 1}} {escb [expr {$n == 1 ? "C" : "${n}C"}]} |
||||
DEFC cb {{n 1}} {escb [expr {$n == 1 ? "D" : "${n}D"}]} |
||||
|
||||
# Scroll Screen (entire display, or between rows start end, inclusive). |
||||
|
||||
DEFC ss {args} { |
||||
if {[llength $args] == 0} {return [escb r]} |
||||
if {[llength $args] == 2} {foreach {s e} $args break ; return [escb ${s};${e}r]} |
||||
return -code error "wrong\#args" |
||||
} |
||||
|
||||
# Set Key Definition |
||||
|
||||
DEFC skd {code str} {escb $code\;\"$str\"p} |
||||
|
||||
# Terminal title |
||||
|
||||
DEFC title {str} {esc \]0\;$str\007} |
||||
|
||||
# Switch to and from character/box graphics. |
||||
|
||||
DEFC gron {} {esc (0} |
||||
DEFC groff {} {esc (B} |
||||
|
||||
# Character graphics, box symbols |
||||
# - 4 corners, 4 t-junctions, |
||||
# one 4-way junction, 2 lines |
||||
|
||||
DEFC tlc {} {return [gron]l[groff]} ; # Top Left Corner |
||||
DEFC trc {} {return [gron]k[groff]} ; # Top Right Corner |
||||
DEFC brc {} {return [gron]j[groff]} ; # Bottom Right Corner |
||||
DEFC blc {} {return [gron]m[groff]} ; # Bottom Left Corner |
||||
|
||||
DEFC ltj {} {return [gron]t[groff]} ; # Left T Junction |
||||
DEFC ttj {} {return [gron]w[groff]} ; # Top T Junction |
||||
DEFC rtj {} {return [gron]u[groff]} ; # Right T Junction |
||||
DEFC btj {} {return [gron]v[groff]} ; # Bottom T Junction |
||||
|
||||
DEFC fwj {} {return [gron]n[groff]} ; # Four-Way Junction |
||||
|
||||
DEFC hl {} {return [gron]q[groff]} ; # Horizontal Line |
||||
DEFC vl {} {return [gron]x[groff]} ; # Vertical Line |
||||
|
||||
# Optimize character graphics. The generator commands above create |
||||
# way to many superfluous commands shifting into and out of the |
||||
# graphics mode. The command below removes all shifts which are |
||||
# not needed. To this end it also knows which characters will look |
||||
# the same in both modes, to handle strings created outside this |
||||
# package. |
||||
|
||||
DEFC groptim {string} { |
||||
variable grforw |
||||
variable grback |
||||
set offon [groff][gron] |
||||
set onoff [gron][groff] |
||||
while {![string equal $string [set new [string map \ |
||||
[list $offon {} $onoff {}] [string map \ |
||||
$grback [string map \ |
||||
$grforw $string]]]]]} { |
||||
set string $new |
||||
} |
||||
return $string |
||||
} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Higher level operations |
||||
|
||||
# Clear screen <=> CursorHome + EraseDown |
||||
# Init (Fonts): Default ASCII, Alternate Graphics |
||||
# Show a block of text at a specific location. |
||||
|
||||
DEFC clear {} {return [ch][ed]} |
||||
DEFC init {} {return [scs0 B][scs1 0]} |
||||
|
||||
DEFC showat {r c text} { |
||||
if {![string length $text]} {return {}} |
||||
return [fcp $r $c][sca][join \ |
||||
[split $text \n] \ |
||||
[rca][cd][sca]][rca][cd] |
||||
} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Attribute control (single attributes) |
||||
|
||||
foreach a [::term::ansi::code::attr::names] { |
||||
DEF sda_$a escb [::term::ansi::code::attr::$a]m |
||||
} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Data structures. |
||||
|
||||
namespace eval ::term::ansi::code::ctrl { |
||||
namespace import ::term::ansi::code::define |
||||
namespace import ::term::ansi::code::esc |
||||
namespace import ::term::ansi::code::escb |
||||
|
||||
variable grforw |
||||
variable grback |
||||
variable _ |
||||
|
||||
foreach _ { |
||||
! \" # $ % & ' ( ) * + , - . / |
||||
0 1 2 3 4 5 6 7 8 9 : ; < = > |
||||
? @ A B C D E F G H I J K L M |
||||
N O P Q R S T U V W X Y Z [ ^ |
||||
\\ ] |
||||
} { |
||||
lappend grforw \016$_ $_\016 |
||||
lappend grback $_\017 \017$_ |
||||
} |
||||
unset _ |
||||
} |
||||
|
||||
::term::ansi::code::ctrl::INIT |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide term::ansi::code::ctrl 0.4 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -0,0 +1,93 @@
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Terminal packages - ANSI - Higher level macros |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
package require textutil::repeat |
||||
package require textutil::tabify |
||||
package require term::ansi::code::ctrl |
||||
|
||||
namespace eval ::term::ansi::code::macros {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API. Symbolic names. |
||||
|
||||
proc ::term::ansi::code::macros::import {{ns macros} args} { |
||||
if {![llength $args]} {set args *} |
||||
set args ::term::ansi::code::macros::[join $args " ::term::ansi::code::macros::"] |
||||
uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Higher level operations |
||||
|
||||
# Format a menu / framed block of text |
||||
|
||||
proc ::term::ansi::code::macros::menu {menu} { |
||||
# Menu = dict (label => char) |
||||
array set _ {} |
||||
set shift 0 |
||||
foreach {label c} $menu { |
||||
if {[string first $c $label] < 0} { |
||||
set shift 1 |
||||
break |
||||
} |
||||
} |
||||
set max 0 |
||||
foreach {label c} $menu { |
||||
set pos [string first $c $label] |
||||
if {$shift || ($pos < 0)} { |
||||
set xlabel "$c $label" |
||||
set pos 0 |
||||
} else { |
||||
set xlabel $label |
||||
} |
||||
set len [string length $xlabel] |
||||
if {$len > $max} {set max $len} |
||||
set _($label) " [string replace $xlabel $pos $pos \ |
||||
[cd::sda_fgred][cd::sda_bold][string index $xlabel $pos][cd::sda_reset]]" |
||||
} |
||||
|
||||
append ms [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]\n |
||||
foreach {l c} $menu {append ms $_($l)\n} |
||||
append ms [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc] |
||||
|
||||
return [cd::groptim $ms] |
||||
} |
||||
|
||||
proc ::term::ansi::code::macros::frame {string} { |
||||
set lines [split [textutil::tabify::untabify2 $string] \n] |
||||
set max 0 |
||||
foreach l $lines { |
||||
if {[set len [string length $l]] > $max} {set max $len} |
||||
} |
||||
append fs [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]\n |
||||
foreach l $lines { |
||||
append fs [cd::vl]${l}[textutil::repeat::strRepeat " " [expr {$max-[string length $l]}]][cd::vl]\n |
||||
} |
||||
append fs [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc] |
||||
return [cd::groptim $fs] |
||||
} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Data structures. |
||||
|
||||
namespace eval ::term::ansi::code::macros { |
||||
term::ansi::code::ctrl::import cd |
||||
|
||||
namespace export menu frame |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide term::ansi::code::macros 0.2 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -0,0 +1,91 @@
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Terminal packages - ANSI - Control operations |
||||
## (Unix specific implementation). |
||||
|
||||
## This was originally taken from page 11820 (Pure Tcl Console Editor) |
||||
## of the Tcler's Wiki, however page 14693 (Reading a single character |
||||
## ...) is the same in a more self-contained manner. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
namespace eval ::term::ansi::ctrl::unix {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Make command easily available |
||||
|
||||
proc ::term::ansi::ctrl::unix::import {{ns ctrl} args} { |
||||
if {![llength $args]} {set args *} |
||||
set args ::term::ansi::ctrl::unix::[join $args " ::term::ansi::ctrl::unix::"] |
||||
uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API |
||||
|
||||
# We use the <@stdin because stty works out what terminal to work with |
||||
# using standard input on some platforms. On others it prefers |
||||
# /dev/tty instead, but putting in the redirection makes the code more |
||||
# portable |
||||
|
||||
proc ::term::ansi::ctrl::unix::raw {} { |
||||
variable stty |
||||
exec $stty raw -echo <@stdin |
||||
return |
||||
} |
||||
|
||||
proc ::term::ansi::ctrl::unix::cooked {} { |
||||
variable stty |
||||
exec $stty -raw echo <@stdin |
||||
return |
||||
} |
||||
|
||||
proc ::term::ansi::ctrl::unix::columns {} { |
||||
variable tput |
||||
return [exec $tput cols <@stdin] |
||||
} |
||||
|
||||
proc ::term::ansi::ctrl::unix::rows {} { |
||||
variable tput |
||||
return [exec $tput lines <@stdin] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Package setup |
||||
|
||||
proc ::term::ansi::ctrl::unix::INIT {} { |
||||
variable tput [auto_execok tput] |
||||
variable stty [auto_execok stty] |
||||
|
||||
if {($stty eq "/usr/ucb/stty") && |
||||
($::tcl_platform(os) eq "SunOS")} { |
||||
set stty /usr/bin/stty |
||||
} |
||||
|
||||
if {($tput eq "") || ($stty eq "")} { |
||||
return -code error \ |
||||
"The external requirements for the \ |
||||
use of this package (tput, stty in \ |
||||
\$PATH) are not met." |
||||
} |
||||
return |
||||
} |
||||
|
||||
namespace eval ::term::ansi::ctrl::unix { |
||||
variable tput {} |
||||
variable stty {} |
||||
|
||||
namespace export columns rows raw cooked |
||||
} |
||||
|
||||
::term::ansi::ctrl::unix::INIT |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide term::ansi::ctrl::unix 0.1.2 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -0,0 +1,92 @@
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Terminal packages - ANSI - Control codes |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
package require Tcl 8.5 9 |
||||
package require term::send |
||||
package require term::ansi::code::ctrl |
||||
|
||||
namespace eval ::term::ansi::send {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Make command easily available |
||||
|
||||
proc ::term::ansi::send::import {{ns send} args} { |
||||
if {![llength $args]} {set args *} |
||||
set args ::term::ansi::send::[join $args " ::term::ansi::send::"] |
||||
uplevel 1 [list namespace eval ${ns} [linsert $args 0 namespace import]] |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internal - Setup. |
||||
|
||||
proc ::term::ansi::send::ChName {n} { |
||||
if {![string match *-* $n]} { |
||||
return ${n}ch |
||||
} |
||||
set nl [split $n -] |
||||
set stem [lindex $nl 0] |
||||
set sfx [join [lrange $nl 1 end] -] |
||||
return ${stem}ch-$sfx |
||||
} |
||||
|
||||
proc ::term::ansi::send::Args {n -> arv achv avv} { |
||||
upvar 1 $arv a $achv ach $avv av |
||||
set code ::term::ansi::code::ctrl::$n |
||||
set a [info args $code] |
||||
set av [expr { |
||||
[llength $a] |
||||
? " \$[join $a { $}]" |
||||
: $a |
||||
}] |
||||
foreach a1 $a[set a {}] { |
||||
if {[info default $code $a1 default]} { |
||||
lappend a [list $a1 $default] |
||||
} else { |
||||
lappend a $a1 |
||||
} |
||||
} |
||||
set ach [linsert $a 0 ch] |
||||
return $code |
||||
} |
||||
|
||||
proc ::term::ansi::send::INIT {} { |
||||
foreach n [::term::ansi::code::ctrl::names] { |
||||
set nch [ChName $n] |
||||
set code [Args $n -> a ach av] |
||||
|
||||
if {[lindex $a end] eq "args"} { |
||||
# An args argument requires more care, and an eval |
||||
set av [lrange $av 0 end-1] |
||||
if {$av ne {}} {set av " $av"} |
||||
set gen "eval \[linsert \$args 0 $code$av\]" |
||||
#8.5: (written for clarity): set gen "$code$av {*}\$args" |
||||
} else { |
||||
set gen $code$av |
||||
} |
||||
|
||||
proc $n $a "wr \[$gen\]" ; namespace export $n |
||||
proc $nch $ach "wrch \$ch \[$gen\]" ; namespace export $nch |
||||
} |
||||
return |
||||
} |
||||
|
||||
namespace eval ::term::ansi::send { |
||||
namespace import ::term::send::wr |
||||
namespace import ::term::send::wrch |
||||
namespace export wr wrch |
||||
} |
||||
|
||||
::term::ansi::send::INIT |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide term::ansi::send 0.3 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -0,0 +1,132 @@
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Terminal packages - string -> action mappings |
||||
## (bind objects). For use with 'receive listen'. |
||||
## In essence a DFA with tree structure. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
package require snit |
||||
package require term::receive |
||||
namespace eval ::term::receive::bind {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
snit::type ::term::receive::bind { |
||||
|
||||
constructor {{dict {}}} { |
||||
foreach {str cmd} $dict {Register $str $cmd} |
||||
return |
||||
} |
||||
|
||||
method map {str cmd} { |
||||
Register $str $cmd |
||||
return |
||||
} |
||||
|
||||
method default {cmd} { |
||||
set default $cmd |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
method listen {{chan stdin}} { |
||||
#parray dfa |
||||
::term::receive::listen $self $chan |
||||
return |
||||
} |
||||
|
||||
method unlisten {{chan stdin}} { |
||||
::term::receive::unlisten $chan |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
variable default {} |
||||
variable state {} |
||||
|
||||
method reset {} { |
||||
set state {} |
||||
return |
||||
} |
||||
|
||||
method next {c} {Next $c ; return} |
||||
method process {str} { |
||||
foreach c [split $str {}] {Next $c} |
||||
return |
||||
} |
||||
|
||||
method eof {} {Eof ; return} |
||||
|
||||
proc Next {c} { |
||||
upvar 1 dfa dfa state state default default |
||||
set key [list $state $c] |
||||
|
||||
#puts -nonewline stderr "('$state' x '$c')" |
||||
|
||||
if {![info exists dfa($key)]} { |
||||
# Unknown sequence. Reset. Restart. |
||||
# Run it through the default action. |
||||
|
||||
if {$default ne ""} { |
||||
uplevel #0 [linsert $default end $state$c] |
||||
} |
||||
|
||||
#puts stderr =\ RESET |
||||
set state {} |
||||
} else { |
||||
foreach {what detail} $dfa($key) break |
||||
#puts -nonewline stderr "= $what '$detail'" |
||||
if {$what eq "t"} { |
||||
# Incomplete sequence. Next state. |
||||
set state $detail |
||||
#puts stderr " goto ('$state')" |
||||
} elseif {$what eq "a"} { |
||||
# Action, then reset. |
||||
set state {} |
||||
#puts stderr " run ($detail)" |
||||
uplevel #0 [linsert $detail end $state$c] |
||||
} else { |
||||
return -code error \ |
||||
"Internal error. Bad DFA." |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc Eof {} {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
proc Register {str cmd} { |
||||
upvar 1 dfa dfa |
||||
set prefix {} |
||||
set last {{} {}} |
||||
foreach c [split $str {}] { |
||||
set key [list $prefix $c] |
||||
set next $prefix$c |
||||
set dfa($key) [list t $next] |
||||
set last $key |
||||
set prefix $next |
||||
} |
||||
set dfa($last) [list a $cmd] |
||||
} |
||||
variable dfa -array {} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide term::receive::bind 0.2 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -0,0 +1,202 @@
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Terminal packages - string -> action mappings |
||||
## (menu objects). For use with 'receive listen'. |
||||
## In essence a DFA with tree structure. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
package require snit |
||||
package require textutil::repeat |
||||
package require textutil::tabify |
||||
package require term::ansi::send |
||||
package require term::receive::bind |
||||
package require term::ansi::code::ctrl |
||||
|
||||
namespace eval ::term::receive::menu {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
snit::type ::term::interact::menu { |
||||
|
||||
option -in -default stdin |
||||
option -out -default stdout |
||||
option -column -default 0 |
||||
option -line -default 0 |
||||
option -height -default 25 |
||||
option -actions -default {} |
||||
option -hilitleft -default 0 |
||||
option -hilitright -default end |
||||
option -framed -default 0 -readonly 1 |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
constructor {dict args} { |
||||
$self configurelist $args |
||||
Save $dict |
||||
|
||||
install bind using ::term::receive::bind \ |
||||
${selfns}::bind $options(-actions) |
||||
|
||||
$bind map [cd::cu] [mymethod Up] |
||||
$bind map [cd::cd] [mymethod Down] |
||||
$bind map \n [mymethod Select] |
||||
#$bind default [mymethod DEF] |
||||
|
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
method interact {} { |
||||
Show |
||||
$bind listen $options(-in) |
||||
vwait [myvar done] |
||||
$bind unlisten $options(-in) |
||||
return $map($done) |
||||
} |
||||
|
||||
method done {} {set done $at ; return} |
||||
method clear {} {Clear ; return} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
component bind |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
variable map -array {} |
||||
variable header |
||||
variable labels |
||||
variable footer |
||||
variable empty |
||||
|
||||
proc Save {dict} { |
||||
upvar 1 header header labels labels footer footer |
||||
upvar 1 empty empty at at map map top top |
||||
upvar 1 options(-height) height |
||||
|
||||
set max 0 |
||||
foreach {l code} $dict { |
||||
if {[set len [string length $l]] > $max} {set max $len} |
||||
} |
||||
|
||||
set header [cd::groptim [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]] |
||||
set footer [cd::groptim [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc]] |
||||
|
||||
set labels {} |
||||
set at 0 |
||||
foreach {l code} $dict { |
||||
set map($at) $code |
||||
lappend labels ${l}[textutil::repeat::strRepeat " " [expr {$max-[string length $l]}]] |
||||
incr at |
||||
} |
||||
|
||||
set h $height |
||||
if {$h > [llength $labels]} {set h [llength $labels]} |
||||
|
||||
set eline " [textutil::repeat::strRepeat { } $max]" |
||||
set empty $eline |
||||
for {set i 0} {$i <= $h} {incr i} { |
||||
append empty \n$eline |
||||
} |
||||
|
||||
set at 0 |
||||
set top 0 |
||||
return |
||||
} |
||||
|
||||
variable top 0 |
||||
variable at 0 |
||||
variable done . |
||||
|
||||
proc Show {} { |
||||
upvar 1 header header labels labels footer footer at at |
||||
upvar 1 options(-in) in options(-column) col top top |
||||
upvar 1 options(-out) out options(-line) row |
||||
upvar 1 options(-height) height options(-framed) framed |
||||
upvar 1 options(-hilitleft) left |
||||
upvar 1 options(-hilitright) right |
||||
|
||||
set bot [expr {$top + $height - 1}] |
||||
set fr [expr {$framed ? [cd::vl] : { }}] |
||||
|
||||
set text $header\n |
||||
set i $top |
||||
foreach l [lrange $labels $top $bot] { |
||||
append text $fr |
||||
if {$i != $at} { |
||||
append text $l |
||||
} else { |
||||
append text [string replace $l $left $right \ |
||||
[cd::sda_revers][string range $l $left $right][cd::sda_reset]] |
||||
} |
||||
append text $fr \n |
||||
incr i |
||||
} |
||||
append text $footer |
||||
|
||||
vt::wrch $out [cd::showat $row $col $text] |
||||
return |
||||
} |
||||
|
||||
proc Clear {} { |
||||
upvar 1 empty empty options(-column) col |
||||
upvar 1 options(-out) out options(-line) row |
||||
|
||||
vt::wrch $out [cd::showat $row $col $empty] |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
method Up {str} { |
||||
if {$at == 0} return |
||||
incr at -1 |
||||
if {$at < $top} {incr top -1} |
||||
Show |
||||
return |
||||
} |
||||
|
||||
method Down {str} { |
||||
upvar 0 options(-height) height |
||||
if {$at == ([llength $labels]-1)} return |
||||
incr at |
||||
set bot [expr {$top + $height - 1}] |
||||
if {$at > $bot} {incr top} |
||||
Show |
||||
return |
||||
} |
||||
|
||||
method Select {str} { |
||||
$self done |
||||
return |
||||
} |
||||
|
||||
method DEF {str} { |
||||
puts stderr "($str)" |
||||
exit |
||||
} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::term::interact::menu { |
||||
term::ansi::code::ctrl::import cd |
||||
term::ansi::send::import vt |
||||
} |
||||
|
||||
package provide term::interact::menu 0.2 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -0,0 +1,206 @@
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Terminal packages - string -> action mappings |
||||
## (pager objects). For use with 'receive listen'. |
||||
## In essence a DFA with tree structure. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
package require snit |
||||
package require textutil::repeat |
||||
package require textutil::tabify |
||||
package require term::ansi::send |
||||
package require term::receive::bind |
||||
package require term::ansi::code::ctrl |
||||
|
||||
namespace eval ::term::receive::pager {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
|
||||
snit::type ::term::interact::pager { |
||||
|
||||
option -in -default stdin |
||||
option -out -default stdout |
||||
option -column -default 0 |
||||
option -line -default 0 |
||||
option -height -default 25 |
||||
option -actions -default {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
constructor {str args} { |
||||
$self configurelist $args |
||||
Save $str |
||||
|
||||
install bind using ::term::receive::bind \ |
||||
${selfns}::bind $options(-actions) |
||||
|
||||
$bind map [cd::cu] [mymethod Up] |
||||
$bind map [cd::cd] [mymethod Down] |
||||
$bind map \033\[5~ [mymethod PageUp] |
||||
$bind map \033\[6~ [mymethod PageDown] |
||||
$bind map \n [mymethod Done] |
||||
#$bind default [mymethod DEF] |
||||
|
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
method interact {} { |
||||
Show |
||||
$bind listen $options(-in) |
||||
set interacting 1 |
||||
vwait [myvar done] |
||||
set interacting 0 |
||||
$bind unlisten $options(-in) |
||||
return |
||||
} |
||||
|
||||
method done {} {set done . ; return} |
||||
method clear {} {Clear ; return} |
||||
|
||||
method text {str} { |
||||
if {$interacting} {Clear} |
||||
Save $str |
||||
if {$interacting} {Show} |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
component bind |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
variable header |
||||
variable text |
||||
variable footer |
||||
variable empty |
||||
|
||||
proc Save {str} { |
||||
upvar 1 header header text text footer footer maxline maxline |
||||
upvar 1 options(-height) height empty empty at at |
||||
|
||||
set lines [split [textutil::tabify::untabify2 $str] \n] |
||||
|
||||
set max 0 |
||||
foreach l $lines { |
||||
if {[set len [string length $l]] > $max} {set max $len} |
||||
} |
||||
|
||||
set header [cd::groptim [cd::tlc][textutil::repeat::strRepeat [cd::hl] $max][cd::trc]] |
||||
set footer [cd::groptim [cd::blc][textutil::repeat::strRepeat [cd::hl] $max][cd::brc]] |
||||
|
||||
set text {} |
||||
foreach l $lines { |
||||
lappend text [cd::vl]${l}[textutil::repeat::strRepeat " " [expr {$max-[string length $l]}]][cd::vl] |
||||
} |
||||
|
||||
set h $height |
||||
if {$h > [llength $text]} {set h [llength $text]} |
||||
|
||||
set eline " [textutil::repeat::strRepeat { } $max]" |
||||
set empty $eline |
||||
for {set i 0} {$i <= $h} {incr i} { |
||||
append empty \n$eline |
||||
} |
||||
|
||||
set maxline [expr {[llength $text] - $height}] |
||||
if {$maxline < 0} {set maxline 0} |
||||
set at 0 |
||||
return |
||||
} |
||||
|
||||
variable interacting 0 |
||||
variable at 0 |
||||
variable maxline -1 |
||||
variable done . |
||||
|
||||
proc Show {} { |
||||
upvar 1 header header text text footer footer at at |
||||
upvar 1 options(-in) in options(-column) col |
||||
upvar 1 options(-out) out options(-line) row |
||||
upvar 1 options(-height) height |
||||
|
||||
set to [expr {$at + $height -1}] |
||||
|
||||
vt::wrch $out [cd::showat $row $col \ |
||||
$header\n[join [lrange $text $at $to] \n]\n$footer] |
||||
return |
||||
} |
||||
|
||||
proc Clear {} { |
||||
upvar 1 empty empty options(-column) col |
||||
upvar 1 options(-out) out options(-line) row |
||||
|
||||
vt::wrch $out [cd::showat $row $col $empty] |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
method Up {str} { |
||||
if {$at == 0} return |
||||
incr at -1 |
||||
Show |
||||
return |
||||
} |
||||
|
||||
method Down {str} { |
||||
if {$at >= $maxline} return |
||||
incr at |
||||
Show |
||||
return |
||||
} |
||||
|
||||
method PageUp {str} { |
||||
set newat [expr {$at - $options(-height) + 1}] |
||||
if {$newat < 0} {set newat 0} |
||||
if {$newat == $at} return |
||||
set at $newat |
||||
Show |
||||
return |
||||
} |
||||
|
||||
method PageDown {str} { |
||||
set newat [expr {$at + $options(-height) - 1}] |
||||
if {$newat >= $maxline} {set newat $maxline} |
||||
if {$newat == $at} return |
||||
set at $newat |
||||
Show |
||||
return |
||||
} |
||||
|
||||
method Done {str} { |
||||
$self done |
||||
return |
||||
} |
||||
|
||||
method DEF {str} { |
||||
puts stderr "($str)" |
||||
exit |
||||
} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::term::interact::pager { |
||||
term::ansi::code::ctrl::import cd |
||||
term::ansi::send::import vt |
||||
} |
||||
|
||||
package provide term::interact::pager 0.2 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -0,0 +1,13 @@
|
||||
if {![package vsatisfies [package provide Tcl] 8.5 9]} return |
||||
package ifneeded term 0.2 [list source [file join $dir term.tcl]] |
||||
package ifneeded term::ansi::code 0.3 [list source [file join $dir ansi/code.tcl]] |
||||
package ifneeded term::ansi::code::attr 0.2 [list source [file join $dir ansi/code/attr.tcl]] |
||||
package ifneeded term::ansi::code::ctrl 0.4 [list source [file join $dir ansi/code/ctrl.tcl]] |
||||
package ifneeded term::ansi::code::macros 0.2 [list source [file join $dir ansi/code/macros.tcl]] |
||||
package ifneeded term::ansi::ctrl::unix 0.1.2 [list source [file join $dir ansi/ctrlunix.tcl]] |
||||
package ifneeded term::ansi::send 0.3 [list source [file join $dir ansi/send.tcl]] |
||||
package ifneeded term::interact::menu 0.2 [list source [file join $dir imenu.tcl]] |
||||
package ifneeded term::interact::pager 0.2 [list source [file join $dir ipager.tcl]] |
||||
package ifneeded term::receive 0.2 [list source [file join $dir receive.tcl]] |
||||
package ifneeded term::receive::bind 0.2 [list source [file join $dir bind.tcl]] |
||||
package ifneeded term::send 0.2 [list source [file join $dir send.tcl]] |
||||
@ -0,0 +1,60 @@
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Terminal packages - Generic receiver operations |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
namespace eval ::term::receive {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API. Read character from specific channel, |
||||
## or default (stdin). Processing of |
||||
## character sequences. |
||||
|
||||
proc ::term::receive::getch {{chan stdin}} { |
||||
return [read $chan 1] |
||||
} |
||||
|
||||
proc ::term::receive::listen {cmd {chan stdin}} { |
||||
fconfigure $chan -blocking 0 |
||||
fileevent $chan readable \ |
||||
[list ::term::receive::Foreach $chan $cmd] |
||||
return |
||||
} |
||||
|
||||
proc ::term::receive::unlisten {{chan stdin}} { |
||||
fileevent $chan readable {} |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Internals |
||||
|
||||
proc ::term::receive::Foreach {chan cmd} { |
||||
set string [read $chan] |
||||
if {[string length $string]} { |
||||
#puts stderr "F($string)" |
||||
uplevel #0 [linsert $cmd end process $string] |
||||
} |
||||
if {[eof $chan]} { |
||||
close $chan |
||||
uplevel #0 [linsert $cmd end eof] |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization |
||||
|
||||
namespace eval ::term::receive { |
||||
namespace export getch listen |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide term::receive 0.2 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -0,0 +1,34 @@
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Terminal packages - Generic sender operations |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
namespace eval ::term::send {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API. Write to channel, or default (stdout) |
||||
|
||||
proc ::term::send::wr {str} { |
||||
wrch stdout $str |
||||
return |
||||
} |
||||
|
||||
proc ::term::send::wrch {ch str} { |
||||
puts -nonewline $ch $str |
||||
flush $ch |
||||
return |
||||
} |
||||
|
||||
namespace eval ::term::send { |
||||
namespace export wr wrch |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide term::send 0.2 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -0,0 +1,19 @@
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Terminal packages - Main :: Generic operations |
||||
|
||||
# Currently we have no generica at all. We make the package, but it |
||||
# provides nothing for now. |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
namespace eval ::term {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide term 0.2 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -0,0 +1,24 @@
|
||||
This is primarily for tcl .tm modules required for your bootstrapping/make/build process. |
||||
It could include other files necessary for this process. |
||||
|
||||
The .tm modules here may be required for your build script if it intended the installation operator uses an existing tclsh or other shell as opposed to a tclkit you may have for distribution which is more likely to include necessary libraries. |
||||
|
||||
The modules here are loaded by your initialisation scripts and so can be a snapshot of different versions than those in your project src. |
||||
The modules can be your own, or 3rd party such as individual items from tcllib. |
||||
|
||||
You can copy modules from a running punk shell to this location using the dev command. |
||||
|
||||
e.g |
||||
dev lib.copyasmodule some::module::lib bootsupport |
||||
|
||||
The dev command will help you pick the latest version, and will create any necessary file structure matching the namespace of the package. |
||||
|
||||
e.g the result might be a file such as |
||||
<projectname>/src/bootsupport/some/module/lib-0.1.tm |
||||
|
||||
The originating library may not yet be in .tm form. |
||||
You can copy a pkgIndex.tcl based library that is composed of a single .tcl file the same way using the above process and it will automatically name and file it appropriately but you need to check that the library doesn't require/load additional files - and that it is Tcl script only. |
||||
|
||||
Always verify that the library is copyable in this manner and test in a shell with tcl::tm::path pointed to ./bootsupport that it works. |
||||
|
||||
|
||||
@ -0,0 +1,366 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application dictn 0.1.2 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval dictn { |
||||
namespace export {[a-z]*} |
||||
namespace ensemble create |
||||
} |
||||
|
||||
|
||||
## ::dictn::append |
||||
#This can of course 'ruin' a nested dict if applied to the wrong element |
||||
# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: |
||||
# %set list {a b {c d}} |
||||
# %append list x |
||||
# a b {c d}x |
||||
# IOW - don't do that unless you really know that's what you want. |
||||
# |
||||
proc ::dictn::append {dictvar path {value {}}} { |
||||
if {[llength $path] == 1} { |
||||
uplevel 1 [list dict append $dictvar $path $value] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
|
||||
::set str [dict get $dvar {*}$path] |
||||
append str $val |
||||
dict set dvar {*}$path $str |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::create {args} { |
||||
::set data {} |
||||
foreach {path val} $args { |
||||
dict set data {*}$path $val |
||||
} |
||||
return $data |
||||
} |
||||
|
||||
proc ::dictn::exists {dictval path} { |
||||
return [dict exists $dictval {*}$path] |
||||
} |
||||
|
||||
proc ::dictn::filter {dictval path filterType args} { |
||||
::set sub [dict get $dictval {*}$path] |
||||
dict filter $sub $filterType {*}$args |
||||
} |
||||
|
||||
proc ::dictn::for {keyvalvars dictval path body} { |
||||
::set sub [dict get $dictval {*}$path] |
||||
dict for $keyvalvars $sub $body |
||||
} |
||||
|
||||
proc ::dictn::get {dictval {path {}}} { |
||||
return [dict get $dictval {*}$path] |
||||
} |
||||
|
||||
|
||||
if {[info commands ::tcl::dict::getdef] ne ""} { |
||||
#tcl 9+ |
||||
proc ::dictn::getdef {dictval path default} { |
||||
return [dict getdef $dictval {*}$path $default] |
||||
} |
||||
|
||||
proc ::dictn::getwithdefault {dictval path default} { |
||||
return [dict getdef $dictval {*}$path $default] |
||||
} |
||||
|
||||
proc ::dictn::incr {dictvar path {increment {}} } { |
||||
if {$increment eq ""} { |
||||
::set increment 1 |
||||
} |
||||
if {[llength $path] == 1} { |
||||
uplevel 1 [list dict incr $dictvar $path $increment] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
if {![::info exists dvar]} { |
||||
dict set dvar {*}$path $increment |
||||
} else { |
||||
::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}] |
||||
dict set dvar {*}$path $newval |
||||
} |
||||
return $dvar |
||||
} |
||||
} |
||||
} else { |
||||
#tcl < 9 |
||||
proc ::dictn::getdef {dictval path default} { |
||||
if {[tcl::dict::exists $dictval {*}$path]} { |
||||
return [tcl::dict::get $dictval {*}$path] |
||||
} else { |
||||
return $default |
||||
} |
||||
} |
||||
proc ::dictn::getwithdefault {dictval path default} { |
||||
if {[tcl::dict::exists $dictval {*}$path]} { |
||||
return [tcl::dict::get $dictval {*}$path] |
||||
} else { |
||||
return $default |
||||
} |
||||
} |
||||
proc ::dictn::incr {dictvar path {increment {}} } { |
||||
if {$increment eq ""} { |
||||
::set increment 1 |
||||
} |
||||
if {[llength $path] == 1} { |
||||
uplevel 1 [list dict incr $dictvar $path $increment] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
if {![::info exists dvar]} { |
||||
dict set dvar {*}$path $increment |
||||
} else { |
||||
if {![dict exists $dvar {*}$path]} { |
||||
::set val 0 |
||||
} else { |
||||
::set val [dict get $dvar {*}$path] |
||||
} |
||||
::set newval [expr {$val + $increment}] |
||||
dict set dvar {*}$path $newval |
||||
} |
||||
return $dvar |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::info {dictval {path {}}} { |
||||
if {![string length $path]} { |
||||
return [dict info $dictval] |
||||
} else { |
||||
::set sub [dict get $dictval {*}$path] |
||||
return [dict info $sub] |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::keys {dictval {path {}} {glob {}}} { |
||||
::set sub [dict get $dictval {*}$path] |
||||
if {[string length $glob]} { |
||||
return [dict keys $sub $glob] |
||||
} else { |
||||
return [dict keys $sub] |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::lappend {dictvar path args} { |
||||
if {[llength $path] == 1} { |
||||
uplevel 1 [list dict lappend $dictvar $path {*}$args] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
|
||||
::set list [dict get $dvar {*}$path] |
||||
::lappend list {*}$args |
||||
dict set dvar {*}$path $list |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::merge {args} { |
||||
error "nested merge not yet supported" |
||||
} |
||||
|
||||
#dictn remove dictionaryValue ?path ...? |
||||
proc ::dictn::remove {dictval args} { |
||||
::set basic [list] ;#buffer basic (1element path) removals to do in a single call. |
||||
|
||||
foreach path $args { |
||||
if {[llength $path] == 1} { |
||||
::lappend basic $path |
||||
} else { |
||||
#extract,modify,replace |
||||
::set subpath [lrange $path 0 end-1] |
||||
|
||||
::set sub [dict get $dictval {*}$subpath] |
||||
::set sub [dict remove $sub [lindex $path end]] |
||||
|
||||
dict set dictval {*}$subpath $sub |
||||
} |
||||
} |
||||
|
||||
if {[llength $basic]} { |
||||
return [dict remove $dictval {*}$basic] |
||||
} else { |
||||
return $dictval |
||||
} |
||||
} |
||||
|
||||
|
||||
proc ::dictn::replace {dictval args} { |
||||
::set basic [list] ;#buffer basic (1element path) replacements to do in a single call. |
||||
|
||||
foreach {path val} $args { |
||||
if {[llength $path] == 1} { |
||||
::lappend basic $path $val |
||||
} else { |
||||
#extract,modify,replace |
||||
::set subpath [lrange $path 0 end-1] |
||||
|
||||
::set sub [dict get $dictval {*}$subpath] |
||||
::set sub [dict replace $sub [lindex $path end] $val] |
||||
|
||||
dict set dictval {*}$subpath $sub |
||||
} |
||||
} |
||||
|
||||
|
||||
if {[llength $basic]} { |
||||
return [dict replace $dictval {*}$basic] |
||||
} else { |
||||
return $dictval |
||||
} |
||||
} |
||||
|
||||
|
||||
proc ::dictn::set {dictvar path newval} { |
||||
upvar 1 $dictvar dvar |
||||
return [dict set dvar {*}$path $newval] |
||||
} |
||||
|
||||
proc ::dictn::size {dictval {path {}}} { |
||||
return [dict size [dict get $dictval {*}$path]] |
||||
} |
||||
|
||||
proc ::dictn::unset {dictvar path} { |
||||
upvar 1 $dictvar dvar |
||||
return [dict unset dvar {*}$path |
||||
} |
||||
|
||||
proc ::dictn::update {dictvar args} { |
||||
::set body [lindex $args end] |
||||
::set maplist [lrange $args 0 end-1] |
||||
|
||||
upvar 1 $dictvar dvar |
||||
foreach {path var} $maplist { |
||||
if {[dict exists $dvar {*}$path]} { |
||||
uplevel 1 [list set $var [dict get $dvar $path]] |
||||
} |
||||
} |
||||
|
||||
catch {uplevel 1 $body} result |
||||
|
||||
foreach {path var} $maplist { |
||||
if {[dict exists $dvar {*}$path]} { |
||||
upvar 1 $var $var |
||||
if {![::info exists $var]} { |
||||
uplevel 1 [list dict unset $dictvar {*}$path] |
||||
} else { |
||||
uplevel 1 [list dict set $dictvar {*}$path [::set $var]] |
||||
} |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
#an experiment. |
||||
proc ::dictn::Applyupdate {dictvar args} { |
||||
::set body [lindex $args end] |
||||
::set maplist [lrange $args 0 end-1] |
||||
|
||||
upvar 1 $dictvar dvar |
||||
|
||||
::set headscript "" |
||||
::set i 0 |
||||
foreach {path var} $maplist { |
||||
if {[dict exists $dvar {*}$path]} { |
||||
#uplevel 1 [list set $var [dict get $dvar $path]] |
||||
::lappend arglist $var |
||||
::lappend vallist [dict get $dvar {*}$path] |
||||
::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ] |
||||
::append headscript \n |
||||
::incr i |
||||
} |
||||
} |
||||
|
||||
::set body $headscript\r\n$body |
||||
|
||||
puts stderr "BODY: $body" |
||||
|
||||
#set result [apply [list args $body] {*}$vallist] |
||||
catch {apply [list args $body] {*}$vallist} result |
||||
|
||||
foreach {path var} $maplist { |
||||
if {[dict exists $dvar {*}$path] && [::info exists $var]} { |
||||
dict set dvar {*}$path [::set $var] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
proc ::dictn::values {dictval {path {}} {glob {}}} { |
||||
::set sub [dict get $dictval {*}$path] |
||||
if {[string length $glob]} { |
||||
return [dict values $sub $glob] |
||||
} else { |
||||
return [dict values $sub] |
||||
} |
||||
} |
||||
|
||||
# Standard form: |
||||
#'dictn with dictVariable path body' |
||||
# |
||||
# Extended form: |
||||
#'dictn with dictVariable path arrayVariable body' |
||||
# |
||||
proc ::dictn::with {dictvar path args} { |
||||
if {[llength $args] == 1} { |
||||
::set body [lindex $args 0] |
||||
return [uplevel 1 [list dict with $dictvar {*}$path $body]] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
::lassign $args arrayname body |
||||
|
||||
upvar 1 $arrayname arr |
||||
array set arr [dict get $dvar {*}$path] |
||||
::set prevkeys [array names arr] |
||||
|
||||
catch {uplevel 1 $body} result |
||||
|
||||
|
||||
foreach k $prevkeys { |
||||
if {![::info exists arr($k)]} { |
||||
dict unset $dvar {*}$path $k |
||||
} |
||||
} |
||||
foreach k [array names arr] { |
||||
dict set $dvar {*}$path $k $arr($k) |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide dictn [namespace eval dictn { |
||||
variable version |
||||
::set version 0.1.2 |
||||
}] |
||||
return |
||||
@ -0,0 +1,195 @@
|
||||
#JMN - api should be kept in sync with package patternlib where possible |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
namespace eval oolib { |
||||
oo::class create collection { |
||||
variable o_data ;#dict |
||||
variable o_alias |
||||
constructor {} { |
||||
set o_data [dict create] |
||||
} |
||||
method info {} { |
||||
return [dict info $o_data] |
||||
} |
||||
method count {} { |
||||
return [dict size $o_data] |
||||
} |
||||
method isEmpty {} { |
||||
expr {[dict size $o_data] == 0} |
||||
} |
||||
method names {{globOrIdx {}}} { |
||||
if {[llength $globOrIdx]} { |
||||
if {[string is integer -strict $globOrIdx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||
error "[self object] no such index : '$idx'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} else { |
||||
#glob |
||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||
} |
||||
} else { |
||||
return [dict keys $o_data] |
||||
} |
||||
} |
||||
#like names but without globbing |
||||
method keys {} { |
||||
dict keys $o_data |
||||
} |
||||
method key {{posn 0}} { |
||||
if {$posn < 0} { |
||||
set posn "end-[expr {abs($posn + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||
error "[self object] no such index : '$posn'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} |
||||
method hasKey {key} { |
||||
dict exists $o_data $key |
||||
} |
||||
method get {} { |
||||
return $o_data |
||||
} |
||||
method items {} { |
||||
return [dict values $o_data] |
||||
} |
||||
method item {key} { |
||||
if {[string is integer -strict $key]} { |
||||
if {$key > 0} { |
||||
set valposn [expr {(2*$key) +1}] |
||||
return [lindex $o_data $valposn] |
||||
} else { |
||||
set key "end-[expr {abs($key + 1)}]" |
||||
return [lindex [dict keys $o_data] $key] |
||||
} |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
return [dict get $o_data $key] |
||||
} |
||||
} |
||||
#inverse lookup |
||||
method itemKeys {value} { |
||||
set value_indices [lsearch -all [dict values $o_data] $value] |
||||
set keylist [list] |
||||
foreach i $value_indices { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
method search {value args} { |
||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||
if {"-inline" in $args} { |
||||
return $matches |
||||
} else { |
||||
set keylist [list] |
||||
foreach i $matches { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
} |
||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||
method alias {newAlias existingKeyOrAlias} { |
||||
if {[string is integer -strict $newAlias]} { |
||||
error "[self object] collection key alias cannot be integer" |
||||
} |
||||
if {[string length $existingKeyOrAlias]} { |
||||
set o_alias($newAlias) $existingKeyOrAlias |
||||
} else { |
||||
unset o_alias($newAlias) |
||||
} |
||||
} |
||||
method aliases {{key ""}} { |
||||
if {[string length $key]} { |
||||
set result [list] |
||||
foreach {n v} [array get o_alias] { |
||||
if {$v eq $key} { |
||||
lappend result $n $v |
||||
} |
||||
} |
||||
return $result |
||||
} else { |
||||
return [array get o_alias] |
||||
} |
||||
} |
||||
#if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||
method realKey {idx} { |
||||
if {[catch {set o_alias($idx)} key]} { |
||||
return $idx |
||||
} else { |
||||
return $key |
||||
} |
||||
} |
||||
method add {value key} { |
||||
if {[string is integer -strict $key]} { |
||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||
} |
||||
dict set o_data $key $value |
||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||
} |
||||
method remove {idx {endRange ""}} { |
||||
if {[string length $endRange]} { |
||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||
} |
||||
if {[string is integer -strict $idx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx+1)}]" |
||||
} |
||||
set key [lindex [dict keys $o_data] $idx] |
||||
set posn $idx |
||||
} else { |
||||
set key $idx |
||||
set posn [lsearch -exact [dict keys $o_data] $key] |
||||
if {$posn < 0} { |
||||
error "[self object] no such index: '$idx' in this collection" |
||||
} |
||||
} |
||||
dict unset o_data $key |
||||
return |
||||
} |
||||
method clear {} { |
||||
set o_data [dict create] |
||||
return |
||||
} |
||||
method reverse {} { |
||||
set dictnew [dict create] |
||||
foreach k [lreverse [dict keys $o_data]] { |
||||
dict set dictnew $k [dict get $o_data $k] |
||||
} |
||||
set o_data $dictnew |
||||
return |
||||
} |
||||
#review - cmd as list vs cmd as script? |
||||
method map {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||
} |
||||
return $seed |
||||
} |
||||
method objectmap {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||
} |
||||
return $seed |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue