76 changed files with 31160 additions and 484 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.2 |
||||
|
||||
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.3 |
||||
} |
||||
@ -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.2]} {return} |
||||
package ifneeded control 0.1.3 [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,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 |
||||
|
||||
# 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.1 |
||||
return |
||||
@ -0,0 +1,178 @@
|
||||
# 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.4 |
||||
|
||||
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 {![package vsatisfies [package provide Tcl] 8.4]} {return 0} |
||||
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.3 |
||||
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.3 |
||||
package require Tcl 8.2 |
||||
|
||||
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); |
||||
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); |
||||
} |
||||
Tcl_AppendToObj (fqn, name, -1); |
||||
} else { |
||||
fqn = Tcl_NewStringObj (name, -1); |
||||
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); |
||||
Tcl_AppendObjToObj (err, fqn); |
||||
Tcl_AppendToObj (err, "\" already exists, unable to create graph", -1); |
||||
|
||||
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); |
||||
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_CreateObjCommand (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.4 |
||||
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 |
||||
return |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,29 @@
|
||||
if {![package vsatisfies [package provide Tcl] 8.2]} {return} |
||||
package ifneeded struct 2.1 [list source [file join $dir struct.tcl]] |
||||
package ifneeded struct 1.4 [list source [file join $dir struct1.tcl]] |
||||
|
||||
package ifneeded struct::queue 1.4.5 [list source [file join $dir queue.tcl]] |
||||
package ifneeded struct::stack 1.5.3 [list source [file join $dir stack.tcl]] |
||||
package ifneeded struct::tree 2.1.2 [list source [file join $dir tree.tcl]] |
||||
package ifneeded struct::pool 1.2.3 [list source [file join $dir pool.tcl]] |
||||
package ifneeded struct::record 1.2.2 [list source [file join $dir record.tcl]] |
||||
package ifneeded struct::set 2.2.3 [list source [file join $dir sets.tcl]] |
||||
package ifneeded struct::prioqueue 1.4 [list source [file join $dir prioqueue.tcl]] |
||||
package ifneeded struct::skiplist 1.3 [list source [file join $dir skiplist.tcl]] |
||||
|
||||
package ifneeded struct::graph 1.2.1 [list source [file join $dir graph1.tcl]] |
||||
package ifneeded struct::tree 1.2.2 [list source [file join $dir tree1.tcl]] |
||||
|
||||
if {![package vsatisfies [package provide Tcl] 8.4]} {return} |
||||
package ifneeded struct::list 1.8.5 [list source [file join $dir list.tcl]] |
||||
package ifneeded struct::list::test 1.8.4 [list source [file join $dir list.test.tcl]] |
||||
package ifneeded struct::graph 2.4.3 [list source [file join $dir graph.tcl]] |
||||
package ifneeded struct::map 1 [list source [file join $dir map.tcl]] |
||||
|
||||
if {![package vsatisfies [package provide Tcl] 8.5]} {return} |
||||
|
||||
package ifneeded struct::matrix 2.1 [list source [file join $dir matrix.tcl]] |
||||
|
||||
if {![package vsatisfies [package provide Tcl] 8.6]} {return} |
||||
package ifneeded struct::disjointset 1.1 [list source [file join $dir disjointset.tcl]] |
||||
package ifneeded struct::graph::op 0.11.3 [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]} { |
||||
# 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.3 |
||||
@ -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.2 |
||||
|
||||
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.4 |
||||
@ -0,0 +1,187 @@
|
||||
# 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.4 |
||||
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 {![package vsatisfies [package provide Tcl] 8.4]} {return 0} |
||||
if {[catch {package require tcllibc}]} {return 0} |
||||
set r [llength [info commands ::struct::queue_critcl]] |
||||
} |
||||
tcl { |
||||
variable selfdir |
||||
if { |
||||
[package vsatisfies [package provide Tcl] 8.5] && |
||||
![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.5 |
||||
@ -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.4 |
||||
|
||||
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); |
||||
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); |
||||
} |
||||
Tcl_AppendToObj (fqn, name, -1); |
||||
} else { |
||||
fqn = Tcl_NewStringObj (name, -1); |
||||
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); |
||||
Tcl_AppendObjToObj (err, fqn); |
||||
Tcl_AppendToObj (err, "\" already exists, unable to create queue", -1); |
||||
|
||||
Tcl_DecrRefCount (fqn); |
||||
Tcl_SetObjResult (interp, err); |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
qd = qu_new(); |
||||
qd->cmd = Tcl_CreateObjCommand (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 |
||||
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]} { |
||||
# 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,189 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# 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.2 |
||||
|
||||
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 { |
||||
# Critcl implementation of set requires Tcl 8.4. |
||||
if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} |
||||
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.3 |
||||
@ -0,0 +1,93 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# 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. |
||||
# |
||||
# RCS: @(#) $Id: sets_c.tcl,v 1.3 2008/03/25 07:15:34 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
package require critcl |
||||
# @sak notprovided struct_setc |
||||
package provide struct_setc 2.1.1 |
||||
package require Tcl 8.4 |
||||
|
||||
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 ...?"); |
||||
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.0 |
||||
|
||||
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.3 |
||||
@ -0,0 +1,187 @@
|
||||
# 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.4 |
||||
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 {![package vsatisfies [package provide Tcl] 8.4]} {return 0} |
||||
if {[catch {package require tcllibc}]} {return 0} |
||||
set r [llength [info commands ::struct::stack_critcl]] |
||||
} |
||||
tcl { |
||||
variable selfdir |
||||
if { |
||||
[package vsatisfies [package provide Tcl] 8.5] && |
||||
![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.3 |
||||
@ -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.4 |
||||
|
||||
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); |
||||
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); |
||||
} |
||||
Tcl_AppendToObj (fqn, name, -1); |
||||
} else { |
||||
fqn = Tcl_NewStringObj (name, -1); |
||||
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); |
||||
Tcl_AppendObjToObj (err, fqn); |
||||
Tcl_AppendToObj (err, "\" already exists, unable to create stack", -1); |
||||
|
||||
Tcl_DecrRefCount (fqn); |
||||
Tcl_SetObjResult (interp, err); |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
sd = st_new(); |
||||
sd->cmd = Tcl_CreateObjCommand (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 |
||||
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]} { |
||||
# 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]} { |
||||
|
||||
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.2 |
||||
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.3 |
||||
|
||||
namespace eval ::struct { |
||||
namespace export * |
||||
} |
||||
|
||||
package provide struct 2.1 |
||||
@ -0,0 +1,17 @@
|
||||
package require Tcl 8.2 |
||||
package require struct::graph 1.2.1 |
||||
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.3 |
||||
|
||||
namespace eval ::struct { |
||||
namespace export * |
||||
} |
||||
|
||||
package provide struct 1.4 |
||||
@ -0,0 +1,183 @@
|
||||
# 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.2 |
||||
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 {![package vsatisfies [package provide Tcl] 8.4]} {return 0} |
||||
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.2 |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,208 @@
|
||||
# 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. |
||||
# |
||||
# RCS: @(#) $Id: tree_c.tcl,v 1.6 2008/03/25 07:15:34 andreas_kupries Exp $ |
||||
|
||||
package require critcl |
||||
# @sak notprovided struct_treec |
||||
package provide struct_treec 2.1.1 |
||||
package require Tcl 8.2 |
||||
|
||||
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); |
||||
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); |
||||
} |
||||
Tcl_AppendToObj (fqn, name, -1); |
||||
} else { |
||||
fqn = Tcl_NewStringObj (name, -1); |
||||
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); |
||||
Tcl_AppendObjToObj (err, fqn); |
||||
Tcl_AppendToObj (err, "\" already exists, unable to create tree", -1); |
||||
|
||||
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); |
||||
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_CreateObjCommand (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,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.2 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -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.1 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -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.3 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -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.1 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -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.1 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -0,0 +1,92 @@
|
||||
# -*- tcl -*- |
||||
# ### ### ### ######### ######### ######### |
||||
## Terminal packages - ANSI - Control codes |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
package require Tcl 8.4 |
||||
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.2 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -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.1 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -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.1 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -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.1 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -0,0 +1,13 @@
|
||||
if {![package vsatisfies [package provide Tcl] 8.4]} return |
||||
package ifneeded term 0.1 [list source [file join $dir term.tcl]] |
||||
package ifneeded term::ansi::code 0.2 [list source [file join $dir ansi/code.tcl]] |
||||
package ifneeded term::ansi::code::attr 0.1 [list source [file join $dir ansi/code/attr.tcl]] |
||||
package ifneeded term::ansi::code::ctrl 0.3 [list source [file join $dir ansi/code/ctrl.tcl]] |
||||
package ifneeded term::ansi::code::macros 0.1 [list source [file join $dir ansi/code/macros.tcl]] |
||||
package ifneeded term::ansi::ctrl::unix 0.1.1 [list source [file join $dir ansi/ctrlunix.tcl]] |
||||
package ifneeded term::ansi::send 0.2 [list source [file join $dir ansi/send.tcl]] |
||||
package ifneeded term::interact::menu 0.1 [list source [file join $dir imenu.tcl]] |
||||
package ifneeded term::interact::pager 0.1 [list source [file join $dir ipager.tcl]] |
||||
package ifneeded term::receive 0.1 [list source [file join $dir receive.tcl]] |
||||
package ifneeded term::receive::bind 0.1 [list source [file join $dir bind.tcl]] |
||||
package ifneeded term::send 0.1 [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.1 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -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.1 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -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.1 |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
@ -1,3 +1,3 @@
|
||||
0.1.0 |
||||
0.1.1 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
|
||||
@ -1,3 +1,3 @@
|
||||
0.1.0 |
||||
0.1.1 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
|
||||
Loading…
Reference in new issue