#tarpack-enum-1.5.2/ 777 0 0 0 10470055117 7124 5#tarpack-enum-1.5.2/#tarpack-loadscript-enum.tcl 777 0 0 122524 10470055117 14555 0 #START-tarpack-loadscript-header---------------------------------------------------------------------------- #START-header-comments #If there is anything other than whitespace above this header, then this is a tarpack. # * Do not edit the code whilst in 'packed' form * # #If there is no data above the header, it is an unpacked fragment of a tarpack and may be edited. #Make sure however that your editor preserves the trailing comment (#) as the final character. # i.e - no trailing newline or carriage-return. # # A tarpack is a valid tar archive in which the first archived file consists of tcl script # containing a leading newline and a trailing comment (#) character. # The comment character hides the tar-header for the next file from Tcl. # This first file in the tarball must be named with the prefix #tarpack-loadscript # # The next file is named #z and contains a final ctrl-z to tell Tcl it has reached the end of scripts # (and thus to stop interpreting). # The #z file is separate from the initial script file because some editors may not be able to handle the # ctrl-z character. # The tarball should have all its contents within a single directory named #tarpack-- # - This allows you to safely untar any package 'in place' # - If a package on your 'tcl module path' is unwrapped (i.e untarred) - then the unwrapped files # are the ones that will be loaded by the interpreter. # # This header (excluding this comment block) and the call to tarpack::disconnect are needed to: # a) allow 'package require' to redirect to the unwrapped version of the tarpack # b) enable sourcing & loading of other files contained in the tarpack #END-header-comments set TEMP_auto_path $::auto_path; set ::auto_path [list] if {![catch {package require tarpack}]} { #Do not wrap 'tarpack::connect' in its own 'catch'! #for unwrapped execution, tarpack::connect may need to abort the 'source' operation using returneval. set ::auto_path $TEMP_auto_path; unset TEMP_auto_path ::tarpack::connect [info script] } else { set ::auto_path $TEMP_auto_path; unset TEMP_auto_path } ##example 'package provide' statement. #package provide enum [namespace eval enum { # variable version # set version [lindex [split [file rootname [info script]] -] end] #}] # #END-tarpack-loadscript-header------------------------------------------------------------------------------ #START-tarpack-loadscript-tidy------------------------------------------------------------------------------ # if {![catch {package require tarpack}]} { ::tarpack::disconnect [info script] } # #END-tarpack-loadscript-tidy-------------------------------------------------------------------------------- #This tarpack initially generated using tarpack::wrap enum-1.2.tcl #-------------------------script + tarpack footer follow------------------------- #http://mini.net/tcl/1308 # original code by KBK & DKF - modified, packaged & namespace ensembled by JMN 2005 # JMN - Released under same License as Tcl (assumed appropriate as KBK & DKF both TCT members) # #Changes: #2006-08-14 - 1.5.2 bugfix - error in bin2i - didn't account for signed bytes returned from scan! #2006-08-13 - bugfix - allow typename to contain full range of characters. #2006-08-12 - binary & bitmask features & fixes. v1.5 #2006-08-08 - v1.4 - basic bitmask support #2006-08 - v 1.3, 1.3.1 - bugfixes, + comparison operators. #2006-08 -release v1.2 added 'next','vnext' & 'prev','vprev' methods. #docs # When thinking about 'next' vs 'vnext' and 'prev' vs 'vprev' # - remember that the most natural purpose of enum to return the opposite type of key to that supplied. # - e.g 'enum months jan' returns 0 while 'enum months 0' returns jan # - therefore it is the 'unusually' named functions vprev & vnext that violate this and return the same # - type of key as that which was given. # - Note that it is usually not particularly useful to use vnext & vprev with a numeric key, as it could simply # - be done with expr, except that using these functions will raise an error when the *result* of a call would be outside of an enum's range. package provide enum [namespace eval enum { set commands {create destroy types values dist diff next prev vnext vprev num number nam name bits bin hex} namespace export {expand}$commands namespace ensemble create variable version set version 1.5.2 }] proc ::enum::types {} { set list [namespace export] foreach c $::enum::commands { set posn [lsearch $list $c] set list [lreplace $list $posn $posn] } return $list } #NOTE! 'shimmering' between a large bignum and it's string rep can be very slow! #pow for bignums - derived from: http://mini.net/tcl/4709 proc ::enum::pow2 {n r} { # #Take care of the trivial cases first (they also stop the recursion) # if {$r == 0} { return 1 } elseif {$r == 1} { return $n } elseif {($r % 2) == 0} { set nn [pow2 $n [expr {$r / 2}]] return [expr {$nn * $nn}] } else { set nn [pow2 $n [expr {$r - 1}]] return [expr {$n * $nn}] } } proc ::enum::pow {n r} { expr {$r & 1 ? $n * [pow $n [expr {$r-1}]] : $r ? [set nn [pow $n [expr {$r >> 1}]]] * $nn : 1} } #!todo - when called with 1 arg (type) - return a definition suitable for another 'create'? # ##### #enum::create # #side effects: create set of commands & vars for new enumerated type $type. # - 3 vars, consisting of 2 ordered lists 'ordered_keys_$type' & 'ordered_nums_$type' # plus an array '$type_to_number' that links keys to positions in the ordered lists. # proc ::enum::create {type identifiers args} { if {[lsearch $::enum::commands $type] >= 0} { error "cannot create enumerated type for keyword '$type'" } dict set defaults -base 0 dict set defaults -explicit {} dict set defaults -bitmask 0 dict set defaults -step 1 dict set defaults -reverse 0 if {[llength $args]} { if {([llength $args] % 2) != 0} { error "usage: enum create ?-optionname optionvalue? ?...?" } foreach key [dict keys $args] { if {$key ni [dict keys $defaults]} { error "option '$key' not understood. Understood options: [dict keys $defaults]" } } } set params [dict merge $defaults $args] if {[dict get $params -bitmask] && [dict exists $args -step]} { error "-step option is incompatible with -bitmask option" } upvar #0 ::enum::${type}_to_number hash_to_num #obliterate any previous enum for this type catch {unset hash_to_num} catch {unset ::enum::ordered_keys_$type} if {[dict get $params -reverse]} { set res [list] set i [llength $identifiers] while {$i} { lappend res [lindex $identifiers [incr i -1]] } set identifiers $res } set n [dict get $params -base] set step [dict get $params -step] set contiguous 1 if {abs($step) != 1} { set contiguous 0 } set bm [dict get $params -bitmask] if {$bm} { set contiguous 0 if {[dict exists $args -base]} { set n [dict get $args -base] #!todo - review, test! #do we need ceil()? - surely n must be a power of 2? #set bitbase [expr {int( log($n) / log(2) )}] set bitbase [expr {int(ceil( log($n) / log(2) ))}] } else { set n 1 set bitbase 0 } } set base $n #puts "---->0" set posn 0 if {![llength [dict get $params -explicit]]} { if {$bm} { foreach id $identifiers { #set localarray($id) $n #as n rises.. powers of 2 quickly become expensive to store! (slow + use lots of mem) #set n [expr {$n << 2}] set hash_to_num($id) $posn incr posn } } else { foreach id $identifiers { set hash_to_num($id) $n incr n $step incr posn } } #puts "--->1" set ::enum::ordered_keys_$type $identifiers } else { set explicit [lsort -integer -index 1 [dict get $params -explicit]] set ::enum::ordered_keys_$type [list] foreach id $identifiers { set idDone 0 while {[set matchposn [lsearch -index 1 $explicit $n]] >=0} { # #*insert* items from our -explicit list if their numeric value matches where we're up to. # set match [lindex $explicit $matchposn] lappend ::enum::ordered_keys_$type [lindex $match 0] if {$bm} { set hash_to_num([lindex $match 0]) $posn #set n [enum::pow 2 [expr {$posn + $bitbase + 1}]] set n [expr {$n << 2}] } else { set hash_to_num([lindex $match 0]) $n incr n $step } incr posn ;#because it's an insert. set explicit [lreplace $explicit $matchposn $matchposn] if {$id eq [lindex $match 0]} { set idDone 1 } } if {$idDone} { continue } if {[set matchposn [lsearch -index 0 $explicit $id]] >= 0} { # #This item name matches one in -explicit list, so use the explicitly supplied number. # set match [lindex $explicit $matchposn] if {[lindex $match 1] != $n} { #!todo - raise error if bitmask and n not a power of 2 if {$n == $base} { set bitbase [expr {int( log10([lindex $match 1]) / log10(2) )}] #puts "here.. reset bitbase to: $bitbase" #could still be contiguous... base is just offset. } else { set contiguous 0 } set n [lindex $match 1] } set explicit [lreplace $explicit $matchposn $matchposn] } lappend ::enum::ordered_keys_$type $id if {$bm} { set hash_to_num($id) $posn #set n [enum::pow 2 [expr {$posn + $bitbase + 1}]] set n [expr {$n << 2}] } else { set hash_to_num($id) $n incr n $step } incr posn } #now process any items remaining in the -explicit list. set nprev $n foreach spec $explicit { #order? lassign $spec id n lappend ::enum::ordered_keys_$type $id if {$bm} { set hash_to_num($id) $posn #!todo - test for contiguity as applies to bitmasks (2^^(power +-1) => contiguous?) } else { set hash_to_num($id) $n if {($n - $nprev) != $step} { set contiguous 0 } } set nprev $n incr posn } } if {$contiguous} { set max [expr {[llength [set ::enum::ordered_keys_$type]] + $base - 1}] proc ::enum::nam_$type {key args} [string map [list @base@ $base @type@ [list $type] @ids@ [list [set ::enum::ordered_keys_$type]] @max@ $max] { set list @ids@ if {[catch { if {$key < @base@ || $key > @max@ } { error {out of range} } #!must use expr here! - lindex does not handle arithmetic on values larger than ints! lindex $list [expr {$key - @base@}] } val]} { error "@type@ has no name for '$key - try 'enum num @type@ $key' or another key" } return $val }] proc ::enum::vprev_$type {key} [string map [list @type@ [list $type] @base@ $base @max@ $max] { #use expr to test key so that we don't cause expensive shimmer to string (could be bignum) if {[catch {expr {$key + 0}}]} { #expr couldn't handle it.. so presumably it's a name. if {[catch { set idx [set ::enum::@type@_to_number($key)] ::enum::nam_@type@ [expr {$idx - 1}] } val]} { return -code error "no prev @type@ for '$key'" } return $val } else { #int-key if {$key <= @base@ || $key > @max@ } { return -code error "no prev @type@ for '$key'" } else { return [expr {$key - 1}] } } }] proc ::enum::prev_$type {key} [string map [list @type@ [list $type] @base@ $base @max@ $max ] { if {[catch {expr {$key + 0}}]} { set key [set ::enum::@type@_to_number($key)] if {[catch { if {$key <= @base@ || $key > @max@ } { error {out of range} } expr {$key - 1} } val]} { return -code error "no prev @type@ for '$key'" } return $val } else { return [::enum::nam_@type@ [expr {$key - 1}]] } }] proc ::enum::vnext_$type {key} [string map [list @type@ [list $type] @base@ $base @max@ $max] { if {[catch {expr {$key + 0}}]} { set key [set ::enum::@type@_to_number($key)] if {[catch { if {$key < (@base@ - 1) || $key >= @max@ } { error {out of range} } expr {$key + 1} } val]} { return -code error "no next @type@ for '$key'" } return [::enum::nam_@type@ $val] } else { if {$key < -1 || $key >= @max@ } { return -code error "no next @type@ for '$key'" } else { return [expr {$key + 1}] } } }] proc ::enum::next_$type {key} [string map [list @type@ [list $type] @base@ $base @max@ $max ] { if {[catch {expr {$key + 0}}]} { set key [set ::enum::@type@_to_number($key)] if {[catch { if {$key < (@base@ - 1) || $key >= @max@ } { error {out of range} } expr {$key + 1} } val]} { return -code error "no next @type@ for '$key'" } return $val } else { return [::enum::nam_@type@ [expr {$key + 1}]] } }] } else { #puts "--->2" #this handles all non-contiguous situations as if they involved bignums with the associated expensive string shimmering. #also the positional 'map' means we don't have to do log operations on bitmasks to workout prev & next keys. # (e.g expr {log10($key)/log10(2)} .. which doesn't seem to work on bignums. #for non-contiguous numbers, use ordered_nums_@type@ to correlate with ::enum::ordered_keys_@type@ #do not use any string operations. # also can't use things such as 'lsearch -integer -exact' as it doesn't (as of Tcl8.5 2006-08 anwyay) # handle bignums. #build a set of nums *in same order* as ordered_keys_$type upvar #0 ::enum::ordered_nums_$type nums if {$bm} { #for bitmasks, we start with a zeroed list and add values only when calculated during retrievals set nums [lrepeat [llength [set ::enum::ordered_keys_$type]] 0] } else { #for non-bitmasks - we immediately store the numbers. set nums [list] foreach name [set ::enum::ordered_keys_$type] { #lappend ::enum::ordered_nums_$type [set ::enum::${type}_to_number($name)] lappend nums [set hash_to_num($name)] } } #bitmask-specific codeblock. set bmcode "" if {$bm} { set bmcode [string map [list @bitbase@ $bitbase] { if {$midval == 0} { # set midval [::enum::pow 2 $mid] ;#bitbase? set midval [::enum::pow 2 [expr {$mid + @bitbase@}]] lset nums $mid $midval } }] } proc ::enum::nam_$type {key args} [string map [list @type@ [list $type] @bmcode@ $bmcode ] { if {[catch { set posn -1 #can't use lsearch. Need to do numeric comparison on bignums without shimmer to string. upvar #0 ::enum::ordered_nums_@type@ nums #binary search set left 0 set right [expr {[llength $nums] - 1}] while {$left <= $right} { set mid [expr {wide(floor(($right - $left)/2)) + $left}] set midval [lindex $nums $mid] @bmcode@ if {$key > $midval} { set left [expr {$mid + 1}] } elseif {$key < $midval} { set right [expr {$mid - 1}] } else { set posn $mid break } } if {$posn < 0} { error {out of range} } lindex ${::enum::ordered_keys_@type@} $posn } val]} { error "@type@ has no name for key - try 'enum num @type@ ' or another key" } return $val }] proc ::enum::vprev_$type {key} [string map [list @type@ [list $type] @bmcode@ $bmcode @bm@ $bm @bitbase@ $bitbase] { upvar #0 ::enum::ordered_nums_@type@ nums if {[catch {expr {$key + 0}}]} { if {[catch { set idx [set ::enum::@type@_to_number($key)] ;#use idx so we can report $key in err. if {@bm@} { #our idx is already a position.. if {$idx <= 0} { error "out of range" } lindex ${::enum::ordered_keys_@type@} [expr {$idx - 1}] } else { #idx represents a value... must search to get position. set posn -1 #binary search set left 0 set right [expr {[llength $nums] - 1}] while {$left <= $right} { set mid [expr {wide(floor(($right - $left)/2)) + $left}] set midval [lindex $nums $mid] if {$idx > $midval} { set left [expr {$mid + 1}] } elseif {$idx < $midval} { set right [expr {$mid - 1}] } else { set posn $mid break } } if {$posn <= 0} { error "out of range '$posn'" } lindex ${::enum::ordered_keys_@type@} [expr {$posn -1}] } } val]} { return -code error "no prev @type@ for '$key' err: $val" } return $val } else { #int-key # #for bitmasks we could theoretically calc posn using log($key)/log(2).. # but can we do it quickly for bignums?? !todo - review. set posn -1 #binary search set left 0 set right [expr {[llength $nums] - 1}] while {$left <= $right} { set mid [expr {wide(floor(($right - $left)/2)) + $left}] set midval [lindex $nums $mid] @bmcode@ if {$key > $midval} { set left [expr {$mid + 1}] } elseif {$key < $midval} { set right [expr {$mid - 1}] } else { set posn $mid break } } if {$posn <= 0} { return -code error "no prev @type@ for key" } if {@bm@} { set val [lindex $nums [expr {$posn -1}]] if {$val == 0} { set val [::enum::pow 2 [expr {($posn -1) + @bitbase@}]] lset nums [expr {$posn -1}] $val } return $val } else { return [lindex $nums [expr {$posn -1}]] } } }] proc ::enum::prev_$type {key} [string map [list @type@ [list $type] @bmcode@ $bmcode @bm@ $bm @bitbase@ $bitbase] { upvar #0 ::enum::ordered_nums_@type@ nums if {[catch {expr {$key + 0}}]} { #key is a name set idx [set ::enum::@type@_to_number($key)] if {[catch { if {@bm@} { #idx is a position if {$idx <=0} { error "out of range" } set val [lindex $nums [expr {$idx -1}]] if {$val == 0} { set val [::enum::pow 2 [expr {($idx -1) + @bitbase@}]] lset nums [expr {$idx -1}] $val } set val } else { #idx is a value. set posn -1 #binary search set left 0 set right [expr {[llength $nums] - 1}] while {$left <= $right} { set mid [expr {wide(floor(($right - $left)/2)) + $left}] set midval [lindex $nums $mid] if {$idx > $midval} { set left [expr {$mid + 1}] } elseif {$idx < $midval} { set right [expr {$mid - 1}] } else { set posn $mid break } } if {$posn <= 0} { error "out of range" } lindex $nums [expr {$posn -1}] } } result]} { return -code error "no prev @type@ for key. err: $result" } return $result } else { #numeric key set posn -1 #binary search set left 0 set right [expr {[llength $nums] - 1}] while {$left <= $right} { set mid [expr {wide(floor(($right - $left)/2)) + $left}] set midval [lindex $nums $mid] @bmcode@ if {$key > $midval} { set left [expr {$mid + 1}] } elseif {$key < $midval} { set right [expr {$mid - 1}] } else { set posn $mid break } } if {$posn <= 0} { error "no prev @type@ for key" } return [lindex ${::enum::ordered_keys_@type@} [expr {$posn -1}]] } }] proc ::enum::vnext_$type {key} [string map [list @type@ [list $type] @bm@ $bm @bmcode@ $bmcode @bitbase@ $bitbase ] { upvar #0 ::enum::ordered_nums_@type@ nums if {[catch {expr {$key + 0}}]} { set idx [set ::enum::@type@_to_number($key)] if {[catch { if {@bm@} { #our idx is already a position.. if {($idx < 0) || ($idx == ([llength $nums] -1)) } { error "out of range" } lindex ${::enum::ordered_keys_@type@} [expr {$idx + 1}] } else { set posn -1 #binary search set left 0 set right [expr {[llength $nums] - 1}] while {$left <= $right} { set mid [expr {wide(floor(($right - $left)/2)) + $left}] set midval [lindex $nums $mid] if {$idx > $midval} { set left [expr {$mid + 1}] } elseif {$idx < $midval} { set right [expr {$mid - 1}] } else { set posn $mid break } } if {$posn < 0} { error "out of range" } lindex ${::enum::ordered_keys_@type@} [expr {$posn + 1}] } } val]} { return -code error "no next @type@ for key" } return $val } else { #int-key # set posn -1 #binary search set left 0 set right [expr {[llength $nums] - 1}] while {$left <= $right} { set mid [expr {wide(floor(($right - $left)/2)) + $left}] set midval [lindex $nums $mid] @bmcode@ if {$key > $midval} { set left [expr {$mid + 1}] } elseif {$key < $midval} { set right [expr {$mid - 1}] } else { set posn $mid break } } if {($posn < 0) || ($posn == ([llength $nums] -1)) } { error "no next @type@ for key" } if {@bm@} { set val [lindex $nums [expr {$posn + 1}]] if {$val == 0} { set val [::enum::pow 2 [expr {($posn + 1) + @bitbase@}]] lset nums [expr {$posn + 1}] $val } return $val } else { return [lindex $nums [expr {$posn + 1}]] } } }] proc ::enum::next_$type {key} [string map [list @type@ [list $type] @bm@ $bm @bmcod@ $bmcode ] { upvar #0 ::enum::ordered_nums_@type@ nums if {[catch {expr {$key + 0}}]} { set idx [set ::enum::@type@_to_number($key)] ;#use temp var idx so we can still emit original $key in err msg if {[catch { set posn -1 #binary search set left 0 set right [expr {[llength $nums] - 1}] while {$left <= $right} { set mid [expr {wide(floor(($right - $left)/2)) + $left}] set midval [lindex $nums $mid] if {$idx > $midval} { set left [expr {$mid + 1}] } elseif {$idx < $midval} { set right [expr {$mid - 1}] } else { set posn $mid break } } if {($posn < 0) || ($posn == ([llength $nums] -1)) } { error "out of range" } lindex $nums [expr {$posn + 1}] } val]} { return -code error "no next @type@ for '$key'" } return $val } else { set posn -1 #binary search set left 0 set right [expr {[llength $nums] - 1}] while {$left <= $right} { set mid [expr {wide(floor(($right - $left)/2)) + $left}] set midval [lindex $nums $mid] @bmcode@ if {$key > $midval} { set left [expr {$mid + 1}] } elseif {$key < $midval} { set right [expr {$mid - 1}] } else { set posn $mid break } } if {($posn < 0) || ($posn == ([llength $nums] -1)) } { #don't emit key value in this err msg. We don't want to force a string rep to be generated. error "no next @type@ for key" } return [lindex ${::enum::ordered_keys_@type@} [expr {$posn +1}]] } }] } #bitmask-specific codeblock. set bmcode "" if {$bm} { set bmcode [string map [list @type@ [list $type] @bitbase@ $bitbase] { #for a bitmask, val now actually holds the position. set posn $val if {[set val [lindex ${::enum::ordered_nums_@type@} $posn]] == 0} { #value not calculated yet.. set val [::enum::pow 2 [expr {$posn + @bitbase@}]] lset ::enum::ordered_nums_@type@ $posn $val } }] } proc ::enum::num_$type {key args} [string map [list @type@ [list $type] @bmcode@ $bmcode] { if {[catch {set ::enum::@type@_to_number($key)} val]} { error "@type@ has no number for '$key' - try 'enum nam @type@ $key' or another key" } else { @bmcode@ return $val } }] proc ::enum::$type {key args} [string map [list @type@ [list $type]] { if {![llength $args]} { #don't let $key shimmer to string rep! (allows large bitmask support) if {[catch {expr {$key + 0}}]} { ::enum::num_@type@ $key {expand}$args } else { ::enum::nam_@type@ $key {expand}$args } } elseif {[llength $args] % 2 == 0} { #assume a sequence of op key op key op key ... #how can we pass to expr without a string rep being generated? #We'll just call expr iteratively.. if {[catch {expr {$key + 0}}]} { set key [::enum::num_@type@ $key] } set pkey $key #This is not meant to be a fully-fledged expression parser. #It is meant to handle binary operations. #consider 'enum create LOGICCHARS {| & ^ ~ } ' #Situations such as that make it difficult to distinguish operators from arguments. #Therefore we support positional operators only in the form: key op key op key ... #To support the common case of flag unsetting, i.e $flags & ~ $key #We add the non-standard compound operator &~ #For symmetry, we support |~ and ^~ #e.g #>set training [enum DAYS mon | wed | sun] #>enum DAYS $training & mon #0 #>enum DAYS $training wed #2 #To unset a bit in a flag.. #>enum DAYS $training &~ wed foreach {op key} $args { if {[catch {expr {$key + 0}}]} { set key [::enum::num_@type@ $key] } switch -- $op { "==" {set pkey [expr {$pkey == $key}]} "!=" {set pkey [expr {$pkey != $key}]} "<" {set pkey [expr {$pkey < $key}]} "<=" {set pkey [expr {$pkey <= $key}]} ">" {set pkey [expr {$pkey > $key}]} ">=" {set pkey [expr {$pkey >= $key}]} "&" {set pkey [expr {$pkey & $key}]} "|" {set pkey [expr {$pkey | $key}]} "^" {set pkey [expr {$pkey ^ $key}]} "&~" {set pkey [expr {$pkey & ~ $key}]} "|~" {set pkey [expr {$pkey | ~ $key}]} "^~" {set pkey [expr {$pkey ^ ~ $key}]} ">>" {set pkey [expr {$pkey >> $key}]} "<<" {set pkey [expr {$pkey << $key}]} default { error "cannot perform operation '$op'" } } } return $pkey } else { error "usage: 'enum ' or 'enum \[==|!=|>|>=|<|<=\] '" } }] namespace export $type } interp alias {} ::enum::number {} ::enum::num interp alias {} ::enum::name {} ::enum::nam proc ::enum::num {type key args} { #!todo - review. performance - should we use catch.. or allow fail with unfriendly error string? if {$type ni [namespace export]} { error "enumerated type '$type' not available" } if {![llength $args]} { ::enum::num_$type $key } else { ::enum::num_$type [enum::$type $key {expand}$args] } } proc ::enum::nam {type key args} { if {$type ni [namespace export]} { error "enumerated type '$type' not available" } if {![llength $args]} { ::enum::nam_$type $key } else { ::enum::nam_$type [enum::$type $key {expand}$args] } } proc ::enum::values {type} { return [set ::enum::ordered_keys_$type] } proc ::enum::dist {type v1 v2} { if {[catch {expr {$v1 + 0}}]} { set v1 [set ::enum::${type}_to_number($v1)] } if {[catch {expr {$v2 + 0}}]} { set v2 [set ::enum::${type}_to_number($v2)] } #!todo - what is the 'dist' between 2^^n & 2^^(n+1) ??? # - is it 2^^n or just 1 for the purposes of enumerated types? # expr {abs($v1 -$v2)} } proc ::enum::diff {type v1 v2} { if {[catch {expr {$v1 + 0}}]} { set v1 [set ::enum::${type}_to_number($v1)] } if {[catch {expr {$v2 + 0}}]} { set v2 [set ::enum::${type}_to_number($v2)] } expr {$v1 -$v2} } proc ::enum::next {type key} { if {$type ni [namespace export]} { error "enumerated type '$type' not available" } ::enum::next_$type $key } ## #Purpose: return *same* type of key as supplied (equiv to wrapping plain 'next' with another enum call) # proc ::enum::vnext {type key} { if {$type ni [namespace export]} { error "enumerated type '$type' not available" } ::enum::vnext_$type $key } proc ::enum::prev {type key} { if {$type ni [namespace export]} { error "enumerated type '$type' not available" } ::enum::prev_$type $key } proc ::enum::vprev {type key} { if {$type ni [namespace export]} { error "enumerated type '$type' not available" } ::enum::vprev_$type $key } proc ::enum::bits {type args} { if {$type ni [namespace export]} { error "enumerated type '$type' not available" } enum::i2bits [enum::$type {expand}$args] } proc ::enum::hex {type args} { if {$type ni [namespace export]} { error "enumerated type '$type' not available" } enum::i2hex [enum::$type {expand}$args] } #int2bits - from: http://mini.net/tcl/1591 proc ::enum::i2bits2 {i} { set res "" while {$i > 0} { set res [expr {$i % 2}]$res set i [expr {$i / 2}] } if {$res==""} {set res 0} return $res } #i2bitlist - based on: http://mini.net/tcl/1591 proc ::enum::i2bitlist {i} { if {($i == 0) || ($i == 1)} { set bitsrequired 1 } else { #expr's log won't work on really big numbers! set bitsrequired [expr {int(floor( log($i) / log(2) )) + 1}] } set res [lrepeat $bitsrequired 0] ;#preallocate a list of the right size. while {$i > 0} { lset res [incr bitsrequired -1] [expr {$i % 2}] set i [expr {$i >> 1}] ;#presumably equiv to $i / 2 } return $res } #create a list of unsigned bytes. proc ::enum::i2bytelist {i} { if {($i == 0) || ($i == 1)} { set bitsrequired 1 set bytesrequired 1 } else { #set bitsrequired [expr {int(floor( log($i) / log(2) )) + 1}] #expr's log can't handle bignums.. set n $i set bytesrequired 0 while {$n > 0} { set n [expr {$n >> 8}] incr bytesrequired } } set res [lrepeat $bytesrequired 0] while {$i > 0} { lset res [incr bytesrequired -1] [expr {$i % 256}] set i [expr {$i >> 8}] } return $res } proc ::enum::i2bits3 {i} { return [join [::enum::i2bitlist $i] {}] } #bigint to bits #returns multiple of 8 bits. proc ::enum::i2bits {i} { set bytes [::enum::i2bytelist $i] binary scan [binary format c[llength $bytes] $bytes] B* val return $val } #bigint to hex proc ::enum::i2hex {i} { set bytes [::enum::i2bytelist $i] binary scan [binary format c[llength $bytes] $bytes] H* val return $val } proc ::enum::bytelist2i {bytelist} { set i 0 foreach byteval $bytelist { set i [expr {($i << 8) + $byteval}] } return $i } #load a binary (byte-packed bitmask) to a biginteger # (expr doesn't seem to be able to do bitwise ops directly on binary strings) proc ::enum::bin2i {bin} { #!todo - research. Is there a more efficient way to load this into a number suitable for expr? binary scan $bin c* sbytelist set i 0 #note - bytes are *signed* foreach byteval $sbytelist { set i [expr {($i << 8) + (($byteval + 0x100) % 0x100)}] } return $i } proc ::enum::i2bin {i} { set bytes [enum::i2bytelist $i] return [binary format c[llength $bytes] $bytes] } proc ::enum::bin {type args} { if {$type ni [namespace export]} { error "enumerated type '$type' not available" } set bytes [enum::i2bytelist [enum::$type {expand}$args]] return [binary format c[llength $bytes] $bytes] } proc ::enum::destroy {type} { unset ::enum::${type}_to_number unset ::enum::ordered_keys_${type} rename ::enum::$type {} rename ::enum::nam_$type {} rename ::enum::num_$type {} rename ::enum::vprev_$type {} rename ::enum::prev_$type {} rename ::enum::vnext_$type {} rename ::enum::next_$type {} set posn [lsearch [namespace export] $type] namespace export -clear {expand}[lreplace [namespace export] $posn $posn] } #Do not remove the trailing comment character from this file. ##tarpack-enum-1.5.2/#z 777 0 0 76 10464721135 7414 0#Do not remove the trailing ctrl-z character from this file.