848 changed files with 461881 additions and 36131 deletions
@ -1,4 +1,4 @@ |
|||||||
Copyright (c) 2003-2012, Ashok P. Nadkarni |
Copyright (c) 2003-2024, Ashok P. Nadkarni |
||||||
All rights reserved. |
All rights reserved. |
||||||
|
|
||||||
Redistribution and use in source and binary forms, with or without |
Redistribution and use in source and binary forms, with or without |
||||||
@ -0,0 +1,73 @@ |
|||||||
|
# Tcl Windows API (TWAPI) extension |
||||||
|
|
||||||
|
The Tcl Windows API (TWAPI) extension provides access to the Windows API from |
||||||
|
within the Tcl scripting language. |
||||||
|
|
||||||
|
* Project source repository is at https://github.com/apnadkarni/twapi |
||||||
|
* Documentation is at https://twapi.magicsplat.com |
||||||
|
* Binary distribution is at https://sourceforge.net/projects/twapi/files/Current%20Releases/Tcl%20Windows%20API/ |
||||||
|
|
||||||
|
## Supported platforms |
||||||
|
|
||||||
|
TWAPI 5.0 requires |
||||||
|
|
||||||
|
* Windows 7 SP1 or later |
||||||
|
* Tcl 8.6.10+ or Tcl 9.x |
||||||
|
|
||||||
|
### Binary distribution |
||||||
|
|
||||||
|
The single binary distribution supports Tcl 8.6 and Tcl 9 for both 32- and |
||||||
|
64-bit platforms. |
||||||
|
|
||||||
|
It requires the VC++ runtime to already be installed |
||||||
|
on the system. Download from https://learn.microsoft.com/en-us/cpp/windows/latest-supported-vc-redist if necessary. |
||||||
|
|
||||||
|
Windows 7 and 8.x also require the Windows UCRT runtime to be installed if not |
||||||
|
present. Download from https://support.microsoft.com/en-gb/topic/update-for-universal-c-runtime-in-windows-c0514201-7fe6-95a3-b0a5-287930f3560c. |
||||||
|
|
||||||
|
In most cases, both the above should already be present on the system. |
||||||
|
|
||||||
|
Note that the *modular* and single file *bin* in 4.x distributions are no longer |
||||||
|
available and will not be supported in 5.0. |
||||||
|
|
||||||
|
## TWAPI Summary |
||||||
|
|
||||||
|
The Tcl Windows API (TWAPI) extension provides access to the Windows API from |
||||||
|
within the Tcl scripting language. |
||||||
|
|
||||||
|
Functions in the following areas are implemented: |
||||||
|
|
||||||
|
* System functions including OS and CPU information, |
||||||
|
shutdown and message formatting |
||||||
|
* User and group management |
||||||
|
* COM client and server support |
||||||
|
* Security and resource access control |
||||||
|
* Window management |
||||||
|
* User input: generate key/mouse input and hotkeys |
||||||
|
* Basic sound playback functions |
||||||
|
* Windows services |
||||||
|
* Windows event log access |
||||||
|
* Windows event tracing |
||||||
|
* Process and thread management |
||||||
|
* Directory change monitoring |
||||||
|
* Lan Manager and file and print shares |
||||||
|
* Drive information, file system types etc. |
||||||
|
* Network configuration and statistics |
||||||
|
* Network connection monitoring and control |
||||||
|
* Named pipes |
||||||
|
* Clipboard access |
||||||
|
* Taskbar icons and notifications |
||||||
|
* Console mode functions |
||||||
|
* Window stations and desktops |
||||||
|
* Internationalization |
||||||
|
* Task scheduling |
||||||
|
* Shell functions |
||||||
|
* Registry |
||||||
|
* Windows Management Instrumentation |
||||||
|
* Windows Installer |
||||||
|
* Synchronization |
||||||
|
* Power management |
||||||
|
* Device I/O and management |
||||||
|
* Crypto API and certificates |
||||||
|
* SSL/TLS |
||||||
|
* Windows Performance Counters |
||||||
@ -0,0 +1,100 @@ |
|||||||
|
if {$::tcl_platform(platform) ne "windows"} { |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
package ifneeded twapi_base 5.0b1 \ |
||||||
|
[list apply [list {dir} { |
||||||
|
package require platform |
||||||
|
set packageVer [string map {. {}} 5.0b1] |
||||||
|
if {[package vsatisfies [package require Tcl] 9]} { |
||||||
|
set baseDllName "tcl9twapi50b1.dll" |
||||||
|
} else { |
||||||
|
set baseDllName "twapi50b1t.dll" |
||||||
|
} |
||||||
|
set package "twapi" |
||||||
|
set package_ns ::$package |
||||||
|
namespace eval $package_ns {} |
||||||
|
set package_init_name [string totitle $package] |
||||||
|
|
||||||
|
# Try to load from current directory and if that fails try from |
||||||
|
# platform-specific directories. Note on failure to load when the DLL |
||||||
|
# exists, we do not try to load from other locations as twapi modules |
||||||
|
# may have been partially set up. |
||||||
|
|
||||||
|
set dllFound false |
||||||
|
foreach platform [linsert [::platform::patterns [platform::identify]] 0 .] { |
||||||
|
if {$platform eq "tcl"} continue |
||||||
|
set path [file join $dir $platform $baseDllName] |
||||||
|
if {[file exists $path]} { |
||||||
|
uplevel #0 [list load $path $package_init_name] |
||||||
|
set dllFound true |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {!$dllFound} { |
||||||
|
error "Could not locate TWAPI dll." |
||||||
|
} |
||||||
|
|
||||||
|
# Load was successful |
||||||
|
set ${package_ns}::dllPath [file normalize $path] |
||||||
|
set ${package_ns}::packageDir $dir |
||||||
|
source [file join $dir twapi.tcl] |
||||||
|
package provide twapi_base 5.0b1 |
||||||
|
}] $dir] |
||||||
|
|
||||||
|
set __twapimods { |
||||||
|
com |
||||||
|
msi |
||||||
|
power |
||||||
|
printer |
||||||
|
synch |
||||||
|
security |
||||||
|
account |
||||||
|
apputil |
||||||
|
clipboard |
||||||
|
console |
||||||
|
crypto |
||||||
|
device |
||||||
|
etw |
||||||
|
eventlog |
||||||
|
mstask |
||||||
|
multimedia |
||||||
|
namedpipe |
||||||
|
network |
||||||
|
nls |
||||||
|
os |
||||||
|
pdh |
||||||
|
process |
||||||
|
rds |
||||||
|
registry |
||||||
|
resource |
||||||
|
service |
||||||
|
share |
||||||
|
shell |
||||||
|
storage |
||||||
|
ui |
||||||
|
input |
||||||
|
winsta |
||||||
|
wmi |
||||||
|
} |
||||||
|
foreach __twapimod $__twapimods { |
||||||
|
package ifneeded twapi_$__twapimod 5.0b1 \ |
||||||
|
[list apply [list {dir mod} { |
||||||
|
package require twapi_base 5.0b1 |
||||||
|
source [file join $dir $mod.tcl] |
||||||
|
package provide twapi_$mod 5.0b1 |
||||||
|
}] $dir $__twapimod] |
||||||
|
} |
||||||
|
|
||||||
|
package ifneeded twapi 5.0b1 \ |
||||||
|
[list apply [list {dir mods} { |
||||||
|
package require twapi_base 5.0b1 |
||||||
|
foreach mod $mods { |
||||||
|
package require twapi_$mod 5.0b1 |
||||||
|
} |
||||||
|
package provide twapi 5.0b1 |
||||||
|
}] $dir $__twapimods] |
||||||
|
|
||||||
|
unset __twapimod |
||||||
|
unset __twapimods |
||||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
@ -0,0 +1,64 @@ |
|||||||
|
|
||||||
|
# Copyright (c) 2021 Ashok P. Nadkarni |
||||||
|
# All rights reserved. |
||||||
|
# |
||||||
|
# See the file LICENSE for license |
||||||
|
|
||||||
|
namespace eval twapi { |
||||||
|
variable _wts_session_monitors |
||||||
|
set _wts_session_monitors [dict create] |
||||||
|
} |
||||||
|
|
||||||
|
proc twapi::start_wts_session_monitor {script args} { |
||||||
|
variable _wts_session_monitors |
||||||
|
|
||||||
|
parseargs args { |
||||||
|
all |
||||||
|
} -maxleftover 0 -setvars] |
||||||
|
|
||||||
|
set script [lrange $script 0 end]; # Verify syntactically a list |
||||||
|
|
||||||
|
set id "wts#[TwapiId]" |
||||||
|
if {[dict size $_wts_session_monitors] == 0} { |
||||||
|
# No monitoring in progress. Start it |
||||||
|
# 0x2B1 -> WM_WTSSESSION_CHANGE |
||||||
|
Twapi_WTSRegisterSessionNotification $all |
||||||
|
_register_script_wm_handler 0x2B1 [list [namespace current]::_wts_session_change_handler] 0 |
||||||
|
} |
||||||
|
|
||||||
|
dict set _wts_session_monitors $id $script |
||||||
|
return $id |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc twapi::stop_wts_session_monitor {id} { |
||||||
|
variable _wts_session_monitors |
||||||
|
|
||||||
|
if {![dict exists $_wts_session_monitors $id]} { |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
dict unset _wts_session_monitors $id |
||||||
|
if {[dict size $_wts_session_monitors] == 0} { |
||||||
|
# 0x2B1 -> WM_WTSSESSION_CHANGE |
||||||
|
_unregister_script_wm_handler 0x2B1 [list [namespace current]::_wts_session_handler] |
||||||
|
Twapi_WTSUnRegisterSessionNotification |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc twapi::_wts_session_change_handler {msg change session_id msgpos ticks} { |
||||||
|
variable _wts_session_monitors |
||||||
|
|
||||||
|
if {[dict size $_wts_session_monitors] == 0} { |
||||||
|
return; # Not an error, could have deleted while already queued |
||||||
|
} |
||||||
|
|
||||||
|
dict for {id script} $_wts_session_monitors { |
||||||
|
set code [catch {uplevel #0 [linsert $script end $change $session_id]} msg] |
||||||
|
if {$code == 1} { |
||||||
|
# Error - put in background but we do not abort |
||||||
|
after 0 [list error $msg $::errorInfo $::errorCode] |
||||||
|
} |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
@ -1,605 +0,0 @@ |
|||||||
# MeTOO stands for "MeTOO Emulates TclOO" (at a superficial syntactic level) |
|
||||||
# |
|
||||||
# Implements a *tiny*, but useful, subset of TclOO, primarily for use |
|
||||||
# with Tcl 8.4. Intent is that if you write code using MeToo, it should work |
|
||||||
# unmodified with TclOO in 8.5/8.6. Obviously, don't try going the other way! |
|
||||||
# |
|
||||||
# Emulation is superficial, don't try to be too clever in usage. |
|
||||||
# Doing funky, or even non-funky, things with object namespaces will |
|
||||||
# not work as you would expect. |
|
||||||
# |
|
||||||
# See the metoo::demo proc for sample usage. Calling this proc |
|
||||||
# with parameter "oo" will use the TclOO commands. Else the metoo:: |
|
||||||
# commands. Note the demo code remains the same for both. |
|
||||||
# |
|
||||||
# The following fragment uses MeToo only if TclOO is not available: |
|
||||||
# if {[llength [info commands oo::*]]} { |
|
||||||
# namespace import oo::* |
|
||||||
# } else { |
|
||||||
# source metoo.tcl |
|
||||||
# namespace import metoo::class |
|
||||||
# } |
|
||||||
# class create C {...} |
|
||||||
# |
|
||||||
# Summary of the TclOO subset implemented - see TclOO docs for detail : |
|
||||||
# |
|
||||||
# Creating a new class: |
|
||||||
# metoo::class create CLASSNAME CLASSDEFINITION |
|
||||||
# |
|
||||||
# Destroying a class: |
|
||||||
# CLASSNAME destroy |
|
||||||
# - this also destroys objects of that class and recursively destroys |
|
||||||
# child classes. NOTE: deleting the class namespace or renaming |
|
||||||
# the CLASSNAME command to "" will NOT call object destructors. |
|
||||||
# |
|
||||||
# CLASSDEFINITION: Following may appear in CLASSDEFINTION |
|
||||||
# method METHODNAME params METHODBODY |
|
||||||
# - same as TclOO |
|
||||||
# constructor params METHODBODY |
|
||||||
# - same syntax as TclOO |
|
||||||
# destructor METHODBODY |
|
||||||
# - same syntax as TclOO |
|
||||||
# unknown METHODNAME ARGS |
|
||||||
# - if defined, called when an undefined method is invoked |
|
||||||
# superclass SUPER |
|
||||||
# - inherits from SUPER. Unlike TclOO, only single inheritance. Also |
|
||||||
# no checks for inheritance loops. You'll find out quickly enough! |
|
||||||
# All other commands within a CLASSDEFINITION will either raise error or |
|
||||||
# work differently from TclOO. Actually you can use pretty much any |
|
||||||
# Tcl command inside CLASSDEFINITION but the results may not be what you |
|
||||||
# expect. Best to avoid this. |
|
||||||
# |
|
||||||
# METHODBODY: The following method-internal TclOO commands are available: |
|
||||||
# my METHODNAME ARGS |
|
||||||
# - to call another method METHODNAME |
|
||||||
# my variable VAR1 ?VAR2...? |
|
||||||
# - brings object-specific variables into scope |
|
||||||
# next ?ARGS? |
|
||||||
# - calls the superclass method of the same name |
|
||||||
# self |
|
||||||
# self object |
|
||||||
# - returns the object name (usable as a command) |
|
||||||
# self class |
|
||||||
# - returns class of this object |
|
||||||
# self namespace |
|
||||||
# - returns namespace of this object |
|
||||||
# |
|
||||||
# Creating objects: |
|
||||||
# CLASSNAME create OBJNAME ?ARGS? |
|
||||||
# - creates object OBJNAME of class CLASSNAME, passing ARGS to constructor |
|
||||||
# Returns the fully qualified object name that can be used as a command. |
|
||||||
# CLASSNAME new ?ARGS? |
|
||||||
# - creates a new object with an auto-generated name |
|
||||||
# |
|
||||||
# Destroying objects |
|
||||||
# OBJNAME destroy |
|
||||||
# - destroys the object calling destructors |
|
||||||
# rename OBJNAME "" |
|
||||||
# - same as above |
|
||||||
# |
|
||||||
# Renaming an object |
|
||||||
# rename OBJNAME NEWNAME |
|
||||||
# - the object can now be invoked using the new name. Note this is unlike |
|
||||||
# classes which should not be renamed. |
|
||||||
# |
|
||||||
# |
|
||||||
# Introspection (though different from TclOO) |
|
||||||
# metoo::introspect object isa OBJECT ?CLASSNAME? |
|
||||||
# - returns 1 if OBJECT is a metoo object and is of the specified class |
|
||||||
# if CLASSNAME is specified. Returns 0 otherwise. |
|
||||||
# metoo::introspect object list |
|
||||||
# - returns list of all objects |
|
||||||
# metoo::introspect class ancestors CLASSNAME |
|
||||||
# - returns list of ancestors for a class |
|
||||||
# |
|
||||||
# Differences and missing features from TclOO: Everything not listed above |
|
||||||
# is missing. Some notable differences: |
|
||||||
# - MeTOO is class-based, not object based like TclOO, thus class instances |
|
||||||
# (objects) cannot be modified by adding instance-specific methods etc.. |
|
||||||
# Also a class is not itself an object. |
|
||||||
# - Renaming classes does not work and will fail in mysterious ways |
|
||||||
# - does not support class refinement/definition |
|
||||||
# - no variable command at class level for automatically bringing variables |
|
||||||
# into scope |
|
||||||
# - no filters, forwarding, multiple-inheritance |
|
||||||
# - no private methods (all methods are exported). |
|
||||||
|
|
||||||
# NOTE: file must be sourced at global level since metoo namespace is expected |
|
||||||
# to be top level namespace |
|
||||||
|
|
||||||
# DO NOT DO THIS. ELSE TESTS FAIL BECAUSE they define tests in the |
|
||||||
# metoo namespace which then get deleted by the line below when |
|
||||||
# the package is lazy auto-loaded |
|
||||||
# catch {namespace delete metoo} |
|
||||||
|
|
||||||
# TBD - variable ("my variable" is done, "variable" in method or |
|
||||||
# class definition is not) |
|
||||||
# TBD - default constructor and destructor to "next" (or maybe that |
|
||||||
# is already taken care of by the inheritance code |
|
||||||
|
|
||||||
namespace eval metoo { |
|
||||||
variable next_id 0 |
|
||||||
|
|
||||||
variable _objects; # Maps objects to its namespace |
|
||||||
array set _objects {} |
|
||||||
|
|
||||||
} |
|
||||||
|
|
||||||
# Namespace in which commands in a class definition block are called |
|
||||||
namespace eval metoo::define { |
|
||||||
proc method {class_ns name params body} { |
|
||||||
# Methods are defined in the methods subspace of the class namespace. |
|
||||||
# We prefix with _m_ to prevent them from being directly called |
|
||||||
# as procs, for example if the method is a Tcl command like "set" |
|
||||||
# The first parameter to a method is always the object namespace |
|
||||||
# denoted as the paramter "_this" |
|
||||||
namespace eval ${class_ns}::methods [list proc _m_$name [concat [list _this] $params] $body] |
|
||||||
|
|
||||||
} |
|
||||||
proc superclass {class_ns superclass} { |
|
||||||
if {[info exists ${class_ns}::super]} { |
|
||||||
error "Only one superclass allowed for a class" |
|
||||||
} |
|
||||||
set sup [uplevel 3 "namespace eval $superclass {namespace current}"] |
|
||||||
set ${class_ns}::super $sup |
|
||||||
# We store the subclass in the super so it can be destroyed |
|
||||||
# if the super is destroyed. |
|
||||||
set ${sup}::subclasses($class_ns) 1 |
|
||||||
} |
|
||||||
proc constructor {class_ns params body} { |
|
||||||
method $class_ns constructor $params $body |
|
||||||
} |
|
||||||
proc destructor {class_ns body} { |
|
||||||
method $class_ns destructor {} $body |
|
||||||
} |
|
||||||
proc export {args} { |
|
||||||
# Nothing to do, all methods are exported anyways |
|
||||||
# Command is here for compatibility only |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
# Namespace in which commands used in objects methods are defined |
|
||||||
# (self, my etc.) |
|
||||||
namespace eval metoo::object { |
|
||||||
proc next {args} { |
|
||||||
upvar 1 _this this; # object namespace |
|
||||||
|
|
||||||
# Figure out what class context this is executing in. Note |
|
||||||
# we cannot use _this in caller since that is the object namespace |
|
||||||
# which is not necessarily related to the current class namespace. |
|
||||||
set class_ns [namespace parent [uplevel 1 {namespace current}]] |
|
||||||
|
|
||||||
# Figure out the current method being called |
|
||||||
set methodname [namespace tail [lindex [uplevel 1 {info level 0}] 0]] |
|
||||||
|
|
||||||
# Find the next method in the class hierarchy and call it |
|
||||||
while {[info exists ${class_ns}::super]} { |
|
||||||
set class_ns [set ${class_ns}::super] |
|
||||||
if {[llength [info commands ${class_ns}::methods::$methodname]]} { |
|
||||||
return [uplevel 1 [list ${class_ns}::methods::$methodname $this] $args] |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
error "'next' command has no receiver in the hierarchy for method $methodname" |
|
||||||
} |
|
||||||
|
|
||||||
proc self {{what object}} { |
|
||||||
upvar 1 _this this |
|
||||||
switch -exact -- $what { |
|
||||||
class { return [namespace parent $this] } |
|
||||||
namespace { return $this } |
|
||||||
object { return [set ${this}::_(name)] } |
|
||||||
default { |
|
||||||
error "Argument '$what' not understood by self method" |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
proc my {methodname args} { |
|
||||||
# We insert the object namespace as the first parameter to the command. |
|
||||||
# This is passed as the first parameter "_this" to methods. Since |
|
||||||
# "my" can be only called from methods, we can retrieve it fro |
|
||||||
# our caller. |
|
||||||
upvar 1 _this this; # object namespace |
|
||||||
|
|
||||||
set class_ns [namespace parent $this] |
|
||||||
|
|
||||||
set meth [::metoo::_locate_method $class_ns $methodname] |
|
||||||
if {$meth ne ""} { |
|
||||||
# We need to invoke in the caller's context so upvar etc. will |
|
||||||
# not be affected by this intermediate method dispatcher |
|
||||||
return [uplevel 1 [list $meth $this] $args] |
|
||||||
} |
|
||||||
|
|
||||||
# It is ok for constructor or destructor to be undefined. For |
|
||||||
# the others, invoke "unknown" if it exists |
|
||||||
if {$methodname eq "constructor" || $methodname eq "destructor"} { |
|
||||||
return |
|
||||||
} |
|
||||||
|
|
||||||
set meth [::metoo::_locate_method $class_ns "unknown"] |
|
||||||
if {$meth ne ""} { |
|
||||||
# We need to invoke in the caller's context so upvar etc. will |
|
||||||
# not be affected by this intermediate method dispatcher |
|
||||||
return [uplevel 1 [list $meth $this $methodname] $args] |
|
||||||
} |
|
||||||
|
|
||||||
error "Unknown method $methodname" |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
# Given a method name, locate it in the class hierarchy. Returns |
|
||||||
# fully qualified method if found, else an empty string |
|
||||||
proc metoo::_locate_method {class_ns methodname} { |
|
||||||
# See if there is a method defined in this class. |
|
||||||
# Breakage if method names with wildcard chars. Too bad |
|
||||||
if {[llength [info commands ${class_ns}::methods::_m_$methodname]]} { |
|
||||||
# We need to invoke in the caller's context so upvar etc. will |
|
||||||
# not be affected by this intermediate method dispatcher |
|
||||||
return ${class_ns}::methods::_m_$methodname |
|
||||||
} |
|
||||||
|
|
||||||
# No method here, check for super class. |
|
||||||
while {[info exists ${class_ns}::super]} { |
|
||||||
set class_ns [set ${class_ns}::super] |
|
||||||
if {[llength [info commands ${class_ns}::methods::_m_$methodname]]} { |
|
||||||
return ${class_ns}::methods::_m_$methodname |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
return ""; # Not found |
|
||||||
} |
|
||||||
|
|
||||||
proc metoo::_new {class_ns cmd args} { |
|
||||||
# class_ns expected to be fully qualified |
|
||||||
variable next_id |
|
||||||
|
|
||||||
# IMPORTANT: |
|
||||||
# object namespace *must* be child of class namespace. |
|
||||||
# Saves a bit of bookkeeping. Putting it somewhere else will require |
|
||||||
# changes to many other places in the code. |
|
||||||
set objns ${class_ns}::o#[incr next_id] |
|
||||||
|
|
||||||
switch -exact -- $cmd { |
|
||||||
create { |
|
||||||
if {[llength $args] < 1} { |
|
||||||
error "Insufficient args, should be: class create CLASSNAME ?args?" |
|
||||||
} |
|
||||||
# TBD - check if command already exists |
|
||||||
# Note objname must always be fully qualified. Note cannot |
|
||||||
# use namespace which here because the commmand does not |
|
||||||
# yet exist. |
|
||||||
set args [lassign $args objname] |
|
||||||
if {[string compare :: [string range $objname 0 1]]} { |
|
||||||
# Not fully qualified. Qualify based on caller namespace |
|
||||||
set objname [uplevel 1 "namespace current"]::$objname |
|
||||||
} |
|
||||||
# Trip excess ":" - can happen in both above cases |
|
||||||
set objname ::[string trimleft $objname :] |
|
||||||
} |
|
||||||
new { |
|
||||||
set objname $objns |
|
||||||
} |
|
||||||
default { |
|
||||||
error "Unknown command '$cmd'. Should be create or new." |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
# Create the namespace. The array _ is used to hold private information |
|
||||||
namespace eval $objns { |
|
||||||
variable _ |
|
||||||
} |
|
||||||
set ${objns}::_(name) $objname |
|
||||||
|
|
||||||
# When invoked by its name, call the dispatcher. |
|
||||||
interp alias {} $objname {} ${class_ns}::_call $objns |
|
||||||
|
|
||||||
# Register the object. We do this BEFORE running the constructor |
|
||||||
variable _objects |
|
||||||
set _objects($objname) $objns |
|
||||||
|
|
||||||
# Invoke the constructor |
|
||||||
if {[catch { |
|
||||||
$objname constructor {*}$args |
|
||||||
} msg]} { |
|
||||||
# Undo what we did |
|
||||||
set erinfo $::errorInfo |
|
||||||
set ercode $::errorCode |
|
||||||
rename $objname "" |
|
||||||
namespace delete $objns |
|
||||||
error $msg $erinfo $ercode |
|
||||||
} |
|
||||||
|
|
||||||
# TBD - does tracing cause a slowdown ? |
|
||||||
# Set up trace to track when the object is renamed/destroyed |
|
||||||
trace add command $objname {rename delete} [list [namespace current]::_trace_object_renames $objns] |
|
||||||
|
|
||||||
return $objname |
|
||||||
} |
|
||||||
|
|
||||||
proc metoo::_trace_object_renames {objns oldname newname op} { |
|
||||||
# Note the trace command fully qualifies oldname and newname |
|
||||||
if {$op eq "rename"} { |
|
||||||
variable _objects |
|
||||||
set _objects($newname) $_objects($oldname) |
|
||||||
unset _objects($oldname) |
|
||||||
set ${objns}::_(name) $newname |
|
||||||
} else { |
|
||||||
$oldname destroy |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
proc metoo::_class_cmd {class_ns cmd args} { |
|
||||||
switch -exact -- $cmd { |
|
||||||
create - |
|
||||||
new { |
|
||||||
return [uplevel 1 [list [namespace current]::_new $class_ns $cmd] $args] |
|
||||||
} |
|
||||||
destroy { |
|
||||||
# Destroy all objects belonging to this class |
|
||||||
foreach objns [namespace children ${class_ns} o#*] { |
|
||||||
[set ${objns}::_(name)] destroy |
|
||||||
} |
|
||||||
# Destroy all classes that inherit from this |
|
||||||
foreach child_ns [array names ${class_ns}::subclasses] { |
|
||||||
# Child namespace is also subclass command |
|
||||||
$child_ns destroy |
|
||||||
} |
|
||||||
trace remove command $class_ns {rename delete} [list ::metoo::_trace_class_renames] |
|
||||||
namespace delete ${class_ns} |
|
||||||
rename ${class_ns} "" |
|
||||||
} |
|
||||||
default { |
|
||||||
error "Unknown command '$cmd'. Should be create, new or destroy." |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
proc metoo::class {cmd cname definition} { |
|
||||||
variable next_id |
|
||||||
|
|
||||||
if {$cmd ne "create"} { |
|
||||||
error "Syntax: class create CLASSNAME DEFINITION" |
|
||||||
} |
|
||||||
|
|
||||||
if {[uplevel 1 "namespace exists $cname"]} { |
|
||||||
error "can't create class '$cname': namespace already exists with that name." |
|
||||||
} |
|
||||||
|
|
||||||
# Resolve cname into a namespace in the caller's context |
|
||||||
set class_ns [uplevel 1 "namespace eval $cname {namespace current}"] |
|
||||||
|
|
||||||
if {[llength [info commands $class_ns]]} { |
|
||||||
# Delete the namespace we just created |
|
||||||
namespace delete $class_ns |
|
||||||
error "can't create class '$cname': command already exists with that name." |
|
||||||
} |
|
||||||
|
|
||||||
# Define the commands/aliases that are used inside a class definition |
|
||||||
foreach procname [info commands [namespace current]::define::*] { |
|
||||||
interp alias {} ${class_ns}::[namespace tail $procname] {} $procname $class_ns |
|
||||||
} |
|
||||||
|
|
||||||
# Define the built in commands callable within class instance methods |
|
||||||
foreach procname [info commands [namespace current]::object::*] { |
|
||||||
interp alias {} ${class_ns}::methods::[namespace tail $procname] {} $procname |
|
||||||
} |
|
||||||
|
|
||||||
# Define the destroy method for the class object instances |
|
||||||
namespace eval $class_ns { |
|
||||||
method destroy {} { |
|
||||||
set retval [my destructor] |
|
||||||
# Remove trace on command rename/deletion. |
|
||||||
# ${_this}::_(name) contains the object's current name on |
|
||||||
# which the trace is set. |
|
||||||
set me [set ${_this}::_(name)] |
|
||||||
trace remove command $me {rename delete} [list ::metoo::_trace_object_renames $_this] |
|
||||||
rename $me "" |
|
||||||
unset -nocomplain ::metoo::_objects($me) |
|
||||||
namespace delete $_this |
|
||||||
return $retval |
|
||||||
} |
|
||||||
method variable {args} { |
|
||||||
if {[llength $args]} { |
|
||||||
set cmd [list upvar 0] |
|
||||||
foreach varname $args { |
|
||||||
lappend cmd ${_this}::$varname $varname |
|
||||||
} |
|
||||||
uplevel 1 $cmd |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
# Define the class. Note we do this *after* the standard |
|
||||||
# definitions (destroy etc.) above so that they can |
|
||||||
# be overridden by the class definition. |
|
||||||
if {[catch { |
|
||||||
namespace eval $class_ns $definition |
|
||||||
} msg ]} { |
|
||||||
namespace delete $class_ns |
|
||||||
error $msg $::errorInfo $::errorCode |
|
||||||
} |
|
||||||
|
|
||||||
# Also define the call dispatcher within the class. |
|
||||||
# TBD - not sure this is actually necessary any more |
|
||||||
namespace eval ${class_ns} { |
|
||||||
proc _call {objns methodname args} { |
|
||||||
# Note this duplicates the "my" code but cannot call that as |
|
||||||
# it adds another frame level which interferes with uplevel etc. |
|
||||||
|
|
||||||
set class_ns [namespace parent $objns] |
|
||||||
|
|
||||||
# We insert the object namespace as the first param to the command. |
|
||||||
# This is passed as the first parameter "_this" to methods. |
|
||||||
|
|
||||||
set meth [::metoo::_locate_method $class_ns $methodname] |
|
||||||
if {$meth ne ""} { |
|
||||||
# We need to invoke in the caller's context so upvar etc. will |
|
||||||
# not be affected by this intermediate method dispatcher |
|
||||||
return [uplevel 1 [list $meth $objns] $args] |
|
||||||
} |
|
||||||
|
|
||||||
# It is ok for constructor or destructor to be undefined. For |
|
||||||
# the others, invoke "unknown" if it exists |
|
||||||
|
|
||||||
if {$methodname eq "constructor" || $methodname eq "destructor"} { |
|
||||||
return |
|
||||||
} |
|
||||||
|
|
||||||
set meth [::metoo::_locate_method $class_ns "unknown"] |
|
||||||
if {$meth ne ""} { |
|
||||||
# We need to invoke in the caller's context so upvar etc. will |
|
||||||
# not be affected by this intermediate method dispatcher |
|
||||||
return [uplevel 1 [list $meth $objns $methodname] $args] |
|
||||||
} |
|
||||||
|
|
||||||
error "Unknown method $methodname" |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
# The namespace is also a command used to create class instances |
|
||||||
# TBD - check if command of that name already exists |
|
||||||
interp alias {} $class_ns {} [namespace current]::_class_cmd $class_ns |
|
||||||
# Set up trace to track when the class command is renamed/destroyed |
|
||||||
trace add command $class_ns [list rename delete] ::metoo::_trace_class_renames |
|
||||||
|
|
||||||
return $class_ns |
|
||||||
} |
|
||||||
|
|
||||||
proc metoo::_trace_class_renames {oldname newname op} { |
|
||||||
if {$op eq "rename"} { |
|
||||||
# TBD - this does not actually work. The rename succeeds anyways |
|
||||||
error "MetOO classes may not be renamed" |
|
||||||
} else { |
|
||||||
$oldname destroy |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
proc metoo::introspect {type info args} { |
|
||||||
switch -exact -- $type { |
|
||||||
"object" { |
|
||||||
variable _objects |
|
||||||
switch -exact -- $info { |
|
||||||
"isa" { |
|
||||||
if {[llength $args] == 0 || [llength $args] > 2} { |
|
||||||
error "wrong # args: should be \"metoo::introspect $type $info OBJNAME ?CLASS?\"" |
|
||||||
} |
|
||||||
set objname [uplevel 1 [list namespace which -command [lindex $args 0]]] |
|
||||||
if {![info exists _objects($objname)]} { |
|
||||||
return 0 |
|
||||||
} |
|
||||||
if {[llength $args] == 1} { |
|
||||||
# No class specified |
|
||||||
return 1 |
|
||||||
} |
|
||||||
# passed classname assumed to be fully qualified |
|
||||||
set objclass [namespace parent $_objects($objname)] |
|
||||||
if {[string equal $objclass [lindex $args 1]]} { |
|
||||||
# Direct hit |
|
||||||
return 1 |
|
||||||
} |
|
||||||
|
|
||||||
# No direct hit, check ancestors |
|
||||||
if {[lindex $args 1] in [ancestors $objclass]} { |
|
||||||
return 1 |
|
||||||
} |
|
||||||
|
|
||||||
return 0 |
|
||||||
} |
|
||||||
|
|
||||||
"list" { |
|
||||||
if {[llength $args] > 1} { |
|
||||||
error "wrong # args: should be \"metoo::introspect $type $info ?CLASS?" |
|
||||||
} |
|
||||||
variable _objects |
|
||||||
if {[llength $args] == 0} { |
|
||||||
return [array names _objects] |
|
||||||
} |
|
||||||
set objs {} |
|
||||||
foreach obj [array names _objects] { |
|
||||||
if {[introspect object isa $obj [lindex $args 0]]} { |
|
||||||
lappend objs $obj |
|
||||||
} |
|
||||||
} |
|
||||||
return $objs |
|
||||||
} |
|
||||||
default { |
|
||||||
error "$info subcommand not supported for $type introspection" |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
"class" { |
|
||||||
switch -exact -- $info { |
|
||||||
"ancestors" { |
|
||||||
if {[llength $args] != 1} { |
|
||||||
error "wrong # args: should be \"metoo::introspect $type $info CLASSNAME" |
|
||||||
} |
|
||||||
return [ancestors [lindex $args 0]] |
|
||||||
} |
|
||||||
default { |
|
||||||
error "$info subcommand not supported for $type introspection" |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
default { |
|
||||||
error "$type introspection not supported" |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
proc metoo::ancestors {class_ns} { |
|
||||||
# Returns ancestors of a class |
|
||||||
|
|
||||||
set ancestors [list ] |
|
||||||
while {[info exists ${class_ns}::super]} { |
|
||||||
lappend ancestors [set class_ns [set ${class_ns}::super]] |
|
||||||
} |
|
||||||
|
|
||||||
return $ancestors |
|
||||||
} |
|
||||||
|
|
||||||
namespace eval metoo { namespace export class } |
|
||||||
|
|
||||||
# Simple sample class showing all capabilities. Anything not shown here will |
|
||||||
# probably not work. Call as "demo" to use metoo, or "demo oo" to use TclOO. |
|
||||||
# Output should be same in both cases. |
|
||||||
proc ::metoo::demo {{ns metoo}} { |
|
||||||
${ns}::class create Base { |
|
||||||
constructor {x y} { puts "Base constructor ([self object]): $x, $y" |
|
||||||
} |
|
||||||
method m {} { puts "Base::m called" } |
|
||||||
method n {args} { puts "Base::n called: [join $args {, }]"; my m } |
|
||||||
method unknown {methodname args} { puts "Base::unknown called for $methodname [join $args {, }]"} |
|
||||||
destructor { puts "Base::destructor ([self object])" } |
|
||||||
} |
|
||||||
|
|
||||||
${ns}::class create Derived { |
|
||||||
superclass Base |
|
||||||
constructor {x y} { puts "Derived constructor ([self object]): $x, $y" ; next $x $y } |
|
||||||
destructor { puts "Derived::destructor called ([self object])" ; next } |
|
||||||
method n {args} { puts "Derived::n ([self object]): [join $args {, }]"; next {*}$args} |
|
||||||
method put {val} {my variable var ; set var $val} |
|
||||||
method get {varname} {my variable var ; upvar 1 $varname retvar; set retvar $var} |
|
||||||
} |
|
||||||
|
|
||||||
Base create b dum dee; # Create named object |
|
||||||
Derived create d fee fi; # Create derived object |
|
||||||
set o [Derived new fo fum]; # Create autonamed object |
|
||||||
$o put 10; # Use of instance variable |
|
||||||
$o get v; # Verify correct frame level ... |
|
||||||
puts "v:$v"; # ...when calling methods |
|
||||||
b m; # Direct method |
|
||||||
b n; # Use of my to call another method |
|
||||||
$o m; # Inherited method |
|
||||||
$o n; # Overridden method chained to inherited |
|
||||||
$o nosuchmethod arg1 arg2; # Invoke unknown |
|
||||||
$o destroy; # Explicit destroy |
|
||||||
rename b ""; # Destroy through rename |
|
||||||
Base destroy; # Should destroy object d, Derived, Base |
|
||||||
} |
|
||||||
|
|
||||||
# Hack to work with the various build configuration. |
|
||||||
if {[info commands ::twapi::get_version] ne ""} { |
|
||||||
package provide metoo [::twapi::get_version -patchlevel] |
|
||||||
} |
|
||||||
@ -1,119 +0,0 @@ |
|||||||
# |
|
||||||
# Tcl package index file |
|
||||||
# |
|
||||||
|
|
||||||
namespace eval twapi { |
|
||||||
variable scriptdir |
|
||||||
proc set_scriptdir dir {variable scriptdir ; set scriptdir $dir} |
|
||||||
} |
|
||||||
|
|
||||||
package ifneeded twapi_base 4.7.2 \ |
|
||||||
[list load [file join $dir twapi472.dll] twapi_base] |
|
||||||
package ifneeded twapi_com 4.7.2 \ |
|
||||||
{load {} twapi_com} |
|
||||||
package ifneeded metoo 4.7.2 \ |
|
||||||
[list source [file join $dir metoo.tcl]] |
|
||||||
package ifneeded twapi_com 4.7.2 \ |
|
||||||
{load {} twapi_com} |
|
||||||
package ifneeded twapi_msi 4.7.2 \ |
|
||||||
[list source [file join $dir msi.tcl]] |
|
||||||
package ifneeded twapi_power 4.7.2 \ |
|
||||||
[list source [file join $dir power.tcl]] |
|
||||||
package ifneeded twapi_printer 4.7.2 \ |
|
||||||
[list source [file join $dir printer.tcl]] |
|
||||||
package ifneeded twapi_synch 4.7.2 \ |
|
||||||
[list source [file join $dir synch.tcl]] |
|
||||||
package ifneeded twapi_security 4.7.2 \ |
|
||||||
{load {} twapi_security} |
|
||||||
package ifneeded twapi_account 4.7.2 \ |
|
||||||
{load {} twapi_account} |
|
||||||
package ifneeded twapi_apputil 4.7.2 \ |
|
||||||
{load {} twapi_apputil} |
|
||||||
package ifneeded twapi_clipboard 4.7.2 \ |
|
||||||
{load {} twapi_clipboard} |
|
||||||
package ifneeded twapi_console 4.7.2 \ |
|
||||||
{load {} twapi_console} |
|
||||||
package ifneeded twapi_crypto 4.7.2 \ |
|
||||||
{load {} twapi_crypto} |
|
||||||
package ifneeded twapi_device 4.7.2 \ |
|
||||||
{load {} twapi_device} |
|
||||||
package ifneeded twapi_etw 4.7.2 \ |
|
||||||
{load {} twapi_etw} |
|
||||||
package ifneeded twapi_eventlog 4.7.2 \ |
|
||||||
{load {} twapi_eventlog} |
|
||||||
package ifneeded twapi_mstask 4.7.2 \ |
|
||||||
{load {} twapi_mstask} |
|
||||||
package ifneeded twapi_multimedia 4.7.2 \ |
|
||||||
{load {} twapi_multimedia} |
|
||||||
package ifneeded twapi_namedpipe 4.7.2 \ |
|
||||||
{load {} twapi_namedpipe} |
|
||||||
package ifneeded twapi_network 4.7.2 \ |
|
||||||
{load {} twapi_network} |
|
||||||
package ifneeded twapi_nls 4.7.2 \ |
|
||||||
{load {} twapi_nls} |
|
||||||
package ifneeded twapi_os 4.7.2 \ |
|
||||||
{load {} twapi_os} |
|
||||||
package ifneeded twapi_pdh 4.7.2 \ |
|
||||||
{load {} twapi_pdh} |
|
||||||
package ifneeded twapi_process 4.7.2 \ |
|
||||||
{load {} twapi_process} |
|
||||||
package ifneeded twapi_rds 4.7.2 \ |
|
||||||
{load {} twapi_rds} |
|
||||||
package ifneeded twapi_resource 4.7.2 \ |
|
||||||
{load {} twapi_resource} |
|
||||||
package ifneeded twapi_service 4.7.2 \ |
|
||||||
{load {} twapi_service} |
|
||||||
package ifneeded twapi_share 4.7.2 \ |
|
||||||
{load {} twapi_share} |
|
||||||
package ifneeded twapi_shell 4.7.2 \ |
|
||||||
{load {} twapi_shell} |
|
||||||
package ifneeded twapi_storage 4.7.2 \ |
|
||||||
{load {} twapi_storage} |
|
||||||
package ifneeded twapi_ui 4.7.2 \ |
|
||||||
{load {} twapi_ui} |
|
||||||
package ifneeded twapi_input 4.7.2 \ |
|
||||||
{load {} twapi_input} |
|
||||||
package ifneeded twapi_winsta 4.7.2 \ |
|
||||||
{load {} twapi_winsta} |
|
||||||
package ifneeded twapi_wmi 4.7.2 \ |
|
||||||
{load {} twapi_wmi} |
|
||||||
|
|
||||||
package ifneeded twapi 4.7.2 [subst { |
|
||||||
twapi::set_scriptdir [list $dir] |
|
||||||
package require twapi_base 4.7.2 |
|
||||||
source [list [file join $dir twapi_entry.tcl]] |
|
||||||
package require metoo 4.7.2 |
|
||||||
package require twapi_com 4.7.2 |
|
||||||
package require twapi_msi 4.7.2 |
|
||||||
package require twapi_power 4.7.2 |
|
||||||
package require twapi_printer 4.7.2 |
|
||||||
package require twapi_synch 4.7.2 |
|
||||||
package require twapi_security 4.7.2 |
|
||||||
package require twapi_account 4.7.2 |
|
||||||
package require twapi_apputil 4.7.2 |
|
||||||
package require twapi_clipboard 4.7.2 |
|
||||||
package require twapi_console 4.7.2 |
|
||||||
package require twapi_crypto 4.7.2 |
|
||||||
package require twapi_device 4.7.2 |
|
||||||
package require twapi_etw 4.7.2 |
|
||||||
package require twapi_eventlog 4.7.2 |
|
||||||
package require twapi_mstask 4.7.2 |
|
||||||
package require twapi_multimedia 4.7.2 |
|
||||||
package require twapi_namedpipe 4.7.2 |
|
||||||
package require twapi_network 4.7.2 |
|
||||||
package require twapi_nls 4.7.2 |
|
||||||
package require twapi_os 4.7.2 |
|
||||||
package require twapi_pdh 4.7.2 |
|
||||||
package require twapi_process 4.7.2 |
|
||||||
package require twapi_rds 4.7.2 |
|
||||||
package require twapi_resource 4.7.2 |
|
||||||
package require twapi_service 4.7.2 |
|
||||||
package require twapi_share 4.7.2 |
|
||||||
package require twapi_shell 4.7.2 |
|
||||||
package require twapi_storage 4.7.2 |
|
||||||
package require twapi_ui 4.7.2 |
|
||||||
package require twapi_input 4.7.2 |
|
||||||
package require twapi_winsta 4.7.2 |
|
||||||
package require twapi_wmi 4.7.2 |
|
||||||
package provide twapi 4.7.2 |
|
||||||
}] |
|
||||||
Binary file not shown.
@ -1,11 +0,0 @@ |
|||||||
# -*- tcl -*- |
|
||||||
namespace eval twapi { |
|
||||||
variable version |
|
||||||
set version(twapi) 4.7.2 |
|
||||||
variable patchlevel 4.7.2 |
|
||||||
variable package_name twapi |
|
||||||
variable dll_base_name twapi[string map {. {}} 4.7.2] |
|
||||||
variable scriptdir [file dirname [info script]] |
|
||||||
} |
|
||||||
|
|
||||||
source [file join $twapi::scriptdir twapi.tcl] |
|
||||||
@ -0,0 +1,8 @@ |
|||||||
|
# Compatibility wrapper for deprecated packages. |
||||||
|
## |
||||||
|
# Stages |
||||||
|
# [D1] Next Release - Noted deprecated, with redirection wrappers |
||||||
|
# [D2] Release After - Wrappers become Blockers, throwing error noting redirection |
||||||
|
# [D3] Release Beyond - All removed. |
||||||
|
## |
||||||
|
# Currently in deprecation [[NONE]] |
||||||
@ -0,0 +1,625 @@ |
|||||||
|
# aes.tcl - |
||||||
|
# |
||||||
|
# Copyright (c) 2005 Thorsten Schloermann |
||||||
|
# Copyright (c) 2005 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||||
|
# Copyright (c) 2013 Andreas Kupries |
||||||
|
# |
||||||
|
# A Tcl implementation of the Advanced Encryption Standard (US FIPS PUB 197) |
||||||
|
# |
||||||
|
# AES is a block cipher with a block size of 128 bits and a variable |
||||||
|
# key size of 128, 192 or 256 bits. |
||||||
|
# The algorithm works on each block as a 4x4 state array. There are 4 steps |
||||||
|
# in each round: |
||||||
|
# SubBytes a non-linear substitution step using a predefined S-box |
||||||
|
# ShiftRows cyclic transposition of rows in the state matrix |
||||||
|
# MixColumns transformation upon columns in the state matrix |
||||||
|
# AddRoundKey application of round specific sub-key |
||||||
|
# |
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# 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.5 9 |
||||||
|
|
||||||
|
namespace eval ::aes { |
||||||
|
variable uid |
||||||
|
if {![info exists uid]} { set uid 0 } |
||||||
|
|
||||||
|
namespace export aes |
||||||
|
|
||||||
|
# constants |
||||||
|
|
||||||
|
# S-box |
||||||
|
variable sbox { |
||||||
|
0x63 0x7c 0x77 0x7b 0xf2 0x6b 0x6f 0xc5 0x30 0x01 0x67 0x2b 0xfe 0xd7 0xab 0x76 |
||||||
|
0xca 0x82 0xc9 0x7d 0xfa 0x59 0x47 0xf0 0xad 0xd4 0xa2 0xaf 0x9c 0xa4 0x72 0xc0 |
||||||
|
0xb7 0xfd 0x93 0x26 0x36 0x3f 0xf7 0xcc 0x34 0xa5 0xe5 0xf1 0x71 0xd8 0x31 0x15 |
||||||
|
0x04 0xc7 0x23 0xc3 0x18 0x96 0x05 0x9a 0x07 0x12 0x80 0xe2 0xeb 0x27 0xb2 0x75 |
||||||
|
0x09 0x83 0x2c 0x1a 0x1b 0x6e 0x5a 0xa0 0x52 0x3b 0xd6 0xb3 0x29 0xe3 0x2f 0x84 |
||||||
|
0x53 0xd1 0x00 0xed 0x20 0xfc 0xb1 0x5b 0x6a 0xcb 0xbe 0x39 0x4a 0x4c 0x58 0xcf |
||||||
|
0xd0 0xef 0xaa 0xfb 0x43 0x4d 0x33 0x85 0x45 0xf9 0x02 0x7f 0x50 0x3c 0x9f 0xa8 |
||||||
|
0x51 0xa3 0x40 0x8f 0x92 0x9d 0x38 0xf5 0xbc 0xb6 0xda 0x21 0x10 0xff 0xf3 0xd2 |
||||||
|
0xcd 0x0c 0x13 0xec 0x5f 0x97 0x44 0x17 0xc4 0xa7 0x7e 0x3d 0x64 0x5d 0x19 0x73 |
||||||
|
0x60 0x81 0x4f 0xdc 0x22 0x2a 0x90 0x88 0x46 0xee 0xb8 0x14 0xde 0x5e 0x0b 0xdb |
||||||
|
0xe0 0x32 0x3a 0x0a 0x49 0x06 0x24 0x5c 0xc2 0xd3 0xac 0x62 0x91 0x95 0xe4 0x79 |
||||||
|
0xe7 0xc8 0x37 0x6d 0x8d 0xd5 0x4e 0xa9 0x6c 0x56 0xf4 0xea 0x65 0x7a 0xae 0x08 |
||||||
|
0xba 0x78 0x25 0x2e 0x1c 0xa6 0xb4 0xc6 0xe8 0xdd 0x74 0x1f 0x4b 0xbd 0x8b 0x8a |
||||||
|
0x70 0x3e 0xb5 0x66 0x48 0x03 0xf6 0x0e 0x61 0x35 0x57 0xb9 0x86 0xc1 0x1d 0x9e |
||||||
|
0xe1 0xf8 0x98 0x11 0x69 0xd9 0x8e 0x94 0x9b 0x1e 0x87 0xe9 0xce 0x55 0x28 0xdf |
||||||
|
0x8c 0xa1 0x89 0x0d 0xbf 0xe6 0x42 0x68 0x41 0x99 0x2d 0x0f 0xb0 0x54 0xbb 0x16 |
||||||
|
} |
||||||
|
# inverse S-box |
||||||
|
variable xobs { |
||||||
|
0x52 0x09 0x6a 0xd5 0x30 0x36 0xa5 0x38 0xbf 0x40 0xa3 0x9e 0x81 0xf3 0xd7 0xfb |
||||||
|
0x7c 0xe3 0x39 0x82 0x9b 0x2f 0xff 0x87 0x34 0x8e 0x43 0x44 0xc4 0xde 0xe9 0xcb |
||||||
|
0x54 0x7b 0x94 0x32 0xa6 0xc2 0x23 0x3d 0xee 0x4c 0x95 0x0b 0x42 0xfa 0xc3 0x4e |
||||||
|
0x08 0x2e 0xa1 0x66 0x28 0xd9 0x24 0xb2 0x76 0x5b 0xa2 0x49 0x6d 0x8b 0xd1 0x25 |
||||||
|
0x72 0xf8 0xf6 0x64 0x86 0x68 0x98 0x16 0xd4 0xa4 0x5c 0xcc 0x5d 0x65 0xb6 0x92 |
||||||
|
0x6c 0x70 0x48 0x50 0xfd 0xed 0xb9 0xda 0x5e 0x15 0x46 0x57 0xa7 0x8d 0x9d 0x84 |
||||||
|
0x90 0xd8 0xab 0x00 0x8c 0xbc 0xd3 0x0a 0xf7 0xe4 0x58 0x05 0xb8 0xb3 0x45 0x06 |
||||||
|
0xd0 0x2c 0x1e 0x8f 0xca 0x3f 0x0f 0x02 0xc1 0xaf 0xbd 0x03 0x01 0x13 0x8a 0x6b |
||||||
|
0x3a 0x91 0x11 0x41 0x4f 0x67 0xdc 0xea 0x97 0xf2 0xcf 0xce 0xf0 0xb4 0xe6 0x73 |
||||||
|
0x96 0xac 0x74 0x22 0xe7 0xad 0x35 0x85 0xe2 0xf9 0x37 0xe8 0x1c 0x75 0xdf 0x6e |
||||||
|
0x47 0xf1 0x1a 0x71 0x1d 0x29 0xc5 0x89 0x6f 0xb7 0x62 0x0e 0xaa 0x18 0xbe 0x1b |
||||||
|
0xfc 0x56 0x3e 0x4b 0xc6 0xd2 0x79 0x20 0x9a 0xdb 0xc0 0xfe 0x78 0xcd 0x5a 0xf4 |
||||||
|
0x1f 0xdd 0xa8 0x33 0x88 0x07 0xc7 0x31 0xb1 0x12 0x10 0x59 0x27 0x80 0xec 0x5f |
||||||
|
0x60 0x51 0x7f 0xa9 0x19 0xb5 0x4a 0x0d 0x2d 0xe5 0x7a 0x9f 0x93 0xc9 0x9c 0xef |
||||||
|
0xa0 0xe0 0x3b 0x4d 0xae 0x2a 0xf5 0xb0 0xc8 0xeb 0xbb 0x3c 0x83 0x53 0x99 0x61 |
||||||
|
0x17 0x2b 0x04 0x7e 0xba 0x77 0xd6 0x26 0xe1 0x69 0x14 0x63 0x55 0x21 0x0c 0x7d |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# aes::Init -- |
||||||
|
# |
||||||
|
# Initialise our AES state and calculate the key schedule. An initialization |
||||||
|
# vector is maintained in the state for modes that require one. The key must |
||||||
|
# be binary data of the correct size and the IV must be 16 bytes. |
||||||
|
# |
||||||
|
# Nk: columns of the key-array |
||||||
|
# Nr: number of rounds (depends on key-length) |
||||||
|
# Nb: columns of the text-block, is always 4 in AES |
||||||
|
# |
||||||
|
proc ::aes::Init {mode key iv} { |
||||||
|
switch -exact -- $mode { |
||||||
|
ecb - cbc { } |
||||||
|
cfb - ofb { |
||||||
|
return -code error "$mode mode not implemented" |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "invalid mode \"$mode\":\ |
||||||
|
must be one of ecb or cbc." |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set size [expr {[string length $key] << 3}] |
||||||
|
switch -exact -- $size { |
||||||
|
128 {set Nk 4; set Nr 10; set Nb 4} |
||||||
|
192 {set Nk 6; set Nr 12; set Nb 4} |
||||||
|
256 {set Nk 8; set Nr 14; set Nb 4} |
||||||
|
default { |
||||||
|
return -code error "invalid key size \"$size\":\ |
||||||
|
must be one of 128, 192 or 256." |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
variable uid |
||||||
|
set Key [namespace current]::[incr uid] |
||||||
|
upvar #0 $Key state |
||||||
|
if {[binary scan $iv Iu4 state(I)] != 1} { |
||||||
|
return -code error "invalid initialization vector: must be 16 bytes" |
||||||
|
} |
||||||
|
array set state [list M $mode K $key Nk $Nk Nr $Nr Nb $Nb W {}] |
||||||
|
ExpandKey $Key |
||||||
|
return $Key |
||||||
|
} |
||||||
|
|
||||||
|
# aes::Reset -- |
||||||
|
# |
||||||
|
# Reset the initialization vector for the specified key. This permits the |
||||||
|
# key to be reused for encryption or decryption without the expense of |
||||||
|
# re-calculating the key schedule. |
||||||
|
# |
||||||
|
proc ::aes::Reset {Key iv} { |
||||||
|
upvar #0 $Key state |
||||||
|
if {[binary scan $iv Iu4 state(I)] != 1} { |
||||||
|
return -code error "invalid initialization vector: must be 16 bytes" |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# aes::Final -- |
||||||
|
# |
||||||
|
# Clean up the key state |
||||||
|
# |
||||||
|
proc ::aes::Final {Key} { |
||||||
|
# FRINK: nocheck |
||||||
|
unset $Key |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# 5.1 Cipher: Encipher a single block of 128 bits. |
||||||
|
proc ::aes::EncryptBlock {Key block} { |
||||||
|
upvar #0 $Key state |
||||||
|
if {[binary scan $block Iu4 data] != 1} { |
||||||
|
return -code error "invalid block size: blocks must be 16 bytes" |
||||||
|
} |
||||||
|
|
||||||
|
if {$state(M) eq {cbc}} { |
||||||
|
# Loop unrolled. |
||||||
|
lassign $data d0 d1 d2 d3 |
||||||
|
lassign $state(I) s0 s1 s2 s3 |
||||||
|
set data [list \ |
||||||
|
[expr {$d0 ^ $s0}] \ |
||||||
|
[expr {$d1 ^ $s1}] \ |
||||||
|
[expr {$d2 ^ $s2}] \ |
||||||
|
[expr {$d3 ^ $s3}] ] |
||||||
|
} |
||||||
|
|
||||||
|
set data [AddRoundKey $Key 0 $data] |
||||||
|
for {set n 1} {$n < $state(Nr)} {incr n} { |
||||||
|
set data [AddRoundKey $Key $n [MixColumns [ShiftRows [SubBytes $data]]]] |
||||||
|
} |
||||||
|
set data [AddRoundKey $Key $n [ShiftRows [SubBytes $data]]] |
||||||
|
|
||||||
|
# Bug 2993029: |
||||||
|
# Force all elements of data into the 32bit range. |
||||||
|
# Loop unrolled |
||||||
|
set res [Clamp32 $data] |
||||||
|
|
||||||
|
set state(I) $res |
||||||
|
binary format Iu4 $res |
||||||
|
} |
||||||
|
|
||||||
|
# 5.3: Inverse Cipher: Decipher a single 128 bit block. |
||||||
|
proc ::aes::DecryptBlock {Key block} { |
||||||
|
upvar #0 $Key state |
||||||
|
if {[binary scan $block Iu4 data] != 1} { |
||||||
|
return -code error "invalid block size: block must be 16 bytes" |
||||||
|
} |
||||||
|
set iv $data |
||||||
|
|
||||||
|
set n $state(Nr) |
||||||
|
set data [AddRoundKey $Key $state(Nr) $data] |
||||||
|
for {incr n -1} {$n > 0} {incr n -1} { |
||||||
|
set data [InvMixColumns [AddRoundKey $Key $n [InvSubBytes [InvShiftRows $data]]]] |
||||||
|
} |
||||||
|
set data [AddRoundKey $Key $n [InvSubBytes [InvShiftRows $data]]] |
||||||
|
|
||||||
|
if {$state(M) eq {cbc}} { |
||||||
|
lassign $data d0 d1 d2 d3 |
||||||
|
lassign $state(I) s0 s1 s2 s3 |
||||||
|
set data [list \ |
||||||
|
[expr {($d0 ^ $s0) & 0xffffffff}] \ |
||||||
|
[expr {($d1 ^ $s1) & 0xffffffff}] \ |
||||||
|
[expr {($d2 ^ $s2) & 0xffffffff}] \ |
||||||
|
[expr {($d3 ^ $s3) & 0xffffffff}] ] |
||||||
|
} else { |
||||||
|
# Bug 2993029: |
||||||
|
# The integrated clamping we see above only happens for CBC mode. |
||||||
|
set data [Clamp32 $data] |
||||||
|
} |
||||||
|
|
||||||
|
set state(I) $iv |
||||||
|
binary format Iu4 $data |
||||||
|
} |
||||||
|
|
||||||
|
proc ::aes::Clamp32 {data} { |
||||||
|
# Force all elements into 32bit range. |
||||||
|
lassign $data d0 d1 d2 d3 |
||||||
|
list \ |
||||||
|
[expr {$d0 & 0xffffffff}] \ |
||||||
|
[expr {$d1 & 0xffffffff}] \ |
||||||
|
[expr {$d2 & 0xffffffff}] \ |
||||||
|
[expr {$d3 & 0xffffffff}] |
||||||
|
} |
||||||
|
|
||||||
|
# 5.2: KeyExpansion |
||||||
|
proc ::aes::ExpandKey {Key} { |
||||||
|
upvar #0 $Key state |
||||||
|
set Rcon [list 0x00000000 0x01000000 0x02000000 0x04000000 0x08000000 \ |
||||||
|
0x10000000 0x20000000 0x40000000 0x80000000 0x1b000000 \ |
||||||
|
0x36000000 0x6c000000 0xd8000000 0xab000000 0x4d000000] |
||||||
|
# Split the key into Nk big-endian words |
||||||
|
binary scan $state(K) I* W |
||||||
|
set max [expr {$state(Nb) * ($state(Nr) + 1)}] |
||||||
|
set i $state(Nk) |
||||||
|
set h [expr {$i - 1}] |
||||||
|
set j 0 |
||||||
|
for {} {$i < $max} {incr i; incr h; incr j} { |
||||||
|
set temp [lindex $W $h] |
||||||
|
if {($i % $state(Nk)) == 0} { |
||||||
|
set sub [SubWord [RotWord $temp]] |
||||||
|
set rc [lindex $Rcon [expr {$i/$state(Nk)}]] |
||||||
|
set temp [expr {$sub ^ $rc}] |
||||||
|
} elseif {$state(Nk) > 6 && ($i % $state(Nk)) == 4} { |
||||||
|
set temp [SubWord $temp] |
||||||
|
} |
||||||
|
lappend W [expr {[lindex $W $j] ^ $temp}] |
||||||
|
} |
||||||
|
set state(W) $W |
||||||
|
} |
||||||
|
|
||||||
|
# 5.2: Key Expansion: Apply S-box to each byte in the 32 bit word |
||||||
|
proc ::aes::SubWord {w} { |
||||||
|
variable sbox |
||||||
|
set s3 [lindex $sbox [expr {($w >> 24) & 255}]] |
||||||
|
set s2 [lindex $sbox [expr {($w >> 16) & 255}]] |
||||||
|
set s1 [lindex $sbox [expr {($w >> 8 ) & 255}]] |
||||||
|
set s0 [lindex $sbox [expr { $w & 255}]] |
||||||
|
return [expr {($s3 << 24) | ($s2 << 16) | ($s1 << 8) | $s0}] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::aes::InvSubWord {w} { |
||||||
|
variable xobs |
||||||
|
set s3 [lindex $xobs [expr {($w >> 24) & 255}]] |
||||||
|
set s2 [lindex $xobs [expr {($w >> 16) & 255}]] |
||||||
|
set s1 [lindex $xobs [expr {($w >> 8 ) & 255}]] |
||||||
|
set s0 [lindex $xobs [expr { $w & 255}]] |
||||||
|
return [expr {($s3 << 24) | ($s2 << 16) | ($s1 << 8) | $s0}] |
||||||
|
} |
||||||
|
|
||||||
|
# 5.2: Key Expansion: Rotate a 32bit word by 8 bits |
||||||
|
proc ::aes::RotWord {w} { |
||||||
|
return [expr {(($w << 8) | (($w >> 24) & 0xff)) & 0xffffffff}] |
||||||
|
} |
||||||
|
|
||||||
|
# 5.1.1: SubBytes() Transformation |
||||||
|
proc ::aes::SubBytes {words} { |
||||||
|
lassign $words w0 w1 w2 w3 |
||||||
|
list [SubWord $w0] [SubWord $w1] [SubWord $w2] [SubWord $w3] |
||||||
|
} |
||||||
|
|
||||||
|
# 5.3.2: InvSubBytes() Transformation |
||||||
|
proc ::aes::InvSubBytes {words} { |
||||||
|
lassign $words w0 w1 w2 w3 |
||||||
|
list [InvSubWord $w0] [InvSubWord $w1] [InvSubWord $w2] [InvSubWord $w3] |
||||||
|
} |
||||||
|
|
||||||
|
# 5.1.2: ShiftRows() Transformation |
||||||
|
proc ::aes::ShiftRows {words} { |
||||||
|
for {set n0 0} {$n0 < 4} {incr n0} { |
||||||
|
set n1 [expr {($n0 + 1) % 4}] |
||||||
|
set n2 [expr {($n0 + 2) % 4}] |
||||||
|
set n3 [expr {($n0 + 3) % 4}] |
||||||
|
lappend r [expr {( [lindex $words $n0] & 0xff000000) |
||||||
|
| ([lindex $words $n1] & 0x00ff0000) |
||||||
|
| ([lindex $words $n2] & 0x0000ff00) |
||||||
|
| ([lindex $words $n3] & 0x000000ff) |
||||||
|
}] |
||||||
|
} |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# 5.3.1: InvShiftRows() Transformation |
||||||
|
proc ::aes::InvShiftRows {words} { |
||||||
|
for {set n0 0} {$n0 < 4} {incr n0} { |
||||||
|
set n1 [expr {($n0 + 1) % 4}] |
||||||
|
set n2 [expr {($n0 + 2) % 4}] |
||||||
|
set n3 [expr {($n0 + 3) % 4}] |
||||||
|
lappend r [expr {( [lindex $words $n0] & 0xff000000) |
||||||
|
| ([lindex $words $n3] & 0x00ff0000) |
||||||
|
| ([lindex $words $n2] & 0x0000ff00) |
||||||
|
| ([lindex $words $n1] & 0x000000ff) |
||||||
|
}] |
||||||
|
} |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# 5.1.3: MixColumns() Transformation |
||||||
|
proc ::aes::MixColumns {words} { |
||||||
|
set r {} |
||||||
|
foreach w $words { |
||||||
|
set r0 [expr {(($w >> 24) & 255)}] |
||||||
|
set r1 [expr {(($w >> 16) & 255)}] |
||||||
|
set r2 [expr {(($w >> 8 ) & 255)}] |
||||||
|
set r3 [expr {( $w & 255)}] |
||||||
|
|
||||||
|
set s0 [expr {[GFMult2 $r0] ^ [GFMult3 $r1] ^ $r2 ^ $r3}] |
||||||
|
set s1 [expr {$r0 ^ [GFMult2 $r1] ^ [GFMult3 $r2] ^ $r3}] |
||||||
|
set s2 [expr {$r0 ^ $r1 ^ [GFMult2 $r2] ^ [GFMult3 $r3]}] |
||||||
|
set s3 [expr {[GFMult3 $r0] ^ $r1 ^ $r2 ^ [GFMult2 $r3]}] |
||||||
|
|
||||||
|
lappend r [expr {($s0 << 24) | ($s1 << 16) | ($s2 << 8) | $s3}] |
||||||
|
} |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# 5.3.3: InvMixColumns() Transformation |
||||||
|
proc ::aes::InvMixColumns {words} { |
||||||
|
set r {} |
||||||
|
foreach w $words { |
||||||
|
set r0 [expr {(($w >> 24) & 255)}] |
||||||
|
set r1 [expr {(($w >> 16) & 255)}] |
||||||
|
set r2 [expr {(($w >> 8 ) & 255)}] |
||||||
|
set r3 [expr {( $w & 255)}] |
||||||
|
|
||||||
|
set s0 [expr {[GFMult0e $r0] ^ [GFMult0b $r1] ^ [GFMult0d $r2] ^ [GFMult09 $r3]}] |
||||||
|
set s1 [expr {[GFMult09 $r0] ^ [GFMult0e $r1] ^ [GFMult0b $r2] ^ [GFMult0d $r3]}] |
||||||
|
set s2 [expr {[GFMult0d $r0] ^ [GFMult09 $r1] ^ [GFMult0e $r2] ^ [GFMult0b $r3]}] |
||||||
|
set s3 [expr {[GFMult0b $r0] ^ [GFMult0d $r1] ^ [GFMult09 $r2] ^ [GFMult0e $r3]}] |
||||||
|
|
||||||
|
lappend r [expr {($s0 << 24) | ($s1 << 16) | ($s2 << 8) | $s3}] |
||||||
|
} |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# 5.1.4: AddRoundKey() Transformation |
||||||
|
proc ::aes::AddRoundKey {Key round words} { |
||||||
|
upvar #0 $Key state |
||||||
|
set r {} |
||||||
|
set n [expr {$round * $state(Nb)}] |
||||||
|
foreach w $words { |
||||||
|
lappend r [expr {$w ^ [lindex $state(W) $n]}] |
||||||
|
incr n |
||||||
|
} |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# ::aes::GFMult* |
||||||
|
# |
||||||
|
# some needed functions for multiplication in a Galois-field |
||||||
|
# |
||||||
|
proc ::aes::GFMult2 {number} { |
||||||
|
# this is a tabular representation of xtime (multiplication by 2) |
||||||
|
# it is used instead of calculation to prevent timing attacks |
||||||
|
set xtime { |
||||||
|
0x00 0x02 0x04 0x06 0x08 0x0a 0x0c 0x0e 0x10 0x12 0x14 0x16 0x18 0x1a 0x1c 0x1e |
||||||
|
0x20 0x22 0x24 0x26 0x28 0x2a 0x2c 0x2e 0x30 0x32 0x34 0x36 0x38 0x3a 0x3c 0x3e |
||||||
|
0x40 0x42 0x44 0x46 0x48 0x4a 0x4c 0x4e 0x50 0x52 0x54 0x56 0x58 0x5a 0x5c 0x5e |
||||||
|
0x60 0x62 0x64 0x66 0x68 0x6a 0x6c 0x6e 0x70 0x72 0x74 0x76 0x78 0x7a 0x7c 0x7e |
||||||
|
0x80 0x82 0x84 0x86 0x88 0x8a 0x8c 0x8e 0x90 0x92 0x94 0x96 0x98 0x9a 0x9c 0x9e |
||||||
|
0xa0 0xa2 0xa4 0xa6 0xa8 0xaa 0xac 0xae 0xb0 0xb2 0xb4 0xb6 0xb8 0xba 0xbc 0xbe |
||||||
|
0xc0 0xc2 0xc4 0xc6 0xc8 0xca 0xcc 0xce 0xd0 0xd2 0xd4 0xd6 0xd8 0xda 0xdc 0xde |
||||||
|
0xe0 0xe2 0xe4 0xe6 0xe8 0xea 0xec 0xee 0xf0 0xf2 0xf4 0xf6 0xf8 0xfa 0xfc 0xfe |
||||||
|
0x1b 0x19 0x1f 0x1d 0x13 0x11 0x17 0x15 0x0b 0x09 0x0f 0x0d 0x03 0x01 0x07 0x05 |
||||||
|
0x3b 0x39 0x3f 0x3d 0x33 0x31 0x37 0x35 0x2b 0x29 0x2f 0x2d 0x23 0x21 0x27 0x25 |
||||||
|
0x5b 0x59 0x5f 0x5d 0x53 0x51 0x57 0x55 0x4b 0x49 0x4f 0x4d 0x43 0x41 0x47 0x45 |
||||||
|
0x7b 0x79 0x7f 0x7d 0x73 0x71 0x77 0x75 0x6b 0x69 0x6f 0x6d 0x63 0x61 0x67 0x65 |
||||||
|
0x9b 0x99 0x9f 0x9d 0x93 0x91 0x97 0x95 0x8b 0x89 0x8f 0x8d 0x83 0x81 0x87 0x85 |
||||||
|
0xbb 0xb9 0xbf 0xbd 0xb3 0xb1 0xb7 0xb5 0xab 0xa9 0xaf 0xad 0xa3 0xa1 0xa7 0xa5 |
||||||
|
0xdb 0xd9 0xdf 0xdd 0xd3 0xd1 0xd7 0xd5 0xcb 0xc9 0xcf 0xcd 0xc3 0xc1 0xc7 0xc5 |
||||||
|
0xfb 0xf9 0xff 0xfd 0xf3 0xf1 0xf7 0xf5 0xeb 0xe9 0xef 0xed 0xe3 0xe1 0xe7 0xe5 |
||||||
|
} |
||||||
|
lindex $xtime $number |
||||||
|
} |
||||||
|
|
||||||
|
proc ::aes::GFMult3 {number} { |
||||||
|
# multliply by 2 (via GFMult2) and add the number again on the result (via XOR) |
||||||
|
expr {$number ^ [GFMult2 $number]} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::aes::GFMult09 {number} { |
||||||
|
# 09 is: (02*02*02) + 01 |
||||||
|
expr {[GFMult2 [GFMult2 [GFMult2 $number]]] ^ $number} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::aes::GFMult0b {number} { |
||||||
|
# 0b is: (02*02*02) + 02 + 01 |
||||||
|
#return [expr [GFMult2 [GFMult2 [GFMult2 $number]]] ^ [GFMult2 $number] ^ $number] |
||||||
|
#set g0 [GFMult2 $number] |
||||||
|
expr {[GFMult09 $number] ^ [GFMult2 $number]} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::aes::GFMult0d {number} { |
||||||
|
# 0d is: (02*02*02) + (02*02) + 01 |
||||||
|
set temp [GFMult2 [GFMult2 $number]] |
||||||
|
expr {[GFMult2 $temp] ^ ($temp ^ $number)} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::aes::GFMult0e {number} { |
||||||
|
# 0e is: (02*02*02) + (02*02) + 02 |
||||||
|
set temp [GFMult2 [GFMult2 $number]] |
||||||
|
expr {[GFMult2 $temp] ^ ($temp ^ [GFMult2 $number])} |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# aes::Encrypt -- |
||||||
|
# |
||||||
|
# Encrypt a blocks of plain text and returns blocks of cipher text. |
||||||
|
# The input data must be a multiple of the block size (16). |
||||||
|
# |
||||||
|
proc ::aes::Encrypt {Key data} { |
||||||
|
set len [string length $data] |
||||||
|
if {($len % 16) != 0} { |
||||||
|
return -code error "invalid block size: AES requires 16 byte blocks" |
||||||
|
} |
||||||
|
|
||||||
|
set result {} |
||||||
|
for {set i 0} {$i < $len} {incr i 1} { |
||||||
|
set block [string range $data $i [incr i 15]] |
||||||
|
append result [EncryptBlock $Key $block] |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
# aes::Decrypt -- |
||||||
|
# |
||||||
|
# Decrypt blocks of cipher text and returns blocks of plain text. |
||||||
|
# The input data must be a multiple of the block size (16). |
||||||
|
# |
||||||
|
proc ::aes::Decrypt {Key data} { |
||||||
|
set len [string length $data] |
||||||
|
if {($len % 16) != 0} { |
||||||
|
return -code error "invalid block size: AES requires 16 byte blocks" |
||||||
|
} |
||||||
|
|
||||||
|
set result {} |
||||||
|
for {set i 0} {$i < $len} {incr i 1} { |
||||||
|
set block [string range $data $i [incr i 15]] |
||||||
|
append result [DecryptBlock $Key $block] |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# chan event handler for chunked file reading. |
||||||
|
# |
||||||
|
proc ::aes::Chunk {Key in {out {}} {chunksize 4096}} { |
||||||
|
upvar #0 $Key state |
||||||
|
|
||||||
|
#puts ||CHUNK.X||i=$in|o=$out|c=$chunksize|eof=[eof $in] |
||||||
|
|
||||||
|
if {[eof $in]} { |
||||||
|
chan event $in readable {} |
||||||
|
set state(reading) 0 |
||||||
|
} |
||||||
|
|
||||||
|
set data [read $in $chunksize] |
||||||
|
|
||||||
|
#puts ||CHUNK.R||i=$in|o=$out|c=$chunksize|eof=[eof $in]||[string length $data]||$data|| |
||||||
|
|
||||||
|
# Do nothing when data was read at all. |
||||||
|
if {$data eq {}} return |
||||||
|
|
||||||
|
if {[eof $in]} { |
||||||
|
#puts CHUNK.Z |
||||||
|
set data [Pad $data 16] |
||||||
|
} |
||||||
|
|
||||||
|
#puts ||CHUNK.P||i=$in|o=$out|c=$chunksize|eof=[eof $in]||[string length $data]||$data|| |
||||||
|
|
||||||
|
if {$out eq {}} { |
||||||
|
append state(output) [$state(cmd) $Key $data] |
||||||
|
} else { |
||||||
|
puts -nonewline $out [$state(cmd) $Key $data] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::aes::SetOneOf {lst item} { |
||||||
|
set ndx [lsearch -glob $lst "${item}*"] |
||||||
|
if {$ndx == -1} { |
||||||
|
set err [join $lst ", "] |
||||||
|
return -code error "invalid mode \"$item\": must be one of $err" |
||||||
|
} |
||||||
|
lindex $lst $ndx |
||||||
|
} |
||||||
|
|
||||||
|
proc ::aes::CheckSize {what size thing} { |
||||||
|
if {[string length $thing] != $size} { |
||||||
|
return -code error "invalid value for $what: must be $size bytes long" |
||||||
|
} |
||||||
|
return $thing |
||||||
|
} |
||||||
|
|
||||||
|
proc ::aes::Pad {data blocksize {fill \0}} { |
||||||
|
set len [string length $data] |
||||||
|
if {$len == 0} { |
||||||
|
set data [string repeat $fill $blocksize] |
||||||
|
} elseif {($len % $blocksize) != 0} { |
||||||
|
set pad [expr {$blocksize - ($len % $blocksize)}] |
||||||
|
append data [string repeat $fill $pad] |
||||||
|
} |
||||||
|
return $data |
||||||
|
} |
||||||
|
|
||||||
|
proc ::aes::Pop {varname {nth 0}} { |
||||||
|
upvar 1 $varname args |
||||||
|
set r [lindex $args $nth] |
||||||
|
set args [lreplace $args $nth $nth] |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
proc ::aes::aes {args} { |
||||||
|
array set opts {-dir encrypt -mode cbc -key {} -in {} -out {} -chunksize 4096 -hex 0} |
||||||
|
set opts(-iv) [string repeat \0 16] |
||||||
|
set modes {ecb cbc} |
||||||
|
set dirs {encrypt decrypt} |
||||||
|
while {([llength $args] > 1) && [string match -* [set option [lindex $args 0]]]} { |
||||||
|
switch -exact -- $option { |
||||||
|
-mode { set opts(-mode) [SetOneOf $modes [Pop args 1]] } |
||||||
|
-dir { set opts(-dir) [SetOneOf $dirs [Pop args 1]] } |
||||||
|
-iv { set opts(-iv) [CheckSize -iv 16 [Pop args 1]] } |
||||||
|
-key { set opts(-key) [Pop args 1] } |
||||||
|
-in { set opts(-in) [Pop args 1] } |
||||||
|
-out { set opts(-out) [Pop args 1] } |
||||||
|
-chunksize { set opts(-chunksize) [Pop args 1] } |
||||||
|
-hex { set opts(-hex) 1 } |
||||||
|
-- { Pop args ; break } |
||||||
|
default { |
||||||
|
set err [join [lsort [array names opts]] ", "] |
||||||
|
return -code error "bad option \"$option\":\ |
||||||
|
must be one of $err" |
||||||
|
} |
||||||
|
} |
||||||
|
Pop args |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-key) eq {}} { |
||||||
|
return -code error "no key provided: the -key option is required" |
||||||
|
} |
||||||
|
|
||||||
|
set r {} |
||||||
|
if {$opts(-in) eq {}} { |
||||||
|
|
||||||
|
if {[llength $args] != 1} { |
||||||
|
return -code error "wrong \# args:\ |
||||||
|
should be \"aes ?options...? -key keydata plaintext\"" |
||||||
|
} |
||||||
|
|
||||||
|
set data [Pad [lindex $args 0] 16] |
||||||
|
set Key [Init $opts(-mode) $opts(-key) $opts(-iv)] |
||||||
|
if {[string equal $opts(-dir) "encrypt"]} { |
||||||
|
set r [Encrypt $Key $data] |
||||||
|
} else { |
||||||
|
set r [Decrypt $Key $data] |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-out) ne {}} { |
||||||
|
puts -nonewline $opts(-out) $r |
||||||
|
set r {} |
||||||
|
} |
||||||
|
Final $Key |
||||||
|
|
||||||
|
} else { |
||||||
|
|
||||||
|
if {[llength $args] != 0} { |
||||||
|
return -code error "wrong \# args:\ |
||||||
|
should be \"aes ?options...? -key keydata -in channel\"" |
||||||
|
} |
||||||
|
|
||||||
|
set Key [Init $opts(-mode) $opts(-key) $opts(-iv)] |
||||||
|
|
||||||
|
set readcmd [list [namespace origin Chunk] \ |
||||||
|
$Key $opts(-in) $opts(-out) \ |
||||||
|
$opts(-chunksize)] |
||||||
|
|
||||||
|
upvar 1 $Key state |
||||||
|
set state(reading) 1 |
||||||
|
if {[string equal $opts(-dir) "encrypt"]} { |
||||||
|
set state(cmd) Encrypt |
||||||
|
} else { |
||||||
|
set state(cmd) Decrypt |
||||||
|
} |
||||||
|
set state(output) "" |
||||||
|
chan event $opts(-in) readable $readcmd |
||||||
|
if {[info commands ::tkwait] != {}} { |
||||||
|
tkwait variable [subst $Key](reading) |
||||||
|
} else { |
||||||
|
vwait [subst $Key](reading) |
||||||
|
} |
||||||
|
if {$opts(-out) == {}} { |
||||||
|
set r $state(output) |
||||||
|
} |
||||||
|
Final $Key |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-hex)} { |
||||||
|
binary scan $r H* r |
||||||
|
} |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
package provide aes 1.2.2 |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# Local variables: |
||||||
|
# mode: tcl |
||||||
|
# indent-tabs-mode: nil |
||||||
|
# End: |
||||||
@ -0,0 +1,5 @@ |
|||||||
|
if {![package vsatisfies [package provide Tcl] 8.5 9]} { |
||||||
|
# PRAGMA: returnok |
||||||
|
return |
||||||
|
} |
||||||
|
package ifneeded aes 1.2.2 [list source [file join $dir aes.tcl]] |
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,9 @@ |
|||||||
|
# pkgIndex.tcl -- |
||||||
|
# Copyright (c) 2006 Darren New |
||||||
|
# This is for the Amazon S3 web service packages. |
||||||
|
|
||||||
|
if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} |
||||||
|
|
||||||
|
package ifneeded xsxp 1.1 [list source [file join $dir xsxp.tcl]] |
||||||
|
package ifneeded S3 1.0.5 [list source [file join $dir S3.tcl]] |
||||||
|
|
||||||
@ -0,0 +1,254 @@ |
|||||||
|
# xsxp.tcl -- |
||||||
|
# |
||||||
|
###Abstract |
||||||
|
# Extremely Simple XML Parser |
||||||
|
# |
||||||
|
# This is pretty lame, but I needed something like this for S3, |
||||||
|
# and at the time, TclDOM would not work with the new 8.5 Tcl |
||||||
|
# due to version number problems. |
||||||
|
# |
||||||
|
# In addition, this is a pure-value implementation. There is no |
||||||
|
# garbage to clean up in the event of a thrown error, for example. |
||||||
|
# This simplifies the code for sufficiently small XML documents, |
||||||
|
# which is what Amazon's S3 guarantees. |
||||||
|
# |
||||||
|
###Copyright |
||||||
|
# Copyright (c) 2006 Darren New. |
||||||
|
# All Rights Reserved. |
||||||
|
# NO WARRANTIES OF ANY TYPE ARE PROVIDED. |
||||||
|
# COPYING OR USE INDEMNIFIES THE AUTHOR IN ALL WAYS. |
||||||
|
# See the license terms in LICENSE.txt |
||||||
|
# |
||||||
|
###Revision String |
||||||
|
# SCCS: %Z% %M% %I% %E% %U% |
||||||
|
|
||||||
|
# xsxp::parse $xml |
||||||
|
# Returns a parsed XML, or PXML. A pxml is a list. |
||||||
|
# The first element is the name of the tag. |
||||||
|
# The second element is a list of name/value pairs of the |
||||||
|
# associated attribues, if any. |
||||||
|
# The third thru final values are recursively PXML values. |
||||||
|
# If the first element (element zero, that is) is "%PCDATA", |
||||||
|
# then the attributes will be emtpy and the third element |
||||||
|
# will be the text of the element. |
||||||
|
|
||||||
|
# xsxp::fetch $pxml $path ?$part? |
||||||
|
# $pxml is a parsed XML, as returned from xsxp::parse. |
||||||
|
# $path is a list of elements. Each element is the name of |
||||||
|
# a child to look up, optionally followed by a hash ("#") |
||||||
|
# and a string of digits. An emtpy list or an initial empty |
||||||
|
# element selects $pxml. If no hash sign is present, the |
||||||
|
# behavior is as if "#0" had been appended to that element. |
||||||
|
# An element of $path scans the children at the indicated |
||||||
|
# level for the n'th instance of a child whose tag matches |
||||||
|
# the part of the element before the hash sign. If an element |
||||||
|
# is simply "#" followed by digits, that indexed child is |
||||||
|
# selected, regardless of the tags in the children. So |
||||||
|
# an element of #3 will always select the fourth child |
||||||
|
# of the node under consideration. |
||||||
|
# $part defaults to %ALL. It can be one of the following: |
||||||
|
# %ALL - returns the entire selected element. |
||||||
|
# %TAGNAME - returns lindex 0 of the selected element. |
||||||
|
# %ATTRIBUTES - returns lindex 1 of the selected element. |
||||||
|
# %CHILDREN - returns lrange 2 through end of the selected element, |
||||||
|
# resulting in a list of elements being returned. |
||||||
|
# %PCDATA - returns a concatenation of all the bodies of |
||||||
|
# direct children of this node whose tag is %PCDATA. |
||||||
|
# Throws an error if no such children are found. That |
||||||
|
# is, part=%PCDATA means return the textual content found |
||||||
|
# in that node but not its children nodes. |
||||||
|
# %PCDATA? - like %PCDATA, but returns an empty string if |
||||||
|
# no PCDATA is found. |
||||||
|
|
||||||
|
# xsxp::fetchall $pxml_list $path ?$part? |
||||||
|
# Iterates over each PXML in $pxml_list, selecting the indicated |
||||||
|
# path from it, building a new list with the selected data, and |
||||||
|
# returning that new list. For example, $pxml_list might be |
||||||
|
# the %CHILDREN of a particular element, and the $path and $part |
||||||
|
# might select from each child a sub-element in which we're interested. |
||||||
|
|
||||||
|
# xsxp::only $pxml $tagname |
||||||
|
# Iterates over the direct children of $pxml and selects only |
||||||
|
# those with $tagname as their tag. Returns a list of matching |
||||||
|
# elements. |
||||||
|
|
||||||
|
# xsxp::prettyprint $pxml |
||||||
|
# Outputs to stdout a nested-list notation of the parsed XML. |
||||||
|
|
||||||
|
package require xml |
||||||
|
package provide xsxp 1.1 |
||||||
|
|
||||||
|
namespace eval xsxp { |
||||||
|
|
||||||
|
variable Stack |
||||||
|
variable Cur |
||||||
|
|
||||||
|
proc Characterdatacommand {characterdata} { |
||||||
|
variable Cur |
||||||
|
# puts "characterdatacommand $characterdata" |
||||||
|
set x [list %PCDATA {} $characterdata] |
||||||
|
lappend Cur $x |
||||||
|
} |
||||||
|
|
||||||
|
proc Elementstartcommand {name attlist args} { |
||||||
|
# puts "elementstart $name {$attlist} $args" |
||||||
|
variable Stack |
||||||
|
variable Cur |
||||||
|
lappend Stack $Cur |
||||||
|
set Cur [list $name $attlist] |
||||||
|
} |
||||||
|
|
||||||
|
proc Elementendcommand {args} { |
||||||
|
# puts "elementend $args" |
||||||
|
variable Stack |
||||||
|
variable Cur |
||||||
|
set x [lindex $Stack end] |
||||||
|
lappend x $Cur |
||||||
|
set Cur $x |
||||||
|
set Stack [lrange $Stack 0 end-1] |
||||||
|
} |
||||||
|
|
||||||
|
proc parse {xml} { |
||||||
|
variable Cur |
||||||
|
variable Stack |
||||||
|
set Cur {} |
||||||
|
set Stack {} |
||||||
|
set parser [::xml::parser \ |
||||||
|
-characterdatacommand [namespace code Characterdatacommand] \ |
||||||
|
-elementstartcommand [namespace code Elementstartcommand] \ |
||||||
|
-elementendcommand [namespace code Elementendcommand] \ |
||||||
|
-ignorewhitespace 1 -final 1 |
||||||
|
] |
||||||
|
$parser parse $xml |
||||||
|
$parser free |
||||||
|
# The following line is needed because the close of the last element |
||||||
|
# appends the outermost element to the item on the top of the stack. |
||||||
|
# Since there's nothing on the top of the stack at the close of the |
||||||
|
# last element, we append the current element to an empty list. |
||||||
|
# In essence, since we don't really have a terminating condition |
||||||
|
# on the recursion, an empty stack is still treated like an element. |
||||||
|
set Cur [lindex $Cur 0] |
||||||
|
set Cur [Normalize $Cur] |
||||||
|
return $Cur |
||||||
|
} |
||||||
|
|
||||||
|
proc Normalize {pxml} { |
||||||
|
# This iterates over pxml recursively, finding entries that |
||||||
|
# start with multiple %PCDATA elements, and coalesces their |
||||||
|
# content, so if an element contains only %PCDATA, it is |
||||||
|
# guaranteed to have only one child. |
||||||
|
# Not really necessary, given definition of part=%PCDATA |
||||||
|
# However, it makes pretty-prints nicer (for AWS at least) |
||||||
|
# and ends up with smaller lists. I have no idea why they |
||||||
|
# would put quotes around an MD5 hash in hex, tho. |
||||||
|
set dupl 1 |
||||||
|
while {$dupl} { |
||||||
|
set first [lindex $pxml 2] |
||||||
|
set second [lindex $pxml 3] |
||||||
|
if {[lindex $first 0] eq "%PCDATA" && [lindex $second 0] eq "%PCDATA"} { |
||||||
|
set repl [list %PCDATA {} [lindex $first 2][lindex $second 2]] |
||||||
|
set pxml [lreplace $pxml 2 3 $repl] |
||||||
|
} else { |
||||||
|
set dupl 0 |
||||||
|
for {set i 2} {$i < [llength $pxml]} {incr i} { |
||||||
|
set pxml [lreplace $pxml $i $i [Normalize [lindex $pxml $i]]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $pxml |
||||||
|
} |
||||||
|
|
||||||
|
proc prettyprint {pxml {chan stdout} {indent 0}} { |
||||||
|
puts -nonewline $chan [string repeat " " $indent] |
||||||
|
if {[lindex $pxml 0] eq "%PCDATA"} { |
||||||
|
puts $chan "%PCDATA: [lindex $pxml 2]" |
||||||
|
return |
||||||
|
} |
||||||
|
puts -nonewline $chan "[lindex $pxml 0]" |
||||||
|
foreach {name val} [lindex $pxml 1] { |
||||||
|
puts -nonewline $chan " $name='$val'" |
||||||
|
} |
||||||
|
puts $chan "" |
||||||
|
foreach node [lrange $pxml 2 end] { |
||||||
|
prettyprint $node $chan [expr $indent+1] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc fetch {pxml path {part %ALL}} { |
||||||
|
set path [string trim $path /] |
||||||
|
if {-1 != [string first / $path]} { |
||||||
|
set path [split $path /] |
||||||
|
} |
||||||
|
foreach element $path { |
||||||
|
if {$pxml eq ""} {return ""} |
||||||
|
foreach {tag count} [split $element #] { |
||||||
|
if {$tag ne ""} { |
||||||
|
if {$count eq ""} {set count 0} |
||||||
|
set pxml [lrange $pxml 2 end] |
||||||
|
while {0 <= $count && 0 != [llength $pxml]} { |
||||||
|
if {$tag eq [lindex $pxml 0 0]} { |
||||||
|
incr count -1 |
||||||
|
if {$count < 0} { |
||||||
|
# We're done. Go on to next element. |
||||||
|
set pxml [lindex $pxml 0] |
||||||
|
} else { |
||||||
|
# Not done yet. Throw this away. |
||||||
|
set pxml [lrange $pxml 1 end] |
||||||
|
} |
||||||
|
} else { |
||||||
|
# Not what we want. |
||||||
|
set pxml [lrange $pxml 1 end] |
||||||
|
} |
||||||
|
} |
||||||
|
} else { # tag eq "" |
||||||
|
if {$count eq ""} { |
||||||
|
# Just select whole $pxml |
||||||
|
} else { |
||||||
|
set pxml [lindex $pxml [expr {2+$count}]] |
||||||
|
} |
||||||
|
} |
||||||
|
break |
||||||
|
} ; # done the foreach [split] loop |
||||||
|
} ; # done all the elements. |
||||||
|
if {$part eq "%ALL"} {return $pxml} |
||||||
|
if {$part eq "%ATTRIBUTES"} {return [lindex $pxml 1]} |
||||||
|
if {$part eq "%TAGNAME"} {return [lindex $pxml 0]} |
||||||
|
if {$part eq "%CHILDREN"} {return [lrange $pxml 2 end]} |
||||||
|
if {$part eq "%PCDATA" || $part eq "%PCDATA?"} { |
||||||
|
set res "" ; set found 0 |
||||||
|
foreach elem [lrange $pxml 2 end] { |
||||||
|
if {"%PCDATA" eq [lindex $elem 0]} { |
||||||
|
append res [lindex $elem 2] |
||||||
|
set found 1 |
||||||
|
} |
||||||
|
} |
||||||
|
if {$found || $part eq "%PCDATA?"} { |
||||||
|
return $res |
||||||
|
} else { |
||||||
|
error "xsxp::fetch did not find requested PCDATA" |
||||||
|
} |
||||||
|
} |
||||||
|
return $pxml ; # Don't know what he's after |
||||||
|
} |
||||||
|
|
||||||
|
proc only {pxml tag} { |
||||||
|
set res {} |
||||||
|
foreach element [lrange $pxml 2 end] { |
||||||
|
if {[lindex $element 0] eq $tag} { |
||||||
|
lappend res $element |
||||||
|
} |
||||||
|
} |
||||||
|
return $res |
||||||
|
} |
||||||
|
|
||||||
|
proc fetchall {pxml_list path {part %ALL}} { |
||||||
|
set res [list] |
||||||
|
foreach pxml $pxml_list { |
||||||
|
lappend res [fetch $pxml $path $part] |
||||||
|
} |
||||||
|
return $res |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
namespace export xsxp parse prettyprint fetch |
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,4 @@ |
|||||||
|
# Tcl package index file, version 1.1 |
||||||
|
|
||||||
|
if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} |
||||||
|
package ifneeded asn 0.8.5 [list source [file join $dir asn.tcl]] |
||||||
@ -0,0 +1,180 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# This code is hereby put into the public domain. |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Overview |
||||||
|
# Base32 encoding and decoding of small strings. |
||||||
|
# |
||||||
|
# Management code for switching between Tcl and C accelerated |
||||||
|
# implementations. |
||||||
|
|
||||||
|
# @mdgen EXCLUDE: base32_c.tcl |
||||||
|
|
||||||
|
package require Tcl 8.5 9 |
||||||
|
|
||||||
|
namespace eval ::base32 {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Management of base32 std implementations. |
||||||
|
|
||||||
|
# ::base32::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 ::base32::LoadAccelerator {key} { |
||||||
|
variable accel |
||||||
|
set isok 0 |
||||||
|
switch -exact -- $key { |
||||||
|
critcl { |
||||||
|
# Critcl implementation of base32 requires Tcl 8.4. |
||||||
|
if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} |
||||||
|
if {[catch {package require tcllibc}]} {return 0} |
||||||
|
set isok [llength [info commands ::base32::critcl_encode]] |
||||||
|
} |
||||||
|
tcl { |
||||||
|
variable selfdir |
||||||
|
if {[catch {source [file join $selfdir base32_tcl.tcl]}]} {return 0} |
||||||
|
set isok [llength [info commands ::base32::tcl_encode]] |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "invalid accelerator $key:\ |
||||||
|
must be one of [join [KnownImplementations] {, }]" |
||||||
|
} |
||||||
|
} |
||||||
|
set accel($key) $isok |
||||||
|
return $isok |
||||||
|
} |
||||||
|
|
||||||
|
# ::base32::SwitchTo -- |
||||||
|
# |
||||||
|
# Activates a loaded named implementation. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# key Name of the implementation to activate. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::base32::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 ""]} { |
||||||
|
foreach c {encode decode} { |
||||||
|
rename ::base32::$c ::base32::${loaded}_$c |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Activate the new implementation, if there is any. |
||||||
|
|
||||||
|
if {![string equal $key ""]} { |
||||||
|
foreach c {encode decode} { |
||||||
|
rename ::base32::${key}_$c ::base32::$c |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Remember the active implementation, for deactivation by future |
||||||
|
# switches. |
||||||
|
|
||||||
|
set loaded $key |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ::base32::Implementations -- |
||||||
|
# |
||||||
|
# Determines which implementations are |
||||||
|
# present, i.e. loaded. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# None. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A list of implementation keys. |
||||||
|
|
||||||
|
proc ::base32::Implementations {} { |
||||||
|
variable accel |
||||||
|
set res {} |
||||||
|
foreach n [array names accel] { |
||||||
|
if {!$accel($n)} continue |
||||||
|
lappend res $n |
||||||
|
} |
||||||
|
return $res |
||||||
|
} |
||||||
|
|
||||||
|
# ::base32::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 ::base32::KnownImplementations {} { |
||||||
|
return {critcl tcl} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::base32::Names {} { |
||||||
|
return { |
||||||
|
critcl {tcllibc based} |
||||||
|
tcl {pure Tcl} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Initialization: Data structures. |
||||||
|
|
||||||
|
namespace eval ::base32 { |
||||||
|
variable selfdir [file dirname [info script]] |
||||||
|
variable loaded {} |
||||||
|
|
||||||
|
variable accel |
||||||
|
array set accel {tcl 0 critcl 0} |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Initialization: Choose an implementation, |
||||||
|
## most prefered first. Loads only one of the |
||||||
|
## possible implementations. And activates it. |
||||||
|
|
||||||
|
namespace eval ::base32 { |
||||||
|
variable e |
||||||
|
foreach e [KnownImplementations] { |
||||||
|
if {[LoadAccelerator $e]} { |
||||||
|
SwitchTo $e |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
unset e |
||||||
|
|
||||||
|
namespace export encode decode |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide base32 0.2 |
||||||
@ -0,0 +1,254 @@ |
|||||||
|
# base32c.tcl -- |
||||||
|
# |
||||||
|
# Implementation of a base32 (std) de/encoder for Tcl. |
||||||
|
# |
||||||
|
# Public domain |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: base32_c.tcl,v 1.3 2008/01/28 22:58:18 andreas_kupries Exp $ |
||||||
|
|
||||||
|
package require critcl |
||||||
|
package require Tcl 8.5 9 |
||||||
|
|
||||||
|
namespace eval ::base32 { |
||||||
|
# Supporting code for the main command. |
||||||
|
catch { |
||||||
|
#critcl::cheaders -g |
||||||
|
#critcl::debug memory symbols |
||||||
|
} |
||||||
|
|
||||||
|
# Main commands, encoder & decoder |
||||||
|
|
||||||
|
critcl::ccommand critcl_encode {dummy interp objc objv} { |
||||||
|
/* Syntax -*- c -*- |
||||||
|
* critcl_encode string |
||||||
|
*/ |
||||||
|
|
||||||
|
unsigned char* buf; |
||||||
|
Tcl_Size nbuf; |
||||||
|
|
||||||
|
unsigned char* out; |
||||||
|
unsigned char* at; |
||||||
|
int nout; |
||||||
|
|
||||||
|
/* |
||||||
|
* The array used for encoding |
||||||
|
*/ /* 123456789 123456789 123456789 12 */ |
||||||
|
static const char map[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"; |
||||||
|
|
||||||
|
#define USAGEE "bitstring" |
||||||
|
|
||||||
|
if (objc != 2) { |
||||||
|
Tcl_WrongNumArgs (interp, 1, objv, USAGEE); /* OK tcl9 */ |
||||||
|
return TCL_ERROR; |
||||||
|
} |
||||||
|
|
||||||
|
buf = Tcl_GetBytesFromObj (interp, objv[1], &nbuf); /* OK tcl9 */ |
||||||
|
if (buf == NULL) return TCL_ERROR; |
||||||
|
nout = ((nbuf+4)/5)*8; |
||||||
|
out = (unsigned char*) Tcl_Alloc (nout*sizeof(char)); |
||||||
|
|
||||||
|
for (at = out; nbuf >= 5; nbuf -= 5, buf += 5) { |
||||||
|
*(at++) = map [ (buf[0]>>3) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[1]>>1) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[3]>>2) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[3]<<3) | (buf[4]>>5)) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[4]) ]; |
||||||
|
} |
||||||
|
if (nbuf > 0) { |
||||||
|
/* Process partials at end. */ |
||||||
|
switch (nbuf) { |
||||||
|
case 1: |
||||||
|
/* |01234567| 2, padding 6 |
||||||
|
* xxxxx |
||||||
|
* xxx 00 |
||||||
|
*/ |
||||||
|
|
||||||
|
*(at++) = map [ (buf[0]>>3) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[0]<<2) ]; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
break; |
||||||
|
case 2: /* x3/=4 */ |
||||||
|
/* |01234567|01234567| 4, padding 4 |
||||||
|
* xxxxx |
||||||
|
* xxx xx |
||||||
|
* xxxxx |
||||||
|
* x 0000 |
||||||
|
*/ |
||||||
|
|
||||||
|
*(at++) = map [ (buf[0]>>3) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[1]>>1) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[1]<<4) ]; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
break; |
||||||
|
case 3: |
||||||
|
/* |01234567|01234567|01234567| 5, padding 3 |
||||||
|
* xxxxx |
||||||
|
* xxx xx |
||||||
|
* xxxxx |
||||||
|
* x xxxx |
||||||
|
* xxxx 0 |
||||||
|
*/ |
||||||
|
|
||||||
|
*(at++) = map [ (buf[0]>>3) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[1]>>1) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[2]<<1) ]; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
break; |
||||||
|
case 4: |
||||||
|
/* |01234567|01234567|01234567|012334567| 7, padding 1 |
||||||
|
* xxxxx |
||||||
|
* xxx xx |
||||||
|
* xxxxx |
||||||
|
* x xxxx |
||||||
|
* xxxx |
||||||
|
* xxxxx |
||||||
|
* xxxx 0 |
||||||
|
*/ |
||||||
|
|
||||||
|
*(at++) = map [ (buf[0]>>3) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[1]>>1) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[3]>>2) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[3]<<3) ]; |
||||||
|
*(at++) = '='; |
||||||
|
break; |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
Tcl_SetObjResult (interp, Tcl_NewStringObj ((char*)out, nout)); /* OK tcl9 */ |
||||||
|
Tcl_Free ((char*) out); |
||||||
|
return TCL_OK; |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
critcl::ccommand critcl_decode {dummy interp objc objv} { |
||||||
|
/* Syntax -*- c -*- |
||||||
|
* critcl_decode estring |
||||||
|
*/ |
||||||
|
|
||||||
|
unsigned char* buf; |
||||||
|
Tcl_Size nbuf; |
||||||
|
|
||||||
|
unsigned char* out; |
||||||
|
unsigned char* at; |
||||||
|
unsigned char x [8]; |
||||||
|
int nout; |
||||||
|
|
||||||
|
int i, j, a, pad, nx; |
||||||
|
|
||||||
|
/* |
||||||
|
* An array for translating single base-32 characters into a value. |
||||||
|
* Disallowed input characters have a value of 64. Upper and lower |
||||||
|
* case is the same. Only 128 chars, as everything above char(127) |
||||||
|
* is 64. |
||||||
|
*/ |
||||||
|
static const char map [] = { |
||||||
|
/* \00 */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, |
||||||
|
/* DLE */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, |
||||||
|
/* SPC */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, |
||||||
|
/* '0' */ 64, 64, 26, 27, 28, 29, 30, 31, 64, 64, 64, 64, 64, 64, 64, 64, |
||||||
|
/* '@' */ 64, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, |
||||||
|
/* 'P' */ 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 64, 64, 64, 64, 64, |
||||||
|
/* '`' */ 64, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, |
||||||
|
/* 'p' */ 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 64, 64, 64, 64, 64 |
||||||
|
}; |
||||||
|
|
||||||
|
#define USAGED "estring" |
||||||
|
|
||||||
|
if (objc != 2) { |
||||||
|
Tcl_WrongNumArgs (interp, 1, objv, USAGED); /* OK tcl9 */ |
||||||
|
return TCL_ERROR; |
||||||
|
} |
||||||
|
|
||||||
|
buf = (unsigned char*) Tcl_GetStringFromObj (objv[1], &nbuf); /* OK tcl9 */ |
||||||
|
|
||||||
|
if (nbuf % 8) { |
||||||
|
Tcl_SetObjResult (interp, Tcl_NewStringObj ("Length is not a multiple of 8", -1)); /* OK tcl9 */ |
||||||
|
return TCL_ERROR; |
||||||
|
} |
||||||
|
|
||||||
|
nout = (nbuf/8)*5 *TCL_UTF_MAX; |
||||||
|
out = (unsigned char*) Tcl_Alloc (nout*sizeof(char)); |
||||||
|
|
||||||
|
#define HIGH(x) (((x) & 0x80) != 0) |
||||||
|
#define BADC(x) ((x) == 64) |
||||||
|
#define BADCHAR(a,j) (HIGH ((a)) || BADC (x [(j)] = map [(a)])) |
||||||
|
|
||||||
|
for (pad = 0, i=0, at = out; i < nbuf; i += 8, buf += 8){ |
||||||
|
for (j=0; j < 8; j++){ |
||||||
|
a = buf [j]; |
||||||
|
|
||||||
|
if (a == '=') { |
||||||
|
x[j] = 0; |
||||||
|
pad++; |
||||||
|
continue; |
||||||
|
} else if (pad) { |
||||||
|
char msg [120]; |
||||||
|
sprintf (msg, |
||||||
|
"Invalid character at index %d: \"=\" (padding found in the middle of the input)", |
||||||
|
j-1); |
||||||
|
Tcl_Free ((char*) out); |
||||||
|
Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */ |
||||||
|
return TCL_ERROR; |
||||||
|
} |
||||||
|
|
||||||
|
if (BADCHAR (a,j)) { |
||||||
|
char msg [100]; |
||||||
|
sprintf (msg,"Invalid character at index %d: \"%c\"",j,a); |
||||||
|
Tcl_Free ((char*) out); |
||||||
|
Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */ |
||||||
|
return TCL_ERROR; |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
*(at++) = (x[0]<<3) | (x[1]>>2) ; |
||||||
|
*(at++) = (x[1]<<6) | (x[2]<<1) | (x[3]>>4); |
||||||
|
*(at++) = (x[3]<<4) | (x[4]>>1) ; |
||||||
|
*(at++) = (x[4]<<7) | (x[5]<<2) | (x[6]>>3); |
||||||
|
*(at++) = (x[6]<<5) | x[7] ; |
||||||
|
} |
||||||
|
|
||||||
|
if (pad) { |
||||||
|
if (pad == 1) { |
||||||
|
at -= 1; |
||||||
|
} else if (pad == 3) { |
||||||
|
at -= 2; |
||||||
|
} else if (pad == 4) { |
||||||
|
at -= 3; |
||||||
|
} else if (pad == 6) { |
||||||
|
at -= 4; |
||||||
|
} else { |
||||||
|
char msg [100]; |
||||||
|
sprintf (msg,"Invalid padding of length %d",pad); |
||||||
|
Tcl_Free ((char*) out); |
||||||
|
Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */ |
||||||
|
return TCL_ERROR; |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out)); /* OK tcl9 */ |
||||||
|
Tcl_Free ((char*) out); |
||||||
|
return TCL_OK; |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
@ -0,0 +1,73 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# This code is hereby put into the public domain. |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Overview |
||||||
|
# Base32 encoding and decoding of small strings. |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Notes |
||||||
|
|
||||||
|
# A binary string is split into groups of 5 bits (2^5 == 32), and each |
||||||
|
# group is converted into a printable character as is specified in RFC |
||||||
|
# 3548. |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requisites |
||||||
|
|
||||||
|
package require base32::core |
||||||
|
namespace eval ::base32 {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## API & Implementation |
||||||
|
|
||||||
|
proc ::base32::tcl_encode {bitstring} { |
||||||
|
variable forward |
||||||
|
|
||||||
|
binary scan $bitstring B* bits |
||||||
|
set len [string length $bits] |
||||||
|
set rem [expr {$len % 5}] |
||||||
|
if {$rem} {append bits =/$rem} |
||||||
|
#puts "($bitstring) => <$bits>" |
||||||
|
|
||||||
|
return [string map $forward $bits] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::base32::tcl_decode {estring} { |
||||||
|
variable backward |
||||||
|
variable invalid |
||||||
|
|
||||||
|
if {![core::valid $estring $invalid msg]} { |
||||||
|
return -code error $msg |
||||||
|
} |
||||||
|
#puts "I<$estring>" |
||||||
|
#puts "M<[string map $backward $estring]>" |
||||||
|
|
||||||
|
return [binary format B* [string map $backward [string toupper $estring]]] |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Data structures |
||||||
|
|
||||||
|
namespace eval ::base32 { |
||||||
|
# Initialize the maps |
||||||
|
variable forward |
||||||
|
variable backward |
||||||
|
variable invalid |
||||||
|
|
||||||
|
core::define { |
||||||
|
0 A 9 J 18 S 27 3 |
||||||
|
1 B 10 K 19 T 28 4 |
||||||
|
2 C 11 L 20 U 29 5 |
||||||
|
3 D 12 M 21 V 30 6 |
||||||
|
4 E 13 N 22 W 31 7 |
||||||
|
5 F 14 O 23 X |
||||||
|
6 G 15 P 24 Y |
||||||
|
7 H 16 Q 25 Z |
||||||
|
8 I 17 R 26 2 |
||||||
|
} forward backward invalid ; # {} |
||||||
|
# puts ///$forward/// |
||||||
|
# puts ///$backward/// |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ok |
||||||
@ -0,0 +1,134 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# This code is hereby put into the public domain. |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
#= Overview |
||||||
|
|
||||||
|
# Fundamental handling of base32 conversion tables. Expansion of a |
||||||
|
# basic mapping into a full mapping and its inverse mapping. |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
#= Requisites |
||||||
|
|
||||||
|
namespace eval ::base32::core {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
#= API & Implementation |
||||||
|
|
||||||
|
proc ::base32::core::define {map fv bv iv} { |
||||||
|
variable bits |
||||||
|
upvar 1 $fv forward $bv backward $iv invalid |
||||||
|
|
||||||
|
# bytes - bits - padding - tail | bits - padding - tail |
||||||
|
# 0 - 0 - "" - "xxxxxxxx" | 0 - "" - "" |
||||||
|
# 1 - 8 - "======" - "xx======" | 3 - "======" - "x======" |
||||||
|
# 2 - 16 - "====" - "xxxx====" | 1 - "====" - "x====" |
||||||
|
# 3 - 24 - "===" - "xxxxx===" | 4 - "===" - "x===" |
||||||
|
# 4 - 32 - "=" - "xxxxxxx=" | 2 - "=" - "x=" |
||||||
|
|
||||||
|
array set _ $bits |
||||||
|
|
||||||
|
set invalid "\[^=" |
||||||
|
set forward {} |
||||||
|
set btmp {} |
||||||
|
|
||||||
|
foreach {code char} $map { |
||||||
|
set b $_($code) |
||||||
|
|
||||||
|
append invalid [string tolower $char][string toupper $char] |
||||||
|
|
||||||
|
# 5 bit remainder |
||||||
|
lappend forward $b $char |
||||||
|
lappend btmp [list $char $b] |
||||||
|
|
||||||
|
# 4 bit remainder |
||||||
|
if {$code%2} continue |
||||||
|
set b [string range $b 0 end-1] |
||||||
|
lappend forward ${b}=/4 ${char}=== |
||||||
|
lappend btmp [list ${char}=== $b] |
||||||
|
|
||||||
|
# 3 bit remainder |
||||||
|
if {$code%4} continue |
||||||
|
set b [string range $b 0 end-1] |
||||||
|
lappend forward ${b}=/3 ${char}====== |
||||||
|
lappend btmp [list ${char}====== $b] |
||||||
|
|
||||||
|
# 2 bit remainder |
||||||
|
if {$code%8} continue |
||||||
|
set b [string range $b 0 end-1] |
||||||
|
lappend forward ${b}=/2 ${char}= |
||||||
|
lappend btmp [list ${char}= $b] |
||||||
|
|
||||||
|
# 1 bit remainder |
||||||
|
if {$code%16} continue |
||||||
|
set b [string range $b 0 end-1] |
||||||
|
lappend forward ${b}=/1 ${char}==== |
||||||
|
lappend btmp [list ${char}==== $b] |
||||||
|
} |
||||||
|
|
||||||
|
set backward {} |
||||||
|
foreach item [lsort -index 0 -decreasing $btmp] { |
||||||
|
foreach {c b} $item break |
||||||
|
lappend backward $c $b |
||||||
|
} |
||||||
|
|
||||||
|
append invalid "\]" |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::base32::core::valid {estring pattern mv} { |
||||||
|
upvar 1 $mv message |
||||||
|
|
||||||
|
if {[string length $estring] % 8} { |
||||||
|
set message "Length is not a multiple of 8" |
||||||
|
return 0 |
||||||
|
} elseif {[regexp -indices $pattern $estring where]} { |
||||||
|
foreach {s e} $where break |
||||||
|
set message "Invalid character at index $s: \"[string index $estring $s]\"" |
||||||
|
return 0 |
||||||
|
} elseif {[regexp {(=+)$} $estring -> pad]} { |
||||||
|
set padlen [string length $pad] |
||||||
|
if { |
||||||
|
($padlen != 6) && |
||||||
|
($padlen != 4) && |
||||||
|
($padlen != 3) && |
||||||
|
($padlen != 1) |
||||||
|
} { |
||||||
|
set message "Invalid padding of length $padlen" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Remove the brackets and ^= from the pattern, to construct the |
||||||
|
# class of valid characters which must not follow the padding. |
||||||
|
|
||||||
|
set badp "=\[[string range $pattern 3 end-1]\]" |
||||||
|
if {[regexp -indices $badp $estring where]} { |
||||||
|
foreach {s e} $where break |
||||||
|
set message "Invalid character at index $s: \"[string index $estring $s]\" (padding found in the middle of the input)" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
return 1 |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Data structures |
||||||
|
|
||||||
|
namespace eval ::base32::core { |
||||||
|
namespace export define valid |
||||||
|
|
||||||
|
variable bits { |
||||||
|
0 00000 1 00001 2 00010 3 00011 |
||||||
|
4 00100 5 00101 6 00110 7 00111 |
||||||
|
8 01000 9 01001 10 01010 11 01011 |
||||||
|
12 01100 13 01101 14 01110 15 01111 |
||||||
|
16 10000 17 10001 18 10010 19 10011 |
||||||
|
20 10100 21 10101 22 10110 23 10111 |
||||||
|
24 11000 25 11001 26 11010 27 11011 |
||||||
|
28 11100 29 11101 30 11110 31 11111 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
#= Registration |
||||||
|
|
||||||
|
package provide base32::core 0.2 |
||||||
@ -0,0 +1,182 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# This code is hereby put into the public domain. |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Overview |
||||||
|
# Base32 encoding and decoding of small strings. |
||||||
|
# |
||||||
|
# Management code for switching between Tcl and C accelerated |
||||||
|
# implementations. |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: base32hex.tcl,v 1.3 2008/03/22 23:46:42 andreas_kupries Exp $ |
||||||
|
|
||||||
|
# @mdgen EXCLUDE: base32hex_c.tcl |
||||||
|
|
||||||
|
package require Tcl 8.5 9 |
||||||
|
|
||||||
|
namespace eval ::base32::hex {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Management of base32 std implementations. |
||||||
|
|
||||||
|
# ::base32::hex::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 ::base32::hex::LoadAccelerator {key} { |
||||||
|
variable accel |
||||||
|
set isok 0 |
||||||
|
switch -exact -- $key { |
||||||
|
critcl { |
||||||
|
# Critcl implementation of base32 requires Tcl 8.4. |
||||||
|
if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} |
||||||
|
if {[catch {package require tcllibc}]} {return 0} |
||||||
|
set isok [llength [info commands ::base32::hex::critcl_encode]] |
||||||
|
} |
||||||
|
tcl { |
||||||
|
variable selfdir |
||||||
|
if {[catch {source [file join $selfdir base32hex_tcl.tcl]}]} {return 0} |
||||||
|
set isok [llength [info commands ::base32::hex::tcl_encode]] |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "invalid accelerator $key:\ |
||||||
|
must be one of [join [KnownImplementations] {, }]" |
||||||
|
} |
||||||
|
} |
||||||
|
set accel($key) $isok |
||||||
|
return $isok |
||||||
|
} |
||||||
|
|
||||||
|
# ::base32::hex::SwitchTo -- |
||||||
|
# |
||||||
|
# Activates a loaded named implementation. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# key Name of the implementation to activate. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::base32::hex::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 ""]} { |
||||||
|
foreach c {encode decode} { |
||||||
|
rename ::base32::hex::$c ::base32::hex::${loaded}_$c |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Activate the new implementation, if there is any. |
||||||
|
|
||||||
|
if {![string equal $key ""]} { |
||||||
|
foreach c {encode decode} { |
||||||
|
rename ::base32::hex::${key}_$c ::base32::hex::$c |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Remember the active implementation, for deactivation by future |
||||||
|
# switches. |
||||||
|
|
||||||
|
set loaded $key |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ::base32::hex::Implementations -- |
||||||
|
# |
||||||
|
# Determines which implementations are |
||||||
|
# present, i.e. loaded. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# None. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A list of implementation keys. |
||||||
|
|
||||||
|
proc ::base32::hex::Implementations {} { |
||||||
|
variable accel |
||||||
|
set res {} |
||||||
|
foreach n [array names accel] { |
||||||
|
if {!$accel($n)} continue |
||||||
|
lappend res $n |
||||||
|
} |
||||||
|
return $res |
||||||
|
} |
||||||
|
|
||||||
|
# ::base32::hex::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 ::base32::hex::KnownImplementations {} { |
||||||
|
return {critcl tcl} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::base32::hex::Names {} { |
||||||
|
return { |
||||||
|
critcl {tcllibc based} |
||||||
|
tcl {pure Tcl} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Initialization: Data structures. |
||||||
|
|
||||||
|
namespace eval ::base32::hex { |
||||||
|
variable selfdir [file dirname [info script]] |
||||||
|
variable loaded {} |
||||||
|
|
||||||
|
variable accel |
||||||
|
array set accel {tcl 0 critcl 0} |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Initialization: Choose an implementation, |
||||||
|
## most prefered first. Loads only one of the |
||||||
|
## possible implementations. And activates it. |
||||||
|
|
||||||
|
namespace eval ::base32::hex { |
||||||
|
variable e |
||||||
|
foreach e [KnownImplementations] { |
||||||
|
if {[LoadAccelerator $e]} { |
||||||
|
SwitchTo $e |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
unset e |
||||||
|
|
||||||
|
namespace export encode decode |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide base32::hex 0.2 |
||||||
@ -0,0 +1,254 @@ |
|||||||
|
# base32hexc.tcl -- |
||||||
|
# |
||||||
|
# Implementation of a base32 (extended hex) de/encoder for Tcl. |
||||||
|
# |
||||||
|
# Public domain |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: base32hex_c.tcl,v 1.3 2008/01/28 22:58:18 andreas_kupries Exp $ |
||||||
|
|
||||||
|
package require critcl |
||||||
|
package require Tcl 8.5 9 |
||||||
|
|
||||||
|
namespace eval ::base32::hex { |
||||||
|
# Supporting code for the main command. |
||||||
|
catch { |
||||||
|
#critcl::cheaders -g |
||||||
|
#critcl::debug memory symbols |
||||||
|
} |
||||||
|
|
||||||
|
# Main commands, encoder & decoder |
||||||
|
|
||||||
|
critcl::ccommand critcl_encode {dummy interp objc objv} { |
||||||
|
/* Syntax -*- c -*- |
||||||
|
* critcl_encode string |
||||||
|
*/ |
||||||
|
|
||||||
|
unsigned char* buf; |
||||||
|
Tcl_Size nbuf; |
||||||
|
|
||||||
|
unsigned char* out; |
||||||
|
unsigned char* at; |
||||||
|
int nout; |
||||||
|
|
||||||
|
/* |
||||||
|
* The array used for encoding |
||||||
|
*/ /* 123456789 123456789 123456789 12 */ |
||||||
|
static const char map[] = "0123456789ABCDEFGHIJKLMNOPQRSTUV"; |
||||||
|
|
||||||
|
#define USAGEE "bitstring" |
||||||
|
|
||||||
|
if (objc != 2) { |
||||||
|
Tcl_WrongNumArgs (interp, 1, objv, USAGEE); /* OK tcl9 */ |
||||||
|
return TCL_ERROR; |
||||||
|
} |
||||||
|
|
||||||
|
buf = Tcl_GetBytesFromObj (interp, objv[1], &nbuf); /* OK tcl9 */ |
||||||
|
if (buf == NULL) return TCL_ERROR; |
||||||
|
nout = ((nbuf+4)/5)*8; |
||||||
|
out = (unsigned char*) Tcl_Alloc (nout*sizeof(char)); |
||||||
|
|
||||||
|
for (at = out; nbuf >= 5; nbuf -= 5, buf += 5) { |
||||||
|
*(at++) = map [ (buf[0]>>3) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[1]>>1) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[3]>>2) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[3]<<3) | (buf[4]>>5)) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[4]) ]; |
||||||
|
} |
||||||
|
if (nbuf > 0) { |
||||||
|
/* Process partials at end. */ |
||||||
|
switch (nbuf) { |
||||||
|
case 1: |
||||||
|
/* |01234567| 2, padding 6 |
||||||
|
* xxxxx |
||||||
|
* xxx 00 |
||||||
|
*/ |
||||||
|
|
||||||
|
*(at++) = map [ (buf[0]>>3) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[0]<<2) ]; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
break; |
||||||
|
case 2: /* x3/=4 */ |
||||||
|
/* |01234567|01234567| 4, padding 4 |
||||||
|
* xxxxx |
||||||
|
* xxx xx |
||||||
|
* xxxxx |
||||||
|
* x 0000 |
||||||
|
*/ |
||||||
|
|
||||||
|
*(at++) = map [ (buf[0]>>3) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[1]>>1) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[1]<<4) ]; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
break; |
||||||
|
case 3: |
||||||
|
/* |01234567|01234567|01234567| 5, padding 3 |
||||||
|
* xxxxx |
||||||
|
* xxx xx |
||||||
|
* xxxxx |
||||||
|
* x xxxx |
||||||
|
* xxxx 0 |
||||||
|
*/ |
||||||
|
|
||||||
|
*(at++) = map [ (buf[0]>>3) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[1]>>1) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[2]<<1) ]; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
*(at++) = '='; |
||||||
|
break; |
||||||
|
case 4: |
||||||
|
/* |01234567|01234567|01234567|012334567| 7, padding 1 |
||||||
|
* xxxxx |
||||||
|
* xxx xx |
||||||
|
* xxxxx |
||||||
|
* x xxxx |
||||||
|
* xxxx |
||||||
|
* xxxxx |
||||||
|
* xxxx 0 |
||||||
|
*/ |
||||||
|
|
||||||
|
*(at++) = map [ (buf[0]>>3) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[1]>>1) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ]; |
||||||
|
*(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[3]>>2) ]; |
||||||
|
*(at++) = map [ 0x1f & (buf[3]<<3) ]; |
||||||
|
*(at++) = '='; |
||||||
|
break; |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
Tcl_SetObjResult (interp, Tcl_NewStringObj ((char*)out, nout)); /* OK tcl9 */ |
||||||
|
Tcl_Free ((char*) out); |
||||||
|
return TCL_OK; |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
critcl::ccommand critcl_decode {dummy interp objc objv} { |
||||||
|
/* Syntax -*- c -*- |
||||||
|
* critcl_decode estring |
||||||
|
*/ |
||||||
|
|
||||||
|
unsigned char* buf; |
||||||
|
Tcl_Size nbuf; |
||||||
|
|
||||||
|
unsigned char* out; |
||||||
|
unsigned char* at; |
||||||
|
unsigned char x [8]; |
||||||
|
int nout; |
||||||
|
|
||||||
|
int i, j, a, pad, nx; |
||||||
|
|
||||||
|
/* |
||||||
|
* An array for translating single base-32 characters into a value. |
||||||
|
* Disallowed input characters have a value of 64. Upper and lower |
||||||
|
* case is the same. Only 128 chars, as everything above char(127) |
||||||
|
* is 64. |
||||||
|
*/ |
||||||
|
static const char map [] = { |
||||||
|
/* \00 */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, |
||||||
|
/* DLE */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, |
||||||
|
/* SPC */ 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, |
||||||
|
/* '0' */ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 64, 64, 64, 64, 64, 64, |
||||||
|
/* '@' */ 64, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, |
||||||
|
/* 'P' */ 25, 26, 27, 28, 29, 30, 31, 64, 64, 64, 64, 64, 64, 64, 64, 64, |
||||||
|
/* '`' */ 64, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, |
||||||
|
/* 'p' */ 25, 26, 27, 28, 29, 30, 31, 64, 64, 64, 64, 64, 64, 64, 64, 64 |
||||||
|
}; |
||||||
|
|
||||||
|
#define USAGED "estring" |
||||||
|
|
||||||
|
if (objc != 2) { |
||||||
|
Tcl_WrongNumArgs (interp, 1, objv, USAGED); /* OK tcl9 */ |
||||||
|
return TCL_ERROR; |
||||||
|
} |
||||||
|
|
||||||
|
buf = (unsigned char*) Tcl_GetStringFromObj (objv[1], &nbuf); /* OK tcl9 */ |
||||||
|
|
||||||
|
if (nbuf % 8) { |
||||||
|
Tcl_SetObjResult (interp, Tcl_NewStringObj ("Length is not a multiple of 8", -1)); /* OK tcl9 */ |
||||||
|
return TCL_ERROR; |
||||||
|
} |
||||||
|
|
||||||
|
nout = (nbuf/8)*5 *TCL_UTF_MAX; |
||||||
|
out = (unsigned char*) Tcl_Alloc (nout*sizeof(char)); |
||||||
|
|
||||||
|
#define HIGH(x) (((x) & 0x80) != 0) |
||||||
|
#define BADC(x) ((x) == 64) |
||||||
|
#define BADCHAR(a,j) (HIGH ((a)) || BADC (x [(j)] = map [(a)])) |
||||||
|
|
||||||
|
for (pad = 0, i=0, at = out; i < nbuf; i += 8, buf += 8){ |
||||||
|
for (j=0; j < 8; j++){ |
||||||
|
a = buf [j]; |
||||||
|
|
||||||
|
if (a == '=') { |
||||||
|
x[j] = 0; |
||||||
|
pad++; |
||||||
|
continue; |
||||||
|
} else if (pad) { |
||||||
|
char msg [120]; |
||||||
|
sprintf (msg, |
||||||
|
"Invalid character at index %d: \"=\" (padding found in the middle of the input)", |
||||||
|
j-1); |
||||||
|
Tcl_Free ((char*) out); |
||||||
|
Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */ |
||||||
|
return TCL_ERROR; |
||||||
|
} |
||||||
|
|
||||||
|
if (BADCHAR (a,j)) { |
||||||
|
char msg [100]; |
||||||
|
sprintf (msg,"Invalid character at index %d: \"%c\"",j,a); |
||||||
|
Tcl_Free ((char*) out); |
||||||
|
Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */ |
||||||
|
return TCL_ERROR; |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
*(at++) = (x[0]<<3) | (x[1]>>2) ; |
||||||
|
*(at++) = (x[1]<<6) | (x[2]<<1) | (x[3]>>4); |
||||||
|
*(at++) = (x[3]<<4) | (x[4]>>1) ; |
||||||
|
*(at++) = (x[4]<<7) | (x[5]<<2) | (x[6]>>3); |
||||||
|
*(at++) = (x[6]<<5) | x[7] ; |
||||||
|
} |
||||||
|
|
||||||
|
if (pad) { |
||||||
|
if (pad == 1) { |
||||||
|
at -= 1; |
||||||
|
} else if (pad == 3) { |
||||||
|
at -= 2; |
||||||
|
} else if (pad == 4) { |
||||||
|
at -= 3; |
||||||
|
} else if (pad == 6) { |
||||||
|
at -= 4; |
||||||
|
} else { |
||||||
|
char msg [100]; |
||||||
|
sprintf (msg,"Invalid padding of length %d",pad); |
||||||
|
Tcl_Free ((char*) out); |
||||||
|
Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */ |
||||||
|
return TCL_ERROR; |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out)); /* OK tcl9 */ |
||||||
|
Tcl_Free ((char*) out); |
||||||
|
return TCL_OK; |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
@ -0,0 +1,79 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# This code is hereby put into the public domain. |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Overview |
||||||
|
# Base32 encoding and decoding of small strings. |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Notes |
||||||
|
|
||||||
|
# A binary string is split into groups of 5 bits (2^5 == 32), and each |
||||||
|
# group is converted into a printable character as is specified in RFC |
||||||
|
# 3548 for the extended hex encoding. |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requisites |
||||||
|
|
||||||
|
package require base32::core |
||||||
|
namespace eval ::base32::hex {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## API & Implementation |
||||||
|
|
||||||
|
proc ::base32::hex::tcl_encode {bitstring} { |
||||||
|
variable forward |
||||||
|
|
||||||
|
binary scan $bitstring B* bits |
||||||
|
set len [string length $bits] |
||||||
|
set rem [expr {$len % 5}] |
||||||
|
if {$rem} {append bits =/$rem} |
||||||
|
#puts "($bitstring) => <$bits>" |
||||||
|
|
||||||
|
return [string map $forward $bits] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::base32::hex::tcl_decode {estring} { |
||||||
|
variable backward |
||||||
|
variable invalid |
||||||
|
|
||||||
|
if {![core::valid $estring $invalid msg]} { |
||||||
|
return -code error $msg |
||||||
|
} |
||||||
|
#puts "I<$estring>" |
||||||
|
#puts "M<[string map $backward $estring]>" |
||||||
|
|
||||||
|
return [binary format B* [string map $backward [string toupper $estring]]] |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Data structures |
||||||
|
|
||||||
|
namespace eval ::base32::hex { |
||||||
|
namespace eval core { |
||||||
|
namespace import ::base32::core::define |
||||||
|
namespace import ::base32::core::valid |
||||||
|
} |
||||||
|
|
||||||
|
namespace export encode decode |
||||||
|
# Initialize the maps |
||||||
|
variable forward |
||||||
|
variable backward |
||||||
|
variable invalid |
||||||
|
|
||||||
|
core::define { |
||||||
|
0 0 9 9 18 I 27 R |
||||||
|
1 1 10 A 19 J 28 S |
||||||
|
2 2 11 B 20 K 29 T |
||||||
|
3 3 12 C 21 L 30 U |
||||||
|
4 4 13 D 22 M 31 V |
||||||
|
5 5 14 E 23 N |
||||||
|
6 6 15 F 24 O |
||||||
|
7 7 16 G 25 P |
||||||
|
8 8 17 H 26 Q |
||||||
|
} forward backward invalid ; # {} |
||||||
|
# puts ///$forward/// |
||||||
|
# puts ///$backward/// |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ok |
||||||
@ -0,0 +1,4 @@ |
|||||||
|
if {![package vsatisfies [package provide Tcl] 8.5 9]} return |
||||||
|
package ifneeded base32 0.2 [list source [file join $dir base32.tcl]] |
||||||
|
package ifneeded base32::hex 0.2 [list source [file join $dir base32hex.tcl]] |
||||||
|
package ifneeded base32::core 0.2 [list source [file join $dir base32core.tcl]] |
||||||
@ -0,0 +1,270 @@ |
|||||||
|
# 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.5 9 |
||||||
|
|
||||||
|
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" |
||||||
|
} |
||||||
|
} |
||||||
|
##nagelfar ignore |
||||||
|
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, and normalize numeric values. |
||||||
|
set ml [format %d $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 rb] |
||||||
|
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.1.1 |
||||||
@ -0,0 +1,411 @@ |
|||||||
|
# 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.5 9 |
||||||
|
namespace eval ::base64 { |
||||||
|
namespace export encode decode |
||||||
|
} |
||||||
|
|
||||||
|
package provide base64 2.6.1 |
||||||
|
|
||||||
|
if {[package vsatisfies [package require Tcl] 8.6 9]} { |
||||||
|
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 |
||||||
|
|
||||||
|
variable i 0 |
||||||
|
variable char |
||||||
|
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.1 |
||||||
|
|
||||||
|
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.5 9]} {return} |
||||||
|
package ifneeded base64 2.6.1 [list source [file join $dir base64.tcl]] |
||||||
|
package ifneeded uuencode 1.1.6 [list source [file join $dir uuencode.tcl]] |
||||||
|
package ifneeded yencode 1.1.4 [list source [file join $dir yencode.tcl]] |
||||||
|
package ifneeded ascii85 1.1.1 [list source [file join $dir ascii85.tcl]] |
||||||
@ -0,0 +1,337 @@ |
|||||||
|
# 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.5 9; # 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) & 0o060) | (($c2 >> 4) & 0o017)}]] |
||||||
|
append r [Enc [expr {(($c2 << 2) & 0o074) | (($c3 >> 6) & 0o003)}]] |
||||||
|
append r [Enc [expr {($c3 & 0o077)}]] |
||||||
|
} |
||||||
|
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; |
||||||
|
Tcl_Size len, rlen, xtra; |
||||||
|
unsigned char *input, *p, *r; |
||||||
|
|
||||||
|
if (objc != 2) { |
||||||
|
Tcl_WrongNumArgs(interp, 1, objv, "data"); /* OK tcl9 */ |
||||||
|
return TCL_ERROR; |
||||||
|
} |
||||||
|
|
||||||
|
inputPtr = objv[1]; |
||||||
|
input = Tcl_GetBytesFromObj(interp, inputPtr, &len); /* OK tcl9 */ |
||||||
|
if (input == NULL) return TCL_ERROR; |
||||||
|
if ((xtra = (3 - (len % 3))) != 3) { |
||||||
|
if (Tcl_IsShared(inputPtr)) |
||||||
|
inputPtr = Tcl_DuplicateObj(inputPtr); |
||||||
|
input = Tcl_SetByteArrayLength(inputPtr, len + xtra); /* OK tcl9 */ |
||||||
|
memset(input + len, 0, xtra); |
||||||
|
len += xtra; |
||||||
|
} |
||||||
|
|
||||||
|
rlen = (len / 3) * 4; |
||||||
|
resultPtr = Tcl_NewObj(); |
||||||
|
r = Tcl_SetByteArrayLength(resultPtr, rlen); /* OK tcl9 */ |
||||||
|
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; |
||||||
|
Tcl_Size len, rlen, xtra; |
||||||
|
unsigned char *input, *p, *r; |
||||||
|
|
||||||
|
if (objc != 2) { |
||||||
|
Tcl_WrongNumArgs(interp, 1, objv, "data"); /* OK tcl9 */ |
||||||
|
return TCL_ERROR; |
||||||
|
} |
||||||
|
|
||||||
|
/* if input is not mod 4, extend it with nuls */ |
||||||
|
inputPtr = objv[1]; |
||||||
|
input = Tcl_GetBytesFromObj(interp, inputPtr, &len); /* OK tcl9 */ |
||||||
|
if (input == NULL) return TCL_ERROR; |
||||||
|
if ((xtra = (4 - (len % 4))) != 4) { |
||||||
|
if (Tcl_IsShared(inputPtr)) |
||||||
|
inputPtr = Tcl_DuplicateObj(inputPtr); |
||||||
|
input = Tcl_SetByteArrayLength(inputPtr, len + xtra); /* OK tcl9 */ |
||||||
|
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); /* OK tcl9 */ |
||||||
|
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 0o0644 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 0o0644 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.6 |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# |
||||||
|
# Local variables: |
||||||
|
# mode: tcl |
||||||
|
# indent-tabs-mode: nil |
||||||
|
# End: |
||||||
|
|
||||||
@ -0,0 +1,309 @@ |
|||||||
|
# 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.5 9; # 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; |
||||||
|
Tcl_Size len, rlen, xtra; |
||||||
|
unsigned char *input, *p, *r, v; |
||||||
|
|
||||||
|
if (objc != 2) { |
||||||
|
Tcl_WrongNumArgs(interp, 1, objv, "data"); /* OK tcl9 */ |
||||||
|
return TCL_ERROR; |
||||||
|
} |
||||||
|
|
||||||
|
/* fetch the input data */ |
||||||
|
inputPtr = objv[1]; |
||||||
|
input = Tcl_GetBytesFromObj(interp, inputPtr, &len); /* OK tcl9 */ |
||||||
|
if (input == NULL) return TCL_ERROR; |
||||||
|
|
||||||
|
/* 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); /* OK tcl9 */ |
||||||
|
|
||||||
|
/* 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; |
||||||
|
Tcl_Size len, rlen, esc; |
||||||
|
unsigned char *input, *p, *r, v; |
||||||
|
|
||||||
|
if (objc != 2) { |
||||||
|
Tcl_WrongNumArgs(interp, 1, objv, "data"); /* OK tcl9 */ |
||||||
|
return TCL_ERROR; |
||||||
|
} |
||||||
|
|
||||||
|
/* fetch the input data */ |
||||||
|
inputPtr = objv[1]; |
||||||
|
input = Tcl_GetBytesFromObj(interp, inputPtr, &len); /* OK tcl9 */ |
||||||
|
if (input == NULL) return TCL_ERROR; |
||||||
|
|
||||||
|
/* allocate the output buffer */ |
||||||
|
resultPtr = Tcl_NewObj(); |
||||||
|
r = Tcl_SetByteArrayLength(resultPtr, len); /* OK tcl9 */ |
||||||
|
|
||||||
|
/* 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); /* OK tcl9 */ |
||||||
|
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) rb] |
||||||
|
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.4 |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# |
||||||
|
# Local variables: |
||||||
|
# mode: tcl |
||||||
|
# indent-tabs-mode: nil |
||||||
|
# End: |
||||||
|
|
||||||
@ -0,0 +1,999 @@ |
|||||||
|
# bee.tcl -- |
||||||
|
# |
||||||
|
# BitTorrent Bee de- and encoder. |
||||||
|
# |
||||||
|
# Copyright (c) 2004 by Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||||
|
# See the file license.terms. |
||||||
|
|
||||||
|
package require Tcl 8.5 9 |
||||||
|
|
||||||
|
namespace eval ::bee { |
||||||
|
# Encoder commands |
||||||
|
namespace export \ |
||||||
|
encodeString encodeNumber \ |
||||||
|
encodeListArgs encodeList \ |
||||||
|
encodeDictArgs encodeDict |
||||||
|
|
||||||
|
# Decoder commands. |
||||||
|
namespace export \ |
||||||
|
decode \ |
||||||
|
decodeChannel \ |
||||||
|
decodeCancel \ |
||||||
|
decodePush |
||||||
|
|
||||||
|
# Channel decoders, reference to state information, keyed by |
||||||
|
# channel handle. |
||||||
|
|
||||||
|
variable bee |
||||||
|
array set bee {} |
||||||
|
|
||||||
|
# Counter for generation of names for the state variables. |
||||||
|
|
||||||
|
variable count 0 |
||||||
|
|
||||||
|
# State information for the channel decoders. |
||||||
|
|
||||||
|
# stateN, with N an integer number counting from 0 on up. |
||||||
|
# ...(chan) Handle of channel the decoder is for. |
||||||
|
# ...(cmd) Command prefix, completion callback |
||||||
|
# ...(exact) Boolean flag, set for exact processing. |
||||||
|
# ...(read) Buffer for new characters to process. |
||||||
|
# ...(type) Type of current value (integer, string, list, dict) |
||||||
|
# ...(value) Buffer for assembling the current value. |
||||||
|
# ...(pend) Stack of pending 'value' buffers, for nested |
||||||
|
# containers. |
||||||
|
# ...(state) Current state of the decoding state machine. |
||||||
|
|
||||||
|
# States of the finite automaton ... |
||||||
|
# intro - One char, type of value, or 'e' as stop of container. |
||||||
|
# signum - sign or digit, for integer. |
||||||
|
# idigit - digit, for integer, or 'e' as stop |
||||||
|
# ldigit - digit, for length of string, or : |
||||||
|
# data - string data, 'get' characters. |
||||||
|
# Containers via 'pend'. |
||||||
|
|
||||||
|
#Debugging help, nesting level |
||||||
|
#variable X 0 |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ::bee::encodeString -- |
||||||
|
# |
||||||
|
# Encode a string to bee-format. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# string The string to encode. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The bee-encoded form of the string. |
||||||
|
|
||||||
|
proc ::bee::encodeString {string} { |
||||||
|
return "[string length $string]:$string" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ::bee::encodeNumber -- |
||||||
|
# |
||||||
|
# Encode an integer number to bee-format. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# num The integer number to encode. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The bee-encoded form of the integer number. |
||||||
|
|
||||||
|
proc ::bee::encodeNumber {num} { |
||||||
|
##nagelfar ignore |
||||||
|
if {![string is integer -strict $num]} { |
||||||
|
return -code error "Expected integer number, got \"$num\"" |
||||||
|
} |
||||||
|
|
||||||
|
# The reformatting deals with hex, octal and other tcl |
||||||
|
# representation of the value. In other words we normalize the |
||||||
|
# string representation of the input value. |
||||||
|
|
||||||
|
set num [format %d $num] |
||||||
|
return "i${num}e" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ::bee::encodeList -- |
||||||
|
# |
||||||
|
# Encode a list of bee-coded values to bee-format. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# list The list to encode. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The bee-encoded form of the list. |
||||||
|
|
||||||
|
proc ::bee::encodeList {list} { |
||||||
|
return "l[join $list ""]e" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ::bee::encodeListArgs -- |
||||||
|
# |
||||||
|
# Encode a variable list of bee-coded values to bee-format. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# args The values to encode. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The bee-encoded form of the list of values. |
||||||
|
|
||||||
|
proc ::bee::encodeListArgs {args} { |
||||||
|
return [encodeList $args] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ::bee::encodeDict -- |
||||||
|
# |
||||||
|
# Encode a dictionary of keys and bee-coded values to bee-format. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# dict The dictionary to encode. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The bee-encoded form of the dictionary. |
||||||
|
|
||||||
|
proc ::bee::encodeDict {dict} { |
||||||
|
if {([llength $dict] % 2) == 1} { |
||||||
|
return -code error "Expected even number of elements, got \"[llength $dict]\"" |
||||||
|
} |
||||||
|
set temp [list] |
||||||
|
foreach {k v} $dict { |
||||||
|
lappend temp [list $k $v] |
||||||
|
} |
||||||
|
set res "d" |
||||||
|
foreach item [lsort -index 0 $temp] { |
||||||
|
foreach {k v} $item break |
||||||
|
append res [encodeString $k]$v |
||||||
|
} |
||||||
|
append res "e" |
||||||
|
return $res |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ::bee::encodeDictArgs -- |
||||||
|
# |
||||||
|
# Encode a variable dictionary of keys and bee-coded values to bee-format. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# args The keys and values to encode. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The bee-encoded form of the dictionary. |
||||||
|
|
||||||
|
proc ::bee::encodeDictArgs {args} { |
||||||
|
return [encodeDict $args] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ::bee::decode -- |
||||||
|
# |
||||||
|
# Decode a bee-encoded value and returns the embedded tcl |
||||||
|
# value. For containers this recurses into the contained value. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# value The string containing the bee-encoded value to decode. |
||||||
|
# evar Optional. If set the name of the variable to store the |
||||||
|
# index of the first character after the decoded value to. |
||||||
|
# start Optional. If set the index of the first character of the |
||||||
|
# value to decode. Defaults to 0, i.e. the beginning of the |
||||||
|
# string. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The tcl value embedded in the encoded string. |
||||||
|
|
||||||
|
proc ::bee::decode {value {evar {}} {start 0}} { |
||||||
|
#variable X |
||||||
|
#puts -nonewline "[string repeat " " $X]decode @$start" ; flush stdout |
||||||
|
|
||||||
|
if {$evar ne ""} {upvar 1 $evar end} else {set end _} |
||||||
|
|
||||||
|
if {[string length $value] < ($start+2)} { |
||||||
|
# This checked that the 'start' index is still in the string, |
||||||
|
# and the end of the value most likely as well. Note that each |
||||||
|
# encoded value consists of at least two characters (the |
||||||
|
# bracketing characters for integer, list, and dict, and for |
||||||
|
# string at least one digit length and the colon). |
||||||
|
|
||||||
|
#puts \t[string length $value]\ <\ ($start+2) |
||||||
|
return -code error "String not large enough for value" |
||||||
|
} |
||||||
|
|
||||||
|
set type [string index $value $start] |
||||||
|
|
||||||
|
#puts -nonewline " $type=" ; flush stdout |
||||||
|
|
||||||
|
if {$type eq "i"} { |
||||||
|
# Extract integer |
||||||
|
#puts -nonewline integer ; flush stdout |
||||||
|
|
||||||
|
incr start ; # Skip over intro 'i'. |
||||||
|
set end [string first e $value $start] |
||||||
|
if {$end < 0} { |
||||||
|
return -code error "End of integer number not found" |
||||||
|
} |
||||||
|
incr end -1 ; # Get last character before closing 'e'. |
||||||
|
set num [string range $value $start $end] |
||||||
|
##nagelfar ignore |
||||||
|
if { |
||||||
|
[regexp {^-0+$} $num] || |
||||||
|
![string is integer -strict $num] || |
||||||
|
(([string length $num] > 1) && [string match 0* $num]) |
||||||
|
} { |
||||||
|
return -code error "Expected integer number, got \"$num\"" |
||||||
|
} |
||||||
|
incr end 2 ; # Step after closing 'e' to the beginning of |
||||||
|
# ........ ; # the next bee-value behind the current one. |
||||||
|
|
||||||
|
#puts " ($num) @$end" |
||||||
|
return [format %d $num] |
||||||
|
|
||||||
|
} elseif {($type eq "l") || ($type eq "d")} { |
||||||
|
#puts -nonewline $type\n ; flush stdout |
||||||
|
|
||||||
|
# Extract list or dictionary, recursively each contained |
||||||
|
# element. From the perspective of the decoder this is the |
||||||
|
# same, the tcl representation of both is a list, and for a |
||||||
|
# dictionary keys and values are also already in the correct |
||||||
|
# order. |
||||||
|
|
||||||
|
set result [list] |
||||||
|
incr start ; # Step over intro 'e' to beginning of the first |
||||||
|
# ........ ; # contained value, or behind the container (if |
||||||
|
# ........ ; # empty). |
||||||
|
|
||||||
|
set end $start |
||||||
|
#incr X |
||||||
|
while {[string index $value $start] ne "e"} { |
||||||
|
lappend result [decode $value end $start] |
||||||
|
set start $end |
||||||
|
} |
||||||
|
#incr X -1 |
||||||
|
incr end |
||||||
|
|
||||||
|
#puts "[string repeat " " $X]($result) @$end" |
||||||
|
|
||||||
|
if {$type eq "d" && ([llength $result] % 2 == 1)} { |
||||||
|
return -code error "Dictionary has to be of even length" |
||||||
|
} |
||||||
|
return $result |
||||||
|
|
||||||
|
} elseif {[string match {[0-9]} $type]} { |
||||||
|
#puts -nonewline string ; flush stdout |
||||||
|
|
||||||
|
# Extract string. First the length, bounded by a colon, then |
||||||
|
# the appropriate number of characters. |
||||||
|
|
||||||
|
set end [string first : $value $start] |
||||||
|
if {$end < 0} { |
||||||
|
return -code error "End of string length not found" |
||||||
|
} |
||||||
|
incr end -1 |
||||||
|
set length [string range $value $start $end] |
||||||
|
incr end 2 ;# Skip to beginning of the string after the colon |
||||||
|
|
||||||
|
##nagelfar ignore |
||||||
|
if {![string is integer -strict $length]} { |
||||||
|
return -code error "Expected integer number for string length, got \"$length\"" |
||||||
|
} elseif {$length < 0} { |
||||||
|
# This cannot happen. To happen "-" has to be first character, |
||||||
|
# and this is caught as unknown bee-type. |
||||||
|
return -code error "Illegal negative string length" |
||||||
|
} elseif {($end + $length) > [string length $value]} { |
||||||
|
return -code error "String not large enough for value" |
||||||
|
} |
||||||
|
|
||||||
|
#puts -nonewline \[$length\] ; flush stdout |
||||||
|
set length [format %d $length] |
||||||
|
if {$length > 0} { |
||||||
|
set start $end |
||||||
|
incr end $length |
||||||
|
incr end -1 |
||||||
|
set result [string range $value $start $end] |
||||||
|
incr end |
||||||
|
} else { |
||||||
|
set result "" |
||||||
|
} |
||||||
|
|
||||||
|
#puts " ($result) @$end" |
||||||
|
return $result |
||||||
|
|
||||||
|
} else { |
||||||
|
return -code error "Unknown bee-type \"$type\"" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ::bee::decodeIndices -- |
||||||
|
# |
||||||
|
# Similar to 'decode', but does not return the decoded tcl values, |
||||||
|
# but a structure containing the start- and end-indices for all |
||||||
|
# values in the structure. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# value The string containing the bee-encoded value to decode. |
||||||
|
# evar Optional. If set the name of the variable to store the |
||||||
|
# index of the first character after the decoded value to. |
||||||
|
# start Optional. If set the index of the first character of the |
||||||
|
# value to decode. Defaults to 0, i.e. the beginning of the |
||||||
|
# string. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The structure of the value, with indices and types for all |
||||||
|
# contained elements. |
||||||
|
|
||||||
|
proc ::bee::decodeIndices {value {evar {}} {start 0}} { |
||||||
|
#variable X |
||||||
|
#puts -nonewline "[string repeat " " $X]decode @$start" ; flush stdout |
||||||
|
|
||||||
|
if {$evar ne ""} {upvar 1 $evar end} else {set end _} |
||||||
|
|
||||||
|
if {[string length $value] < ($start+2)} { |
||||||
|
# This checked that the 'start' index is still in the string, |
||||||
|
# and the end of the value most likely as well. Note that each |
||||||
|
# encoded value consists of at least two characters (the |
||||||
|
# bracketing characters for integer, list, and dict, and for |
||||||
|
# string at least one digit length and the colon). |
||||||
|
|
||||||
|
#puts \t[string length $value]\ <\ ($start+2) |
||||||
|
return -code error "String not large enough for value" |
||||||
|
} |
||||||
|
|
||||||
|
set type [string index $value $start] |
||||||
|
|
||||||
|
#puts -nonewline " $type=" ; flush stdout |
||||||
|
|
||||||
|
if {$type eq "i"} { |
||||||
|
# Extract integer |
||||||
|
#puts -nonewline integer ; flush stdout |
||||||
|
|
||||||
|
set begin $start |
||||||
|
|
||||||
|
incr start ; # Skip over intro 'i'. |
||||||
|
set end [string first e $value $start] |
||||||
|
if {$end < 0} { |
||||||
|
return -code error "End of integer number not found" |
||||||
|
} |
||||||
|
incr end -1 ; # Get last character before closing 'e'. |
||||||
|
set num [string range $value $start $end] |
||||||
|
##nagelfar ignore |
||||||
|
if { |
||||||
|
[regexp {^-0+$} $num] || |
||||||
|
![string is integer -strict $num] || |
||||||
|
(([string length $num] > 1) && [string match 0* $num]) |
||||||
|
} { |
||||||
|
return -code error "Expected integer number, got \"$num\"" |
||||||
|
} |
||||||
|
incr end |
||||||
|
set stop $end |
||||||
|
incr end 1 ; # Step after closing 'e' to the beginning of |
||||||
|
# ........ ; # the next bee-value behind the current one. |
||||||
|
|
||||||
|
#puts " ($num) @$end" |
||||||
|
return [list integer $begin $stop] |
||||||
|
|
||||||
|
} elseif {$type eq "l"} { |
||||||
|
#puts -nonewline $type\n ; flush stdout |
||||||
|
|
||||||
|
# Extract list, recursively each contained element. |
||||||
|
|
||||||
|
set result [list] |
||||||
|
|
||||||
|
lappend result list $start @ |
||||||
|
|
||||||
|
incr start ; # Step over intro 'e' to beginning of the first |
||||||
|
# ........ ; # contained value, or behind the container (if |
||||||
|
# ........ ; # empty). |
||||||
|
|
||||||
|
set end $start |
||||||
|
#incr X |
||||||
|
|
||||||
|
set contained [list] |
||||||
|
while {[string index $value $start] ne "e"} { |
||||||
|
lappend contained [decodeIndices $value end $start] |
||||||
|
set start $end |
||||||
|
} |
||||||
|
lappend result $contained |
||||||
|
#incr X -1 |
||||||
|
set stop $end |
||||||
|
incr end |
||||||
|
|
||||||
|
#puts "[string repeat " " $X]($result) @$end" |
||||||
|
|
||||||
|
return [lreplace $result 2 2 $stop] |
||||||
|
|
||||||
|
} elseif {($type eq "l") || ($type eq "d")} { |
||||||
|
#puts -nonewline $type\n ; flush stdout |
||||||
|
|
||||||
|
# Extract dictionary, recursively each contained element. |
||||||
|
|
||||||
|
set result [list] |
||||||
|
|
||||||
|
lappend result dict $start @ |
||||||
|
|
||||||
|
incr start ; # Step over intro 'e' to beginning of the first |
||||||
|
# ........ ; # contained value, or behind the container (if |
||||||
|
# ........ ; # empty). |
||||||
|
|
||||||
|
set end $start |
||||||
|
set atkey 1 |
||||||
|
#incr X |
||||||
|
|
||||||
|
set contained [list] |
||||||
|
set val [list] |
||||||
|
while {[string index $value $start] ne "e"} { |
||||||
|
if {$atkey} { |
||||||
|
lappend contained [decode $value {} $start] |
||||||
|
lappend val [decodeIndices $value end $start] |
||||||
|
set atkey 0 |
||||||
|
} else { |
||||||
|
lappend val [decodeIndices $value end $start] |
||||||
|
lappend contained $val |
||||||
|
set val [list] |
||||||
|
set atkey 1 |
||||||
|
} |
||||||
|
set start $end |
||||||
|
} |
||||||
|
lappend result $contained |
||||||
|
#incr X -1 |
||||||
|
set stop $end |
||||||
|
incr end |
||||||
|
|
||||||
|
#puts "[string repeat " " $X]($result) @$end" |
||||||
|
|
||||||
|
if {[llength $result] % 2 == 1} { |
||||||
|
return -code error "Dictionary has to be of even length" |
||||||
|
} |
||||||
|
return [lreplace $result 2 2 $stop] |
||||||
|
|
||||||
|
} elseif {[string match {[0-9]} $type]} { |
||||||
|
#puts -nonewline string ; flush stdout |
||||||
|
|
||||||
|
# Extract string. First the length, bounded by a colon, then |
||||||
|
# the appropriate number of characters. |
||||||
|
|
||||||
|
set end [string first : $value $start] |
||||||
|
if {$end < 0} { |
||||||
|
return -code error "End of string length not found" |
||||||
|
} |
||||||
|
incr end -1 |
||||||
|
set length [string range $value $start $end] |
||||||
|
incr end 2 ;# Skip to beginning of the string after the colon |
||||||
|
|
||||||
|
##nagelfar ignore |
||||||
|
if {![string is integer -strict $length]} { |
||||||
|
return -code error "Expected integer number for string length, got \"$length\"" |
||||||
|
} elseif {$length < 0} { |
||||||
|
# This cannot happen. To happen "-" has to be first character, |
||||||
|
# and this is caught as unknown bee-type. |
||||||
|
return -code error "Illegal negative string length" |
||||||
|
} elseif {($end + $length) > [string length $value]} { |
||||||
|
return -code error "String not large enough for value" |
||||||
|
} |
||||||
|
|
||||||
|
set length [format %d $length] |
||||||
|
#puts -nonewline \[$length\] ; flush stdout |
||||||
|
incr end -1 |
||||||
|
if {$length > 0} { |
||||||
|
incr end $length |
||||||
|
set stop $end |
||||||
|
} else { |
||||||
|
set stop $end |
||||||
|
} |
||||||
|
incr end |
||||||
|
|
||||||
|
#puts " ($result) @$end" |
||||||
|
return [list string $start $stop] |
||||||
|
|
||||||
|
} else { |
||||||
|
return -code error "Unknown bee-type \"$type\"" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ::bee::decodeChannel -- |
||||||
|
# |
||||||
|
# Attach decoder for a bee-value to a channel. See the |
||||||
|
# documentation for details. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# chan Channel to attach to. |
||||||
|
# -command cmdprefix Completion callback. Required. |
||||||
|
# -exact Keep running after completion. |
||||||
|
# -prefix data Seed for decode buffer. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A token to use when referring to the decoder. |
||||||
|
# For example when canceling it. |
||||||
|
|
||||||
|
proc ::bee::decodeChannel {chan args} { |
||||||
|
variable bee |
||||||
|
if {[info exists bee($chan)]} { |
||||||
|
return -code error "bee-Decoder already active for channel" |
||||||
|
} |
||||||
|
|
||||||
|
# Create state and token. |
||||||
|
|
||||||
|
variable count |
||||||
|
variable [set st state$count] |
||||||
|
array set $st {} |
||||||
|
set bee($chan) $st |
||||||
|
upvar 0 $st state |
||||||
|
incr count |
||||||
|
|
||||||
|
# Initialize the decoder state, process the options. When |
||||||
|
# encountering errors here destroy the half-baked state before |
||||||
|
# throwing the message. |
||||||
|
|
||||||
|
set state(chan) $chan |
||||||
|
array set state { |
||||||
|
exact 0 |
||||||
|
type ? |
||||||
|
read {} |
||||||
|
value {} |
||||||
|
pend {} |
||||||
|
state intro |
||||||
|
get 1 |
||||||
|
} |
||||||
|
|
||||||
|
while {[llength $args]} { |
||||||
|
set option [lindex $args 0] |
||||||
|
set args [lrange $args 1 end] |
||||||
|
if {$option eq "-command"} { |
||||||
|
if {![llength $args]} { |
||||||
|
unset bee($chan) |
||||||
|
unset state |
||||||
|
return -code error "Missing value for option -command." |
||||||
|
} |
||||||
|
set state(cmd) [lindex $args 0] |
||||||
|
set args [lrange $args 1 end] |
||||||
|
|
||||||
|
} elseif {$option eq "-prefix"} { |
||||||
|
if {![llength $args]} { |
||||||
|
unset bee($chan) |
||||||
|
unset state |
||||||
|
return -code error "Missing value for option -prefix." |
||||||
|
} |
||||||
|
set state(read) [lindex $args 0] |
||||||
|
set args [lrange $args 1 end] |
||||||
|
|
||||||
|
} elseif {$option eq "-exact"} { |
||||||
|
set state(exact) 1 |
||||||
|
} else { |
||||||
|
unset bee($chan) |
||||||
|
unset state |
||||||
|
return -code error "Illegal option \"$option\",\ |
||||||
|
expected \"-command\", \"-prefix\", or \"-keep\"" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {![info exists state(cmd)]} { |
||||||
|
unset bee($chan) |
||||||
|
unset state |
||||||
|
return -code error "Missing required completion callback." |
||||||
|
} |
||||||
|
|
||||||
|
# Set up the processing of incoming data. |
||||||
|
|
||||||
|
fileevent $chan readable [list ::bee::Process $chan $bee($chan)] |
||||||
|
|
||||||
|
# Return the name of the state array as token. |
||||||
|
return $bee($chan) |
||||||
|
} |
||||||
|
|
||||||
|
# ::bee::Parse -- |
||||||
|
# |
||||||
|
# Internal helper. Fileevent handler for a decoder. |
||||||
|
# Parses input and handles both error and eof conditions. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# token The decoder to run on its input. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::bee::Process {chan token} { |
||||||
|
if {[catch {Parse $token} msg]} { |
||||||
|
# Something failed. Destroy and report. |
||||||
|
Command $token error $msg |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
if {[eof $chan]} { |
||||||
|
# Having data waiting, either in the input queue, or in the |
||||||
|
# output stack (of nested containers) is a failure. Report |
||||||
|
# this instead of the eof. |
||||||
|
|
||||||
|
variable $token |
||||||
|
upvar 0 $token state |
||||||
|
|
||||||
|
if { |
||||||
|
[string length $state(read)] || |
||||||
|
[llength $state(pend)] || |
||||||
|
[string length $state(value)] || |
||||||
|
($state(state) ne "intro") |
||||||
|
} { |
||||||
|
Command $token error "Incomplete value at end of channel" |
||||||
|
} else { |
||||||
|
Command $token eof |
||||||
|
} |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ::bee::Parse -- |
||||||
|
# |
||||||
|
# Internal helper. Reading from the channel and parsing the input. |
||||||
|
# Uses a hardwired state machine. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# token The decoder to run on its input. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::bee::Parse {token} { |
||||||
|
variable $token |
||||||
|
upvar 0 $token state |
||||||
|
upvar 0 state(state) current |
||||||
|
upvar 0 state(read) input |
||||||
|
upvar 0 state(type) type |
||||||
|
upvar 0 state(value) value |
||||||
|
upvar 0 state(pend) pend |
||||||
|
upvar 0 state(exact) exact |
||||||
|
upvar 0 state(get) get |
||||||
|
set chan $state(chan) |
||||||
|
|
||||||
|
#puts Parse/$current |
||||||
|
|
||||||
|
if {!$exact} { |
||||||
|
# Add all waiting characters to the buffer so that we can process as |
||||||
|
# much as is possible in one go. |
||||||
|
append input [read $chan] |
||||||
|
} else { |
||||||
|
# Exact reading. Usually one character, but when in the data |
||||||
|
# section for a string value we know for how many characters |
||||||
|
# we are looking for. |
||||||
|
|
||||||
|
append input [read $chan $get] |
||||||
|
} |
||||||
|
|
||||||
|
# We got nothing, do nothing. |
||||||
|
if {![string length $input]} return |
||||||
|
|
||||||
|
|
||||||
|
if {$current eq "data"} { |
||||||
|
# String data, this can be done faster, as we read longer |
||||||
|
# sequences of characters for this. |
||||||
|
set l [string length $input] |
||||||
|
if {$l < $get} { |
||||||
|
# Not enough, wait for more. |
||||||
|
append value $input |
||||||
|
incr get -$l |
||||||
|
return |
||||||
|
} elseif {$l == $get} { |
||||||
|
# Got all, exactly. Prepare state machine for next value. |
||||||
|
|
||||||
|
if {[Complete $token $value$input]} return |
||||||
|
|
||||||
|
set current intro |
||||||
|
set get 1 |
||||||
|
set value "" |
||||||
|
set input "" |
||||||
|
|
||||||
|
return |
||||||
|
} else { |
||||||
|
# Got more than required (only for !exact). |
||||||
|
|
||||||
|
incr get -1 |
||||||
|
if {[Complete $token $value[string range $input 0 $get]]} {return} |
||||||
|
|
||||||
|
incr get |
||||||
|
set input [string range $input $get end] |
||||||
|
set get 1 |
||||||
|
set value "" |
||||||
|
set current intro |
||||||
|
# This now falls into the loop below. |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set where 0 |
||||||
|
set n [string length $input] |
||||||
|
|
||||||
|
#puts Parse/$n |
||||||
|
|
||||||
|
while {$where < $n} { |
||||||
|
# Hardwired state machine. Get current character. |
||||||
|
set ch [string index $input $where] |
||||||
|
|
||||||
|
#puts Parse/@$where/$current/$ch/ |
||||||
|
if {$current eq "intro"} { |
||||||
|
# First character of a value. |
||||||
|
|
||||||
|
if {$ch eq "i"} { |
||||||
|
# Begin reading integer. |
||||||
|
set type integer |
||||||
|
set current signum |
||||||
|
} elseif {$ch eq "l"} { |
||||||
|
# Begin a list. |
||||||
|
set type list |
||||||
|
lappend pend list {} |
||||||
|
#set current intro |
||||||
|
|
||||||
|
} elseif {$ch eq "d"} { |
||||||
|
# Begin a dictionary. |
||||||
|
set type dict |
||||||
|
lappend pend dict {} |
||||||
|
#set current intro |
||||||
|
|
||||||
|
} elseif {$ch eq "e"} { |
||||||
|
# Close a container. Throw an error if there is no |
||||||
|
# container to close. |
||||||
|
|
||||||
|
if {![llength $pend]} { |
||||||
|
return -code error "End of container outside of container." |
||||||
|
} |
||||||
|
|
||||||
|
set v [lindex $pend end] |
||||||
|
set t [lindex $pend end-1] |
||||||
|
set pend [lrange $pend 0 end-2] |
||||||
|
|
||||||
|
if {$t eq "dict" && ([llength $v] % 2 == 1)} { |
||||||
|
return -code error "Dictionary has to be of even length" |
||||||
|
} |
||||||
|
|
||||||
|
if {[Complete $token $v]} {return} |
||||||
|
set current intro |
||||||
|
|
||||||
|
} elseif {[string match {[0-9]} $ch]} { |
||||||
|
# Begin reading a string, length section first. |
||||||
|
set type string |
||||||
|
set current ldigit |
||||||
|
set value $ch |
||||||
|
|
||||||
|
} else { |
||||||
|
# Unknown type. Throw error. |
||||||
|
return -code error "Unknown bee-type \"$ch\"" |
||||||
|
} |
||||||
|
|
||||||
|
# To next character. |
||||||
|
incr where |
||||||
|
} elseif {$current eq "signum"} { |
||||||
|
# Integer number, a minus sign, or a digit. |
||||||
|
if {[string match {[-0-9]} $ch]} { |
||||||
|
append value $ch |
||||||
|
set current idigit |
||||||
|
} else { |
||||||
|
return -code error "Syntax error in integer,\ |
||||||
|
expected sign or digit, got \"$ch\"" |
||||||
|
} |
||||||
|
incr where |
||||||
|
|
||||||
|
} elseif {$current eq "idigit"} { |
||||||
|
# Integer number, digit or closing 'e'. |
||||||
|
|
||||||
|
if {[string match {[-0-9]} $ch]} { |
||||||
|
append value $ch |
||||||
|
} elseif {$ch eq "e"} { |
||||||
|
# Integer closes. Validate and report. |
||||||
|
#puts validate |
||||||
|
##nagelfar ignore |
||||||
|
if { |
||||||
|
[regexp {^-0+$} $value] || |
||||||
|
![string is integer -strict $value] || |
||||||
|
(([string length $value] > 1) && [string match 0* $value]) |
||||||
|
} { |
||||||
|
return -code error "Expected integer number, got \"$value\"" |
||||||
|
} |
||||||
|
set value [format %d $value] |
||||||
|
if {[Complete $token $value]} {return} |
||||||
|
set value "" |
||||||
|
set current intro |
||||||
|
} else { |
||||||
|
return -code error "Syntax error in integer,\ |
||||||
|
expected digit, or 'e', got \"$ch\"" |
||||||
|
} |
||||||
|
incr where |
||||||
|
|
||||||
|
} elseif {$current eq "ldigit"} { |
||||||
|
# String, length section, digit, or : |
||||||
|
|
||||||
|
if {[string match {[-0-9]} $ch]} { |
||||||
|
append value $ch |
||||||
|
|
||||||
|
} elseif {$ch eq ":"} { |
||||||
|
# Length section closes, validate, |
||||||
|
# then perform data processing. |
||||||
|
|
||||||
|
set num $value |
||||||
|
##nagelfar ignore |
||||||
|
if { |
||||||
|
[regexp {^-0+$} $num] || |
||||||
|
![string is integer -strict $num] || |
||||||
|
(([string length $num] > 1) && [string match 0* $num]) |
||||||
|
} { |
||||||
|
return -code error "Expected integer number as string length, got \"$num\"" |
||||||
|
} |
||||||
|
set num [format %d $num] |
||||||
|
set value "" |
||||||
|
|
||||||
|
# We may have already part of the data in |
||||||
|
# memory. Process that piece before looking for more. |
||||||
|
|
||||||
|
incr where |
||||||
|
set have [expr {$n - $where}] |
||||||
|
if {$num < $have} { |
||||||
|
# More than enough in the buffer. |
||||||
|
|
||||||
|
set end $where |
||||||
|
incr end $num |
||||||
|
incr end -1 |
||||||
|
|
||||||
|
if {[Complete $token [string range $input $where $end]]} {return} |
||||||
|
|
||||||
|
set where $end ;# Further processing behind the string. |
||||||
|
set current intro |
||||||
|
|
||||||
|
} elseif {$num == $have} { |
||||||
|
# Just enough. |
||||||
|
|
||||||
|
if {[Complete $token [string range $input $where end]]} {return} |
||||||
|
|
||||||
|
set where $n |
||||||
|
set current intro |
||||||
|
} else { |
||||||
|
# Not enough. Initialize value with the data we |
||||||
|
# have (after the colon) and stop processing for |
||||||
|
# now. |
||||||
|
|
||||||
|
set value [string range $input $where end] |
||||||
|
set current data |
||||||
|
set get $num |
||||||
|
set input "" |
||||||
|
return |
||||||
|
} |
||||||
|
} else { |
||||||
|
return -code error "Syntax error in string length,\ |
||||||
|
expected digit, or ':', got \"$ch\"" |
||||||
|
} |
||||||
|
incr where |
||||||
|
} else { |
||||||
|
# unknown state = internal error |
||||||
|
return -code error "Unknown decoder state \"$current\", internal error" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set input "" |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ::bee::Command -- |
||||||
|
# |
||||||
|
# Internal helper. Runs the decoder command callback. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# token The decoder invoking its callback |
||||||
|
# how Which method to invoke (value, error, eof) |
||||||
|
# args Arguments for the method. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A boolean flag. Set if further processing has to stop. |
||||||
|
|
||||||
|
proc ::bee::Command {token how args} { |
||||||
|
variable $token |
||||||
|
upvar 0 $token state |
||||||
|
|
||||||
|
#puts Report/$token/$how/$args/ |
||||||
|
|
||||||
|
set cmd $state(cmd) |
||||||
|
set chan $state(chan) |
||||||
|
|
||||||
|
# We catch the fileevents because they will fail when this is |
||||||
|
# called from the 'Close'. The channel will already be gone in |
||||||
|
# that case. |
||||||
|
|
||||||
|
set stop 0 |
||||||
|
if {($how eq "error") || ($how eq "eof")} { |
||||||
|
variable bee |
||||||
|
|
||||||
|
set stop 1 |
||||||
|
fileevent $chan readable {} |
||||||
|
unset bee($chan) |
||||||
|
unset state |
||||||
|
|
||||||
|
if {$how eq "eof"} { |
||||||
|
#puts \tclosing/$chan |
||||||
|
close $chan |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
lappend cmd $how $token |
||||||
|
foreach a $args {lappend cmd $a} |
||||||
|
uplevel #0 $cmd |
||||||
|
|
||||||
|
if {![info exists state]} { |
||||||
|
# The decoder token was killed by the callback, stop |
||||||
|
# processing. |
||||||
|
set stop 1 |
||||||
|
} |
||||||
|
|
||||||
|
#puts /$stop/[file channels] |
||||||
|
return $stop |
||||||
|
} |
||||||
|
|
||||||
|
# ::bee::Complete -- |
||||||
|
# |
||||||
|
# Internal helper. Reports a completed value. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# token The decoder reporting the value. |
||||||
|
# value The value to report. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A boolean flag. Set if further processing has to stop. |
||||||
|
|
||||||
|
proc ::bee::Complete {token value} { |
||||||
|
variable $token |
||||||
|
upvar 0 $token state |
||||||
|
upvar 0 state(pend) pend |
||||||
|
|
||||||
|
if {[llength $pend]} { |
||||||
|
# The value is part of a container. Add the value to its end |
||||||
|
# and keep processing. |
||||||
|
|
||||||
|
set pend [lreplace $pend end end \ |
||||||
|
[linsert [lindex $pend end] end \ |
||||||
|
$value]] |
||||||
|
|
||||||
|
# Don't stop. |
||||||
|
return 0 |
||||||
|
} |
||||||
|
|
||||||
|
# The value is at the top, report it. The callback determines if |
||||||
|
# we keep processing. |
||||||
|
|
||||||
|
return [Command $token value $value] |
||||||
|
} |
||||||
|
|
||||||
|
# ::bee::decodeCancel -- |
||||||
|
# |
||||||
|
# Destroys the decoder referenced by the token. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# token The decoder to destroy. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::bee::decodeCancel {token} { |
||||||
|
variable bee |
||||||
|
variable $token |
||||||
|
upvar 0 $token state |
||||||
|
unset bee($state(chan)) |
||||||
|
unset state |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ::bee::decodePush -- |
||||||
|
# |
||||||
|
# Push data into the decoder input buffer. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# token The decoder to extend. |
||||||
|
# string The characters to add. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::bee::decodePush {token string} { |
||||||
|
variable $token |
||||||
|
upvar 0 $token state |
||||||
|
append state(read) $string |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
package provide bee 0.3 |
||||||
@ -0,0 +1,4 @@ |
|||||||
|
# Tcl package index file, version 1.1 |
||||||
|
|
||||||
|
if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} |
||||||
|
package ifneeded bee 0.3 [list source [file join $dir bee.tcl]] |
||||||
@ -0,0 +1,556 @@ |
|||||||
|
# bench.tcl -- |
||||||
|
# |
||||||
|
# Management of benchmarks. |
||||||
|
# |
||||||
|
# Copyright (c) 2005-2008 by Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||||
|
# library derived from runbench.tcl application (C) Jeff Hobbs. |
||||||
|
# |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Requisites - Packages and namespace for the commands and data. |
||||||
|
|
||||||
|
package require Tcl 8.5 9 |
||||||
|
package require logger |
||||||
|
package require csv |
||||||
|
package require struct::matrix |
||||||
|
package require report |
||||||
|
|
||||||
|
namespace eval ::bench {} |
||||||
|
namespace eval ::bench::out {} |
||||||
|
|
||||||
|
# @mdgen OWNER: libbench.tcl |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Public API - Benchmark execution |
||||||
|
|
||||||
|
# ::bench::run -- |
||||||
|
# |
||||||
|
# Run a series of benchmarks. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# ... |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# Dictionary. |
||||||
|
|
||||||
|
proc ::bench::run {args} { |
||||||
|
log::debug [linsert $args 0 ::bench::run] |
||||||
|
|
||||||
|
# -errors 0|1 default 1, propagate errors in benchmarks |
||||||
|
# -threads <num> default 0, no threads, #threads to use |
||||||
|
# -match <pattern> only run tests matching this pattern |
||||||
|
# -rmatch <pattern> only run tests matching this pattern |
||||||
|
# -iters <num> default 1000, max#iterations for any benchmark |
||||||
|
# -pkgdir <dir> Defaults to nothing, regular bench invokation. |
||||||
|
|
||||||
|
# interps - dict (path -> version) |
||||||
|
# files - list (of files) |
||||||
|
|
||||||
|
# Process arguments ...................................... |
||||||
|
# Defaults first, then overides by the user |
||||||
|
|
||||||
|
set errors 1 ; # Propagate errors |
||||||
|
set threads 0 ; # Do not use threads |
||||||
|
set match {} ; # Do not exclude benchmarks based on glob pattern |
||||||
|
set rmatch {} ; # Do not exclude benchmarks based on regex pattern |
||||||
|
set iters 1000 ; # Limit #iterations for any benchmark |
||||||
|
set pkgdirs {} ; # List of dirs to put in front of auto_path in the |
||||||
|
# bench interpreters. Default: nothing. |
||||||
|
|
||||||
|
while {[string match "-*" [set opt [lindex $args 0]]]} { |
||||||
|
set val [lindex $args 1] |
||||||
|
switch -exact -- $opt { |
||||||
|
-errors { |
||||||
|
if {![string is boolean -strict $val]} { |
||||||
|
return -code error "Expected boolean, got \"$val\"" |
||||||
|
} |
||||||
|
set errors $val |
||||||
|
} |
||||||
|
-threads { |
||||||
|
##nagelfar ignore |
||||||
|
if {![string is integer -strict $val] || ($val < 0)} { |
||||||
|
return -code error "Expected int >= 0, got \"$val\"" |
||||||
|
} |
||||||
|
set threads [format %d $val] |
||||||
|
} |
||||||
|
-match { |
||||||
|
set match [lindex $args 1] |
||||||
|
} |
||||||
|
-rmatch { |
||||||
|
set rmatch [lindex $args 1] |
||||||
|
} |
||||||
|
-iters { |
||||||
|
##nagelfar ignore |
||||||
|
if {![string is integer -strict $val] || ($val <= 0)} { |
||||||
|
return -code error "Expected int > 0, got \"$val\"" |
||||||
|
} |
||||||
|
set iters [format %d $val] |
||||||
|
} |
||||||
|
-pkgdir { |
||||||
|
CheckPkgDirArg $val |
||||||
|
lappend pkgdirs $val |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "Unknown option \"$opt\", should -errors, -threads, -match, -rmatch, or -iters" |
||||||
|
} |
||||||
|
} |
||||||
|
set args [lrange $args 2 end] |
||||||
|
} |
||||||
|
if {[llength $args] != 2} { |
||||||
|
return -code error "wrong\#args, should be: ?options? interp files" |
||||||
|
} |
||||||
|
foreach {interps files} $args break |
||||||
|
|
||||||
|
# Run the benchmarks ..................................... |
||||||
|
|
||||||
|
array set DATA {} |
||||||
|
|
||||||
|
if {![llength $pkgdirs]} { |
||||||
|
# No user specified package directories => Simple run. |
||||||
|
foreach {ip ver} $interps { |
||||||
|
Invoke $ip $ver {} ;# DATA etc passed via upvar. |
||||||
|
} |
||||||
|
} else { |
||||||
|
# User specified package directories. |
||||||
|
foreach {ip ver} $interps { |
||||||
|
foreach pkgdir $pkgdirs { |
||||||
|
Invoke $ip $ver $pkgdir ;# DATA etc passed via upvar. |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Benchmark data ... Structure, dict (key -> value) |
||||||
|
# |
||||||
|
# Key || Value |
||||||
|
# ============ ++ ========================================= |
||||||
|
# interp IP -> Version. Shell IP was used to run benchmarks. IP is |
||||||
|
# the path to the shell. |
||||||
|
# |
||||||
|
# desc DESC -> "". DESC is description of an executed benchmark. |
||||||
|
# |
||||||
|
# usec DESC IP -> Result. Result of benchmark DESC when run by the |
||||||
|
# shell IP. Usually time in microseconds, but can be |
||||||
|
# a special code as well (ERR, BAD_RES). |
||||||
|
# ============ ++ ========================================= |
||||||
|
|
||||||
|
return [array get DATA] |
||||||
|
} |
||||||
|
|
||||||
|
# ::bench::locate -- |
||||||
|
# |
||||||
|
# Locate interpreters on the pathlist, based on a pattern. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# ... |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# List of paths. |
||||||
|
|
||||||
|
proc ::bench::locate {pattern paths} { |
||||||
|
# Cache of executables already found. |
||||||
|
array set var {} |
||||||
|
set res {} |
||||||
|
|
||||||
|
foreach path $paths { |
||||||
|
foreach ip [glob -nocomplain [file join $path $pattern]] { |
||||||
|
set ip [file normalize $ip] |
||||||
|
|
||||||
|
# Follow soft-links to the actual executable. |
||||||
|
while {[string equal link [file type $ip]]} { |
||||||
|
set link [file readlink $ip] |
||||||
|
if {[string match relative [file pathtype $link]]} { |
||||||
|
set ip [file join [file dirname $ip] $link] |
||||||
|
} else { |
||||||
|
set ip $link |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if { |
||||||
|
[file executable $ip] && ![info exists var($ip)] |
||||||
|
} { |
||||||
|
if {[catch {exec $ip << "exit"} dummy]} { |
||||||
|
log::debug "$ip: $dummy" |
||||||
|
continue |
||||||
|
} |
||||||
|
set var($ip) . |
||||||
|
lappend res $ip |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return $res |
||||||
|
} |
||||||
|
|
||||||
|
# ::bench::versions -- |
||||||
|
# |
||||||
|
# Take list of interpreters, find their versions. |
||||||
|
# Removes all interps for which it cannot do so. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# List of interpreters (paths) |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# dictionary: interpreter -> version. |
||||||
|
|
||||||
|
proc ::bench::versions {interps} { |
||||||
|
set res {} |
||||||
|
foreach ip $interps { |
||||||
|
if {[catch { |
||||||
|
exec $ip << {puts [info patchlevel] ; exit} |
||||||
|
} patchlevel]} { |
||||||
|
log::debug "$ip: $patchlevel" |
||||||
|
continue |
||||||
|
} |
||||||
|
|
||||||
|
lappend res [list $patchlevel $ip] |
||||||
|
} |
||||||
|
|
||||||
|
# -uniq 8.4-ism, replaced with use of array. |
||||||
|
array set tmp {} |
||||||
|
set resx {} |
||||||
|
foreach item [lsort -dictionary -decreasing -index 0 $res] { |
||||||
|
foreach {p ip} $item break |
||||||
|
if {[info exists tmp($p)]} continue |
||||||
|
set tmp($p) . |
||||||
|
lappend resx $ip $p |
||||||
|
} |
||||||
|
|
||||||
|
return $resx |
||||||
|
} |
||||||
|
|
||||||
|
# ::bench::merge -- |
||||||
|
# |
||||||
|
# Take the data of several benchmark runs and merge them into |
||||||
|
# one data set. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# One or more data sets to merge |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The merged data set. |
||||||
|
|
||||||
|
proc ::bench::merge {args} { |
||||||
|
if {[llength $args] == 1} { |
||||||
|
return [lindex $args 0] |
||||||
|
} |
||||||
|
|
||||||
|
array set DATA {} |
||||||
|
foreach data $args { |
||||||
|
array set DATA $data |
||||||
|
} |
||||||
|
return [array get DATA] |
||||||
|
} |
||||||
|
|
||||||
|
# ::bench::norm -- |
||||||
|
# |
||||||
|
# Normalize the time data in the dataset, using one of the |
||||||
|
# columns as reference. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# Data to normalize |
||||||
|
# Index of reference column |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The normalized data set. |
||||||
|
|
||||||
|
proc ::bench::norm {data col} { |
||||||
|
|
||||||
|
##nagelfar ignore |
||||||
|
if {![string is integer -strict $col]} { |
||||||
|
return -code error "Ref.column: Expected integer, but got \"$col\"" |
||||||
|
} |
||||||
|
set col [format %d $col] |
||||||
|
if {$col < 1} { |
||||||
|
return -code error "Ref.column out of bounds" |
||||||
|
} |
||||||
|
|
||||||
|
array set DATA $data |
||||||
|
set ipkeys [array names DATA interp*] |
||||||
|
|
||||||
|
if {$col > [llength $ipkeys]} { |
||||||
|
return -code error "Ref.column out of bounds" |
||||||
|
} |
||||||
|
incr col -1 |
||||||
|
set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1] |
||||||
|
|
||||||
|
foreach key [array names DATA] { |
||||||
|
if {[string match "desc*" $key]} continue |
||||||
|
if {[string match "interp*" $key]} continue |
||||||
|
|
||||||
|
foreach {_ desc ip} $key break |
||||||
|
if {[string equal $ip $refip]} continue |
||||||
|
|
||||||
|
set v $DATA($key) |
||||||
|
if {![string is double -strict $v]} continue |
||||||
|
|
||||||
|
if {![info exists DATA([list usec $desc $refip])]} { |
||||||
|
# We cannot normalize, we do not keep the time value. |
||||||
|
# The row will be shown, empty. |
||||||
|
set DATA($key) "" |
||||||
|
continue |
||||||
|
} |
||||||
|
set vref $DATA([list usec $desc $refip]) |
||||||
|
|
||||||
|
if {![string is double -strict $vref]} continue |
||||||
|
|
||||||
|
set DATA($key) [expr {$v/double($vref)}] |
||||||
|
} |
||||||
|
|
||||||
|
foreach key [array names DATA [list * $refip]] { |
||||||
|
if {![string is double -strict $DATA($key)]} continue |
||||||
|
set DATA($key) 1 |
||||||
|
} |
||||||
|
|
||||||
|
return [array get DATA] |
||||||
|
} |
||||||
|
|
||||||
|
# ::bench::edit -- |
||||||
|
# |
||||||
|
# Change the 'path' of an interp to a user-defined value. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# Data to edit |
||||||
|
# Index of column to change |
||||||
|
# The value replacing the current path |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The changed data set. |
||||||
|
|
||||||
|
proc ::bench::edit {data col new} { |
||||||
|
|
||||||
|
##nagelfar ignore |
||||||
|
if {![string is integer -strict $col]} { |
||||||
|
return -code error "Ref.column: Expected integer, but got \"$col\"" |
||||||
|
} |
||||||
|
set col [format %d $col] |
||||||
|
if {$col < 1} { |
||||||
|
return -code error "Ref.column out of bounds" |
||||||
|
} |
||||||
|
|
||||||
|
array set DATA $data |
||||||
|
set ipkeys [array names DATA interp*] |
||||||
|
|
||||||
|
if {$col > [llength $ipkeys]} { |
||||||
|
return -code error "Ref.column out of bounds" |
||||||
|
} |
||||||
|
incr col -1 |
||||||
|
set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1] |
||||||
|
|
||||||
|
if {[string equal $new $refip]} { |
||||||
|
# No change, quick return |
||||||
|
return $data |
||||||
|
} |
||||||
|
|
||||||
|
set refkey [list interp $refip] |
||||||
|
set DATA([list interp $new]) $DATA($refkey) |
||||||
|
unset DATA($refkey) |
||||||
|
|
||||||
|
foreach key [array names DATA [list * $refip]] { |
||||||
|
if {![string equal [lindex $key 0] "usec"]} continue |
||||||
|
foreach {__ desc ip} $key break |
||||||
|
set DATA([list usec $desc $new]) $DATA($key) |
||||||
|
unset DATA($key) |
||||||
|
} |
||||||
|
|
||||||
|
return [array get DATA] |
||||||
|
} |
||||||
|
|
||||||
|
# ::bench::del -- |
||||||
|
# |
||||||
|
# Remove the data for an interp. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# Data to edit |
||||||
|
# Index of column to remove |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The changed data set. |
||||||
|
|
||||||
|
proc ::bench::del {data col} { |
||||||
|
##nagelfar ignore |
||||||
|
if {![string is integer -strict $col]} { |
||||||
|
return -code error "Ref.column: Expected integer, but got \"$col\"" |
||||||
|
} |
||||||
|
set col [format %d $col] |
||||||
|
if {$col < 1} { |
||||||
|
return -code error "Ref.column out of bounds" |
||||||
|
} |
||||||
|
|
||||||
|
array set DATA $data |
||||||
|
set ipkeys [array names DATA interp*] |
||||||
|
|
||||||
|
if {$col > [llength $ipkeys]} { |
||||||
|
return -code error "Ref.column out of bounds" |
||||||
|
} |
||||||
|
incr col -1 |
||||||
|
set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1] |
||||||
|
|
||||||
|
unset DATA([list interp $refip]) |
||||||
|
|
||||||
|
# Do not use 'array unset'. Keep 8.2 clean. |
||||||
|
foreach key [array names DATA [list * $refip]] { |
||||||
|
if {![string equal [lindex $key 0] "usec"]} continue |
||||||
|
unset DATA($key) |
||||||
|
} |
||||||
|
|
||||||
|
return [array get DATA] |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Public API - Result formatting. |
||||||
|
|
||||||
|
# ::bench::out::raw -- |
||||||
|
# |
||||||
|
# Format the result of a benchmark run. |
||||||
|
# Style: Raw data. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# DATA dict |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# String containing the formatted DATA. |
||||||
|
|
||||||
|
proc ::bench::out::raw {data} { |
||||||
|
return $data |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Internal commands |
||||||
|
|
||||||
|
proc ::bench::CheckPkgDirArg {path {expected {}}} { |
||||||
|
# Allow empty string, special. |
||||||
|
if {![string length $path]} return |
||||||
|
|
||||||
|
if {![file isdirectory $path]} { |
||||||
|
return -code error \ |
||||||
|
"The path \"$path\" is not a directory." |
||||||
|
} |
||||||
|
if {![file readable $path]} { |
||||||
|
return -code error \ |
||||||
|
"The path \"$path\" is not readable." |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::bench::Invoke {ip ver pkgdir} { |
||||||
|
variable self |
||||||
|
# Import remainder of the current configuration/settings. |
||||||
|
|
||||||
|
upvar 1 DATA DATA match match rmatch rmatch \ |
||||||
|
iters iters errors errors threads threads \ |
||||||
|
files files |
||||||
|
|
||||||
|
if {[string length $pkgdir]} { |
||||||
|
log::info "Benchmark $ver ($pkgdir) $ip" |
||||||
|
set idstr "$ip ($pkgdir)" |
||||||
|
} else { |
||||||
|
log::info "Benchmark $ver $ip" |
||||||
|
set idstr $ip |
||||||
|
} |
||||||
|
|
||||||
|
set DATA([list interp $idstr]) $ver |
||||||
|
|
||||||
|
set cmd [list $ip [file join $self libbench.tcl] \ |
||||||
|
-match $match \ |
||||||
|
-rmatch $rmatch \ |
||||||
|
-iters $iters \ |
||||||
|
-interp $ip \ |
||||||
|
-errors $errors \ |
||||||
|
-threads $threads \ |
||||||
|
-pkgdir $pkgdir \ |
||||||
|
] |
||||||
|
|
||||||
|
# Determine elapsed time per file, logged. |
||||||
|
set start [clock seconds] |
||||||
|
|
||||||
|
array set tmp {} |
||||||
|
|
||||||
|
if {$threads} { |
||||||
|
foreach f $files { lappend cmd $f } |
||||||
|
if {[catch { |
||||||
|
close [Process [open |$cmd r+]] |
||||||
|
} output]} { |
||||||
|
if {$errors} { |
||||||
|
error $::errorInfo |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
foreach file $files { |
||||||
|
log::info [file tail $file] |
||||||
|
if {[catch { |
||||||
|
close [Process [open |[linsert $cmd end $file] r+]] |
||||||
|
} output]} { |
||||||
|
if {$errors} { |
||||||
|
error $::errorInfo |
||||||
|
} else { |
||||||
|
continue |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
foreach desc [array names tmp] { |
||||||
|
set DATA([list desc $desc]) {} |
||||||
|
set DATA([list usec $desc $idstr]) $tmp($desc) |
||||||
|
} |
||||||
|
|
||||||
|
unset tmp |
||||||
|
set elapsed [expr {[clock seconds] - $start}] |
||||||
|
|
||||||
|
set hour [expr {$elapsed / 3600}] |
||||||
|
set min [expr {$elapsed / 60}] |
||||||
|
set sec [expr {$elapsed % 60}] |
||||||
|
log::info " [format %.2d:%.2d:%.2d $hour $min $sec] elapsed" |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::bench::Process {pipe} { |
||||||
|
while {1} { |
||||||
|
if {[eof $pipe]} break |
||||||
|
if {[gets $pipe line] < 0} break |
||||||
|
# AK: FUTURE: Log all lines?! |
||||||
|
#puts |$line| |
||||||
|
set line [string trim $line] |
||||||
|
if {[string equal $line ""]} continue |
||||||
|
|
||||||
|
Result |
||||||
|
Feedback |
||||||
|
# Unknown lines are printed. Future: Callback?! |
||||||
|
log::info $line |
||||||
|
} |
||||||
|
return $pipe |
||||||
|
} |
||||||
|
|
||||||
|
proc ::bench::Result {} { |
||||||
|
upvar 1 line line |
||||||
|
if {[lindex $line 0] ne "RESULT"} return |
||||||
|
upvar 2 tmp tmp |
||||||
|
foreach {_ desc result} $line break |
||||||
|
set tmp($desc) $result |
||||||
|
return -code continue |
||||||
|
} |
||||||
|
|
||||||
|
proc ::bench::Feedback {} { |
||||||
|
upvar 1 line line |
||||||
|
if {[lindex $line 0] ne "LOG"} return |
||||||
|
# AK: Future - Run through callback?! |
||||||
|
log::info [lindex $line 1] |
||||||
|
return -code continue |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Initialize internal data structures. |
||||||
|
|
||||||
|
namespace eval ::bench { |
||||||
|
variable self [file join [pwd] [file dirname [info script]]] |
||||||
|
|
||||||
|
logger::init bench |
||||||
|
logger::import -force -all -namespace log bench |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Ready to run |
||||||
|
|
||||||
|
package provide bench 0.6 |
||||||
@ -0,0 +1,162 @@ |
|||||||
|
# bench_read.tcl -- |
||||||
|
# |
||||||
|
# Management of benchmarks, reading results in various formats. |
||||||
|
# |
||||||
|
# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||||
|
# library derived from runbench.tcl application (C) Jeff Hobbs. |
||||||
|
# |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: bench_read.tcl,v 1.3 2006/06/13 23:20:30 andreas_kupries Exp $ |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Requisites - Packages and namespace for the commands and data. |
||||||
|
|
||||||
|
package require Tcl 8.5 9 |
||||||
|
package require csv |
||||||
|
|
||||||
|
namespace eval ::bench::in {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Public API - Result reading |
||||||
|
|
||||||
|
# ::bench::in::read -- |
||||||
|
# |
||||||
|
# Read a bench result in any of the raw/csv/text formats |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# path to file to read |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# DATA dictionary, internal representation of the bench results. |
||||||
|
|
||||||
|
proc ::bench::in::read {file} { |
||||||
|
|
||||||
|
set f [open $file r] |
||||||
|
set head [gets $f] |
||||||
|
|
||||||
|
if {![string match "# -\\*- tcl -\\*- bench/*" $head]} { |
||||||
|
return -code error "Bad file format, not a benchmark file" |
||||||
|
} else { |
||||||
|
regexp {bench/(.*)$} $head -> format |
||||||
|
|
||||||
|
switch -exact -- $format { |
||||||
|
raw - csv - text { |
||||||
|
set res [RD$format $f] |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "Bad format \"$val\", expected text, csv, or raw" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
close $f |
||||||
|
return $res |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Internal commands |
||||||
|
|
||||||
|
proc ::bench::in::RDraw {chan} { |
||||||
|
return [string trimright [::read $chan]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::bench::in::RDcsv {chan} { |
||||||
|
# Lines Format |
||||||
|
# First line is number of interpreters #n. int |
||||||
|
# Next to 1+n is interpreter data. id,ver,path |
||||||
|
# Beyond is benchmark results. id,desc,res1,...,res#n |
||||||
|
|
||||||
|
array set DATA {} |
||||||
|
|
||||||
|
# #Interp ... |
||||||
|
|
||||||
|
set nip [lindex [csv::split [gets $chan]] 0] |
||||||
|
|
||||||
|
# Interp data ... |
||||||
|
|
||||||
|
set iplist {} |
||||||
|
for {set i 0} {$i < $nip} {incr i} { |
||||||
|
foreach {__ ver ip} [csv::split [gets $chan]] break |
||||||
|
|
||||||
|
set DATA([list interp $ip]) $ver |
||||||
|
lappend iplist $ip |
||||||
|
} |
||||||
|
|
||||||
|
# Benchmark data ... |
||||||
|
|
||||||
|
while {[gets $chan line] >= 0} { |
||||||
|
set line [string trim $line] |
||||||
|
if {$line == {}} break |
||||||
|
set line [csv::split $line] |
||||||
|
set desc [lindex $line 1] |
||||||
|
|
||||||
|
set DATA([list desc $desc]) {} |
||||||
|
foreach val [lrange $line 2 end] ip $iplist { |
||||||
|
if {$val == {}} continue |
||||||
|
set DATA([list usec $desc $ip]) $val |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return [array get DATA] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::bench::in::RDtext {chan} { |
||||||
|
array set DATA {} |
||||||
|
|
||||||
|
# Interp data ... |
||||||
|
|
||||||
|
# Empty line - ignore |
||||||
|
# "id: ver path" - interp data. |
||||||
|
# Empty line - separator before benchmark data. |
||||||
|
|
||||||
|
set n 0 |
||||||
|
set iplist {} |
||||||
|
while {[gets $chan line] >= 0} { |
||||||
|
set line [string trim $line] |
||||||
|
if {$line == {}} { |
||||||
|
incr n |
||||||
|
if {$n == 2} break |
||||||
|
continue |
||||||
|
} |
||||||
|
|
||||||
|
regexp {[^:]+: ([^ ]+) (.*)$} $line -> ver ip |
||||||
|
set DATA([list interp $ip]) $ver |
||||||
|
lappend iplist $ip |
||||||
|
} |
||||||
|
|
||||||
|
# Benchmark data ... |
||||||
|
|
||||||
|
# '---' -> Ignore. |
||||||
|
# '|' column separators. Remove spaces around it. Then treat line |
||||||
|
# as CSV data with a particular separator. |
||||||
|
# Ignore the INTERP line. |
||||||
|
|
||||||
|
while {[gets $chan line] >= 0} { |
||||||
|
set line [string trim $line] |
||||||
|
if {$line == {}} continue |
||||||
|
if {[string match "+---*" $line]} continue |
||||||
|
if {[string match "*INTERP*" $line]} continue |
||||||
|
|
||||||
|
regsub -all "\\| +" $line {|} line |
||||||
|
regsub -all " +\\|" $line {|} line |
||||||
|
set line [csv::split [string trim $line |] |] |
||||||
|
set desc [lindex $line 1] |
||||||
|
|
||||||
|
set DATA([list desc $desc]) {} |
||||||
|
foreach val [lrange $line 2 end] ip $iplist { |
||||||
|
if {$val == {}} continue |
||||||
|
set DATA([list usec $desc $ip]) $val |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return [array get DATA] |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Initialize internal data structures. |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Ready to run |
||||||
|
|
||||||
|
package provide bench::in 0.2 |
||||||
@ -0,0 +1,101 @@ |
|||||||
|
# bench_wtext.tcl -- |
||||||
|
# |
||||||
|
# Management of benchmarks, formatted text. |
||||||
|
# |
||||||
|
# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||||
|
# library derived from runbench.tcl application (C) Jeff Hobbs. |
||||||
|
# |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: bench_wcsv.tcl,v 1.4 2007/01/21 23:29:06 andreas_kupries Exp $ |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Requisites - Packages and namespace for the commands and data. |
||||||
|
|
||||||
|
package require Tcl 8.5 9 |
||||||
|
package require csv |
||||||
|
|
||||||
|
namespace eval ::bench::out {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Public API - Benchmark execution |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Public API - Result formatting. |
||||||
|
|
||||||
|
# ::bench::out::csv -- |
||||||
|
# |
||||||
|
# Format the result of a benchmark run. |
||||||
|
# Style: CSV |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# DATA dict |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# String containing the formatted DATA. |
||||||
|
|
||||||
|
proc ::bench::out::csv {data} { |
||||||
|
array set DATA $data |
||||||
|
set CSV {} |
||||||
|
|
||||||
|
# 1st record: #shells |
||||||
|
# 2nd record to #shells+1: Interpreter data (id, version, path) |
||||||
|
# #shells+2 to end: Benchmark data (id,desc,result1,...,result#shells) |
||||||
|
|
||||||
|
# --- --- ---- |
||||||
|
# #interpreters used |
||||||
|
|
||||||
|
set ipkeys [array names DATA interp*] |
||||||
|
lappend CSV [csv::join [list [llength $ipkeys]]] |
||||||
|
|
||||||
|
# --- --- ---- |
||||||
|
# Table 1: Interpreter information. |
||||||
|
|
||||||
|
set n 1 |
||||||
|
set iplist {} |
||||||
|
foreach key [lsort -dict $ipkeys] { |
||||||
|
set ip [lindex $key 1] |
||||||
|
lappend CSV [csv::join [list $n $DATA($key) $ip]] |
||||||
|
set DATA($key) $n |
||||||
|
incr n |
||||||
|
lappend iplist $ip |
||||||
|
} |
||||||
|
|
||||||
|
# --- --- ---- |
||||||
|
# Table 2: Benchmark information |
||||||
|
|
||||||
|
set dlist {} |
||||||
|
foreach key [lsort -dict -index 1 [array names DATA desc*]] { |
||||||
|
lappend dlist [lindex $key 1] |
||||||
|
} |
||||||
|
|
||||||
|
set n 1 |
||||||
|
foreach desc $dlist { |
||||||
|
set record {} |
||||||
|
lappend record $n |
||||||
|
lappend record $desc |
||||||
|
foreach ip $iplist { |
||||||
|
if {[catch { |
||||||
|
lappend record $DATA([list usec $desc $ip]) |
||||||
|
}]} { |
||||||
|
lappend record {} |
||||||
|
} |
||||||
|
} |
||||||
|
lappend CSV [csv::join $record] |
||||||
|
incr n |
||||||
|
} |
||||||
|
|
||||||
|
return [join $CSV \n] |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Internal commands |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Initialize internal data structures. |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Ready to run |
||||||
|
|
||||||
|
package provide bench::out::csv 0.1.3 |
||||||
@ -0,0 +1,165 @@ |
|||||||
|
# bench_wtext.tcl -- |
||||||
|
# |
||||||
|
# Management of benchmarks, formatted text. |
||||||
|
# |
||||||
|
# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||||
|
# library derived from runbench.tcl application (C) Jeff Hobbs. |
||||||
|
# |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: bench_wtext.tcl,v 1.4 2007/01/21 23:29:06 andreas_kupries Exp $ |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Requisites - Packages and namespace for the commands and data. |
||||||
|
|
||||||
|
package require Tcl 8.5 9 |
||||||
|
package require struct::matrix |
||||||
|
package require report |
||||||
|
|
||||||
|
namespace eval ::bench::out {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Public API - Result formatting. |
||||||
|
|
||||||
|
# ::bench::out::text -- |
||||||
|
# |
||||||
|
# Format the result of a benchmark run. |
||||||
|
# Style: TEXT |
||||||
|
# |
||||||
|
# General structure like CSV, but nicely formatted and aligned |
||||||
|
# columns. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# DATA dict |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# String containing the formatted DATA. |
||||||
|
|
||||||
|
proc ::bench::out::text {data} { |
||||||
|
array set DATA $data |
||||||
|
set LINES {} |
||||||
|
|
||||||
|
# 1st line to #shells: Interpreter data (id, version, path) |
||||||
|
# #shells+1 to end: Benchmark data (id,desc,result1,...,result#shells) |
||||||
|
|
||||||
|
lappend LINES {} |
||||||
|
|
||||||
|
# --- --- ---- |
||||||
|
# Table 1: Interpreter information. |
||||||
|
|
||||||
|
set ipkeys [array names DATA interp*] |
||||||
|
set n 1 |
||||||
|
set iplist {} |
||||||
|
set vlen 0 |
||||||
|
foreach key [lsort -dict $ipkeys] { |
||||||
|
lappend iplist [lindex $key 1] |
||||||
|
incr n |
||||||
|
set l [string length $DATA($key)] |
||||||
|
if {$l > $vlen} {set vlen $l} |
||||||
|
} |
||||||
|
set idlen [string length $n] |
||||||
|
|
||||||
|
set dlist {} |
||||||
|
set n 1 |
||||||
|
foreach key [lsort -dict -index 1 [array names DATA desc*]] { |
||||||
|
lappend dlist [lindex $key 1] |
||||||
|
incr n |
||||||
|
} |
||||||
|
set didlen [string length $n] |
||||||
|
|
||||||
|
set n 1 |
||||||
|
set record [list "" INTERP] |
||||||
|
foreach ip $iplist { |
||||||
|
set v $DATA([list interp $ip]) |
||||||
|
lappend LINES " [PADL $idlen $n]: [PADR $vlen $v] $ip" |
||||||
|
lappend record $n |
||||||
|
incr n |
||||||
|
} |
||||||
|
|
||||||
|
lappend LINES {} |
||||||
|
|
||||||
|
# --- --- ---- |
||||||
|
# Table 2: Benchmark information |
||||||
|
|
||||||
|
set m [struct::matrix m] |
||||||
|
$m add columns [expr {2 + [llength $iplist]}] |
||||||
|
$m add row $record |
||||||
|
|
||||||
|
set n 1 |
||||||
|
foreach desc $dlist { |
||||||
|
set record [list $n] |
||||||
|
lappend record $desc |
||||||
|
|
||||||
|
foreach ip $iplist { |
||||||
|
if {[catch { |
||||||
|
set val $DATA([list usec $desc $ip]) |
||||||
|
}]} { |
||||||
|
set val {} |
||||||
|
} |
||||||
|
if {[string is double -strict $val]} { |
||||||
|
lappend record [format %.2f $val] |
||||||
|
} else { |
||||||
|
lappend record [format %s $val] |
||||||
|
} |
||||||
|
} |
||||||
|
$m add row $record |
||||||
|
incr n |
||||||
|
} |
||||||
|
|
||||||
|
::report::defstyle simpletable {} { |
||||||
|
data set [split "[string repeat "| " [columns]]|"] |
||||||
|
top set [split "[string repeat "+ - " [columns]]+"] |
||||||
|
bottom set [top get] |
||||||
|
top enable |
||||||
|
bottom enable |
||||||
|
|
||||||
|
set c [columns] |
||||||
|
justify 0 right |
||||||
|
pad 0 both |
||||||
|
|
||||||
|
if {$c > 1} { |
||||||
|
justify 1 left |
||||||
|
pad 1 both |
||||||
|
} |
||||||
|
for {set i 2} {$i < $c} {incr i} { |
||||||
|
justify $i right |
||||||
|
pad $i both |
||||||
|
} |
||||||
|
} |
||||||
|
::report::defstyle captionedtable {{n 1}} { |
||||||
|
simpletable |
||||||
|
topdata set [data get] |
||||||
|
topcapsep set [top get] |
||||||
|
topcapsep enable |
||||||
|
tcaption $n |
||||||
|
} |
||||||
|
|
||||||
|
set r [report::report r [$m columns] style captionedtable] |
||||||
|
lappend LINES [$m format 2string $r] |
||||||
|
$m destroy |
||||||
|
$r destroy |
||||||
|
|
||||||
|
return [join $LINES \n] |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Internal commands |
||||||
|
|
||||||
|
proc ::bench::out::PADL {max str} { |
||||||
|
format "%${max}s" $str |
||||||
|
#return "[PAD $max $str]$str" |
||||||
|
} |
||||||
|
|
||||||
|
proc ::bench::out::PADR {max str} { |
||||||
|
format "%-${max}s" $str |
||||||
|
#return "$str[PAD $max $str]" |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Initialize internal data structures. |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### ########################### |
||||||
|
## Ready to run |
||||||
|
|
||||||
|
package provide bench::out::text 0.1.3 |
||||||
@ -0,0 +1,561 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# libbench.tcl ?(<option> <value>)...? <benchFile>... |
||||||
|
# |
||||||
|
# This file has to have code that works in any version of Tcl that |
||||||
|
# the user would want to benchmark. |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: libbench.tcl,v 1.4 2008/07/02 23:34:06 andreas_kupries Exp $ |
||||||
|
# |
||||||
|
# Copyright (c) 2000-2001 Jeffrey Hobbs. |
||||||
|
# Copyright (c) 2007 Andreas Kupries |
||||||
|
# |
||||||
|
|
||||||
|
# This code provides the supporting commands for the execution of a |
||||||
|
# benchmark files. It is actually an application and is exec'd by the |
||||||
|
# management code. |
||||||
|
|
||||||
|
# Options: |
||||||
|
# -help Print usage message. |
||||||
|
# -rmatch <regexp-pattern> Run only tests whose description matches the pattern. |
||||||
|
# -match <glob-pattern> Run only tests whose description matches the pattern. |
||||||
|
# -interp <name> Name of the interp running the benchmarks. |
||||||
|
# -thread <num> Invoke threaded benchmarks, number of threads to use. |
||||||
|
# -errors <boolean> Throw errors, or not. |
||||||
|
|
||||||
|
# Note: If both -match and -rmatch are specified then _both_ |
||||||
|
# apply. I.e. a benchmark will be run if and only if it matches both |
||||||
|
# patterns. |
||||||
|
|
||||||
|
# Application activity and results are communicated to the highlevel |
||||||
|
# management via text written to stdout. Each line written is a list |
||||||
|
# and has one of the following forms: |
||||||
|
# |
||||||
|
# __THREADED <version> - Indicates threaded mode, and version |
||||||
|
# of package Thread in use. |
||||||
|
# |
||||||
|
# Sourcing {<desc>: <res>} - Benchmark <desc> has started. |
||||||
|
# <res> is the result from executing |
||||||
|
# it once (compilation of body.) |
||||||
|
# |
||||||
|
# Sourcing <file> - Benchmark file <file> starts execution. |
||||||
|
# |
||||||
|
# <desc> <res> - Result of a benchmark. |
||||||
|
# |
||||||
|
# The above implies that no benchmark may use the strings 'Sourcing' |
||||||
|
# or '__THREADED' as their description. |
||||||
|
|
||||||
|
# We will put our data into these named globals. |
||||||
|
|
||||||
|
global BENCH bench |
||||||
|
|
||||||
|
# 'BENCH' contents: |
||||||
|
# |
||||||
|
# - ERRORS : Boolean flag. If set benchmark output mismatches are |
||||||
|
# reported by throwing an error. Otherwise they are simply |
||||||
|
# listed as BAD_RES. Default true. Can be set/reset via |
||||||
|
# option -errors. |
||||||
|
# |
||||||
|
# - MATCH : Match pattern, see -match, default empty, aka everything |
||||||
|
# matches. |
||||||
|
# |
||||||
|
# - RMATCH : Match pattern, see -rmatch, default empty, aka |
||||||
|
# everything matches. |
||||||
|
# |
||||||
|
# - OUTFILE : Name of output file, default is special value "stdout". |
||||||
|
# - OUTFID : Channel for output. |
||||||
|
# |
||||||
|
# The outfile cannot be set by the caller, thus output is always |
||||||
|
# written to stdout. |
||||||
|
# |
||||||
|
# - FILES : List of benchmark files to run. |
||||||
|
# |
||||||
|
# - ITERS : Number of iterations to run a benchmark body, default |
||||||
|
# 1000. Can be overridden by the individual benchmarks. |
||||||
|
# |
||||||
|
# - THREADS : Number of threads to use. 0 signals no threading. |
||||||
|
# Limited to number of files if there are less files than |
||||||
|
# requested threads. |
||||||
|
# |
||||||
|
# - EXIT : Boolean flag. True when appplication is run by wish, for |
||||||
|
# special exit processing. ... Actually always true. |
||||||
|
# |
||||||
|
# - INTERP : Name of the interpreter running the benchmarks. Is the |
||||||
|
# executable running this code. Can be overridden via the |
||||||
|
# command line option -interp. |
||||||
|
# |
||||||
|
# - uniqid : Counter for 'bench_tmpfile' to generate unique names of |
||||||
|
# tmp files. |
||||||
|
# |
||||||
|
# - us : Thread id of main thread. |
||||||
|
# |
||||||
|
# - inuse : Number of threads active, present and relevant only in |
||||||
|
# threaded mode. |
||||||
|
# |
||||||
|
# - file : Currently executed benchmark file. Relevant only in |
||||||
|
# non-threaded mode. |
||||||
|
|
||||||
|
# |
||||||
|
# 'bench' contents. |
||||||
|
|
||||||
|
# Benchmark results, mapping from the benchmark descriptions to their |
||||||
|
# results. Usually time in microseconds, but the following special |
||||||
|
# values can occur: |
||||||
|
# |
||||||
|
# - BAD_RES - Result from benchmark body does not match expectations. |
||||||
|
# - ERR - Benchmark body aborted with an error. |
||||||
|
# - Any string - Forced by error code 666 to pass to management. |
||||||
|
|
||||||
|
# |
||||||
|
# We claim all procedures starting with bench* |
||||||
|
# |
||||||
|
|
||||||
|
# bench_tmpfile -- |
||||||
|
# |
||||||
|
# Return a temp file name that can be modified at will |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# None |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# Returns file name |
||||||
|
# |
||||||
|
proc bench_tmpfile {} { |
||||||
|
global tcl_platform env BENCH |
||||||
|
if {![info exists BENCH(uniqid)]} { set BENCH(uniqid) 0 } |
||||||
|
set base "tclbench[incr BENCH(uniqid)].dat" |
||||||
|
if {[info exists tcl_platform(platform)]} { |
||||||
|
if {$tcl_platform(platform) == "unix"} { |
||||||
|
return "/tmp/$base" |
||||||
|
} elseif {$tcl_platform(platform) == "windows"} { |
||||||
|
return [file join $env(TEMP) $base] |
||||||
|
} else { |
||||||
|
return $base |
||||||
|
} |
||||||
|
} else { |
||||||
|
# The Good Ol' Days (?) when only Unix support existed |
||||||
|
return "/tmp/$base" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# bench_rm -- |
||||||
|
# |
||||||
|
# Remove a file silently (no complaining) |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# args Files to delete |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# Returns nothing |
||||||
|
# |
||||||
|
proc bench_rm {args} { |
||||||
|
foreach file $args { |
||||||
|
if {[info tclversion] > 7.4} { |
||||||
|
catch {file delete $file} |
||||||
|
} else { |
||||||
|
catch {exec /bin/rm $file} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc bench_puts {args} { |
||||||
|
eval [linsert $args 0 FEEDBACK] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# bench -- |
||||||
|
# |
||||||
|
# Main bench procedure. |
||||||
|
# The bench test is expected to exit cleanly. If an error occurs, |
||||||
|
# it will be thrown all the way up. A bench proc may return the |
||||||
|
# special code 666, which says take the string as the bench value. |
||||||
|
# This is usually used for N/A feature situations. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# |
||||||
|
# -pre script to run before main timed body |
||||||
|
# -body script to run as main timed body |
||||||
|
# -post script to run after main timed body |
||||||
|
# -ipre script to run before timed body, per iteration of the body. |
||||||
|
# -ipost script to run after timed body, per iteration of the body. |
||||||
|
# -desc message text |
||||||
|
# -iterations <#> |
||||||
|
# |
||||||
|
# Note: |
||||||
|
# |
||||||
|
# Using -ipre and/or -ipost will cause us to compute the average |
||||||
|
# time ourselves, i.e. 'time body 1' n times. Required to ensure |
||||||
|
# that prefix/post operation are executed, yet not timed themselves. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# |
||||||
|
# Returns nothing |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
# |
||||||
|
# Sets up data in bench global array |
||||||
|
# |
||||||
|
proc bench {args} { |
||||||
|
global BENCH bench errorInfo errorCode |
||||||
|
|
||||||
|
# -pre script |
||||||
|
# -body script |
||||||
|
# -desc msg |
||||||
|
# -post script |
||||||
|
# -ipre script |
||||||
|
# -ipost script |
||||||
|
# -iterations <#> |
||||||
|
array set opts { |
||||||
|
-pre {} |
||||||
|
-body {} |
||||||
|
-desc {} |
||||||
|
-post {} |
||||||
|
-ipre {} |
||||||
|
-ipost {} |
||||||
|
} |
||||||
|
set opts(-iter) $BENCH(ITERS) |
||||||
|
while {[llength $args]} { |
||||||
|
set key [lindex $args 0] |
||||||
|
switch -glob -- $key { |
||||||
|
-res* { set opts(-res) [lindex $args 1] } |
||||||
|
-pr* { set opts(-pre) [lindex $args 1] } |
||||||
|
-po* { set opts(-post) [lindex $args 1] } |
||||||
|
-ipr* { set opts(-ipre) [lindex $args 1] } |
||||||
|
-ipo* { set opts(-ipost) [lindex $args 1] } |
||||||
|
-bo* { set opts(-body) [lindex $args 1] } |
||||||
|
-de* { set opts(-desc) [lindex $args 1] } |
||||||
|
-it* { |
||||||
|
# Only change the iterations when it is smaller than |
||||||
|
# the requested default |
||||||
|
set val [lindex $args 1] |
||||||
|
if {$opts(-iter) > $val} { set opts(-iter) $val } |
||||||
|
} |
||||||
|
default { |
||||||
|
error "unknown option $key" |
||||||
|
} |
||||||
|
} |
||||||
|
set args [lreplace $args 0 1] |
||||||
|
} |
||||||
|
|
||||||
|
FEEDBACK "Running <$opts(-desc)>" |
||||||
|
|
||||||
|
if {($BENCH(MATCH) != "") && ![string match $BENCH(MATCH) $opts(-desc)]} { |
||||||
|
return |
||||||
|
} |
||||||
|
if {($BENCH(RMATCH) != "") && ![regexp $BENCH(RMATCH) $opts(-desc)]} { |
||||||
|
return |
||||||
|
} |
||||||
|
if {$opts(-pre) != ""} { |
||||||
|
uplevel \#0 $opts(-pre) |
||||||
|
} |
||||||
|
if {$opts(-body) != ""} { |
||||||
|
# always run it once to remove compile phase confusion |
||||||
|
if {$opts(-ipre) != ""} { |
||||||
|
uplevel \#0 $opts(-ipre) |
||||||
|
} |
||||||
|
set code [catch {uplevel \#0 $opts(-body)} res] |
||||||
|
if {$opts(-ipost) != ""} { |
||||||
|
uplevel \#0 $opts(-ipost) |
||||||
|
} |
||||||
|
if {!$code && [info exists opts(-res)] \ |
||||||
|
&& [string compare $opts(-res) $res]} { |
||||||
|
if {$BENCH(ERRORS)} { |
||||||
|
return -code error "Result was:\n$res\nResult\ |
||||||
|
should have been:\n$opts(-res)" |
||||||
|
} else { |
||||||
|
set res "BAD_RES" |
||||||
|
} |
||||||
|
#set bench($opts(-desc)) $res |
||||||
|
RESULT $opts(-desc) $res |
||||||
|
} else { |
||||||
|
if {($opts(-ipre) != "") || ($opts(-ipost) != "")} { |
||||||
|
# We do the averaging on our own, to allow untimed |
||||||
|
# pre/post execution per iteration. We catch and |
||||||
|
# handle problems in the pre/post code as if |
||||||
|
# everything was executed as one block (like it would |
||||||
|
# be in the other path). We are using floating point |
||||||
|
# to avoid integer overflow, easily happening when |
||||||
|
# accumulating a high number (iterations) of large |
||||||
|
# integers (microseconds). |
||||||
|
|
||||||
|
set total 0.0 |
||||||
|
for {set i 0} {$i < $opts(-iter)} {incr i} { |
||||||
|
set code 0 |
||||||
|
if {$opts(-ipre) != ""} { |
||||||
|
set code [catch {uplevel \#0 $opts(-ipre)} res] |
||||||
|
if {$code} break |
||||||
|
} |
||||||
|
set code [catch {uplevel \#0 [list time $opts(-body) 1]} res] |
||||||
|
if {$code} break |
||||||
|
set total [expr {$total + [lindex $res 0]}] |
||||||
|
if {$opts(-ipost) != ""} { |
||||||
|
set code [catch {uplevel \#0 $opts(-ipost)} res] |
||||||
|
if {$code} break |
||||||
|
} |
||||||
|
} |
||||||
|
if {!$code} { |
||||||
|
set res [list [expr {int ($total/$opts(-iter))}] microseconds per iteration] |
||||||
|
} |
||||||
|
} else { |
||||||
|
set code [catch {uplevel \#0 \ |
||||||
|
[list time $opts(-body) $opts(-iter)]} res] |
||||||
|
} |
||||||
|
if {!$BENCH(THREADS)} { |
||||||
|
if {$code == 0} { |
||||||
|
# Get just the microseconds value from the time result |
||||||
|
set res [lindex $res 0] |
||||||
|
} elseif {$code != 666} { |
||||||
|
# A 666 result code means pass it through to the bench |
||||||
|
# suite. Otherwise throw errors all the way out, unless |
||||||
|
# we specified not to throw errors (option -errors 0 to |
||||||
|
# libbench). |
||||||
|
if {$BENCH(ERRORS)} { |
||||||
|
return -code $code -errorinfo $errorInfo \ |
||||||
|
-errorcode $errorCode |
||||||
|
} else { |
||||||
|
set res "ERR" |
||||||
|
} |
||||||
|
} |
||||||
|
#set bench($opts(-desc)) $res |
||||||
|
RESULT $opts(-desc) $res |
||||||
|
} else { |
||||||
|
# Threaded runs report back asynchronously |
||||||
|
thread::send $BENCH(us) \ |
||||||
|
[list thread_report $opts(-desc) $code $res] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {($opts(-post) != "") && [catch {uplevel \#0 $opts(-post)} err] \ |
||||||
|
&& $BENCH(ERRORS)} { |
||||||
|
return -code error "post code threw error:\n$err" |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc RESULT {desc time} { |
||||||
|
global BENCH |
||||||
|
puts $BENCH(OUTFID) [list RESULT $desc $time] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc FEEDBACK {text} { |
||||||
|
global BENCH |
||||||
|
puts $BENCH(OUTFID) [list LOG $text] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc usage {} { |
||||||
|
set me [file tail [info script]] |
||||||
|
puts stderr "Usage: $me ?options?\ |
||||||
|
\n\t-help # print out this message\ |
||||||
|
\n\t-rmatch <regexp> # only run tests matching this pattern\ |
||||||
|
\n\t-match <glob> # only run tests matching this pattern\ |
||||||
|
\n\t-interp <name> # name of interp (tries to get it right)\ |
||||||
|
\n\t-thread <num> # number of threads to use\ |
||||||
|
\n\tfileList # files to benchmark" |
||||||
|
exit 1 |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# Process args |
||||||
|
# |
||||||
|
if {[catch {set BENCH(INTERP) [info nameofexec]}]} { |
||||||
|
set BENCH(INTERP) $argv0 |
||||||
|
} |
||||||
|
foreach {var val} { |
||||||
|
ERRORS 1 |
||||||
|
MATCH {} |
||||||
|
RMATCH {} |
||||||
|
OUTFILE stdout |
||||||
|
FILES {} |
||||||
|
ITERS 1000 |
||||||
|
THREADS 0 |
||||||
|
PKGDIR {} |
||||||
|
EXIT "[info exists tk_version]" |
||||||
|
} { |
||||||
|
if {![info exists BENCH($var)]} { |
||||||
|
set BENCH($var) [subst $val] |
||||||
|
} |
||||||
|
} |
||||||
|
set BENCH(EXIT) 1 |
||||||
|
|
||||||
|
if {[llength $argv]} { |
||||||
|
while {[llength $argv]} { |
||||||
|
set key [lindex $argv 0] |
||||||
|
switch -glob -- $key { |
||||||
|
-help* { usage } |
||||||
|
-err* { set BENCH(ERRORS) [lindex $argv 1] } |
||||||
|
-int* { set BENCH(INTERP) [lindex $argv 1] } |
||||||
|
-rmat* { set BENCH(RMATCH) [lindex $argv 1] } |
||||||
|
-mat* { set BENCH(MATCH) [lindex $argv 1] } |
||||||
|
-iter* { set BENCH(ITERS) [lindex $argv 1] } |
||||||
|
-thr* { set BENCH(THREADS) [lindex $argv 1] } |
||||||
|
-pkg* { set BENCH(PKGDIR) [lindex $argv 1] } |
||||||
|
default { |
||||||
|
foreach arg $argv { |
||||||
|
if {![file exists $arg]} { usage } |
||||||
|
lappend BENCH(FILES) $arg |
||||||
|
} |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
set argv [lreplace $argv 0 1] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[string length $BENCH(PKGDIR)]} { |
||||||
|
set auto_path [linsert $auto_path 0 $BENCH(PKGDIR)] |
||||||
|
} |
||||||
|
|
||||||
|
if {$BENCH(THREADS)} { |
||||||
|
# We have to be able to load threads if we want to use threads, and |
||||||
|
# we don't want to create more threads than we have files. |
||||||
|
if {[catch {package require Thread}]} { |
||||||
|
set BENCH(THREADS) 0 |
||||||
|
} elseif {[llength $BENCH(FILES)] < $BENCH(THREADS)} { |
||||||
|
set BENCH(THREADS) [llength $BENCH(FILES)] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
rename exit exit.true |
||||||
|
proc exit args { |
||||||
|
error "called \"exit $args\" in benchmark test" |
||||||
|
} |
||||||
|
|
||||||
|
if {[string compare $BENCH(OUTFILE) stdout]} { |
||||||
|
set BENCH(OUTFID) [open $BENCH(OUTFILE) w] |
||||||
|
} else { |
||||||
|
set BENCH(OUTFID) stdout |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# Everything that gets output must be in pairwise format, because |
||||||
|
# the data will be collected in via an 'array set'. |
||||||
|
# |
||||||
|
|
||||||
|
if {$BENCH(THREADS)} { |
||||||
|
# Each file must run in it's own thread because of all the extra |
||||||
|
# header stuff they have. |
||||||
|
#set DEBUG 1 |
||||||
|
proc thread_one {{id 0}} { |
||||||
|
global BENCH |
||||||
|
set file [lindex $BENCH(FILES) 0] |
||||||
|
set BENCH(FILES) [lrange $BENCH(FILES) 1 end] |
||||||
|
if {[file exists $file]} { |
||||||
|
incr BENCH(inuse) |
||||||
|
FEEDBACK [list Sourcing $file] |
||||||
|
if {$id} { |
||||||
|
set them $id |
||||||
|
} else { |
||||||
|
set them [thread::create] |
||||||
|
thread::send -async $them { load {} Thread } |
||||||
|
thread::send -async $them \ |
||||||
|
[list array set BENCH [array get BENCH]] |
||||||
|
thread::send -async $them \ |
||||||
|
[list proc bench_tmpfile {} [info body bench_tmpfile]] |
||||||
|
thread::send -async $them \ |
||||||
|
[list proc bench_rm {args} [info body bench_rm]] |
||||||
|
thread::send -async $them \ |
||||||
|
[list proc bench {args} [info body bench]] |
||||||
|
} |
||||||
|
if {[info exists ::DEBUG]} { |
||||||
|
FEEDBACK "SEND [clock seconds] thread $them $file INUSE\ |
||||||
|
$BENCH(inuse) of $BENCH(THREADS)" |
||||||
|
} |
||||||
|
thread::send -async $them [list source $file] |
||||||
|
thread::send -async $them \ |
||||||
|
[list thread::send $BENCH(us) [list thread_ready $them]] |
||||||
|
#thread::send -async $them { thread::unwind } |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc thread_em {} { |
||||||
|
global BENCH |
||||||
|
while {[llength $BENCH(FILES)]} { |
||||||
|
if {[info exists ::DEBUG]} { |
||||||
|
FEEDBACK "THREAD ONE [lindex $BENCH(FILES) 0]" |
||||||
|
} |
||||||
|
thread_one |
||||||
|
if {$BENCH(inuse) >= $BENCH(THREADS)} { |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc thread_ready {id} { |
||||||
|
global BENCH |
||||||
|
|
||||||
|
incr BENCH(inuse) -1 |
||||||
|
if {[llength $BENCH(FILES)]} { |
||||||
|
if {[info exists ::DEBUG]} { |
||||||
|
FEEDBACK "SEND ONE [clock seconds] thread $id" |
||||||
|
} |
||||||
|
thread_one $id |
||||||
|
} else { |
||||||
|
if {[info exists ::DEBUG]} { |
||||||
|
FEEDBACK "UNWIND thread $id" |
||||||
|
} |
||||||
|
thread::send -async $id { thread::unwind } |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc thread_report {desc code res} { |
||||||
|
global BENCH bench errorInfo errorCode |
||||||
|
|
||||||
|
if {$code == 0} { |
||||||
|
# Get just the microseconds value from the time result |
||||||
|
set res [lindex $res 0] |
||||||
|
} elseif {$code != 666} { |
||||||
|
# A 666 result code means pass it through to the bench suite. |
||||||
|
# Otherwise throw errors all the way out, unless we specified |
||||||
|
# not to throw errors (option -errors 0 to libbench). |
||||||
|
if {$BENCH(ERRORS)} { |
||||||
|
return -code $code -errorinfo $errorInfo \ |
||||||
|
-errorcode $errorCode |
||||||
|
} else { |
||||||
|
set res "ERR" |
||||||
|
} |
||||||
|
} |
||||||
|
#set bench($desc) $res |
||||||
|
RESULT $desc $res |
||||||
|
} |
||||||
|
|
||||||
|
proc thread_finish {{delay 4000}} { |
||||||
|
global BENCH bench |
||||||
|
set val [expr {[llength [thread::names]] > 1}] |
||||||
|
#set val [expr {$BENCH(inuse)}] |
||||||
|
if {$val} { |
||||||
|
after $delay [info level 0] |
||||||
|
} else { |
||||||
|
if {0} {foreach desc [array names bench] { |
||||||
|
RESULT $desc $bench($desc) |
||||||
|
}} |
||||||
|
if {$BENCH(EXIT)} { |
||||||
|
exit.true ; # needed for Tk tests |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set BENCH(us) [thread::id] |
||||||
|
set BENCH(inuse) 0 ; # num threads in use |
||||||
|
FEEDBACK [list __THREADED [package provide Thread]] |
||||||
|
|
||||||
|
thread_em |
||||||
|
thread_finish |
||||||
|
vwait forever |
||||||
|
} else { |
||||||
|
foreach BENCH(file) $BENCH(FILES) { |
||||||
|
if {[file exists $BENCH(file)]} { |
||||||
|
FEEDBACK [list Sourcing $BENCH(file)] |
||||||
|
source $BENCH(file) |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {0} {foreach desc [array names bench] { |
||||||
|
RESULT $desc $bench($desc) |
||||||
|
}} |
||||||
|
|
||||||
|
if {$BENCH(EXIT)} { |
||||||
|
exit.true ; # needed for Tk tests |
||||||
|
} |
||||||
|
} |
||||||
@ -0,0 +1,7 @@ |
|||||||
|
if {![package vsatisfies [package provide Tcl] 8.5 9]} { |
||||||
|
return |
||||||
|
} |
||||||
|
package ifneeded bench 0.6 [list source [file join $dir bench.tcl]] |
||||||
|
package ifneeded bench::out::text 0.1.3 [list source [file join $dir bench_wtext.tcl]] |
||||||
|
package ifneeded bench::out::csv 0.1.3 [list source [file join $dir bench_wcsv.tcl]] |
||||||
|
package ifneeded bench::in 0.2 [list source [file join $dir bench_read.tcl]] |
||||||
@ -0,0 +1,501 @@ |
|||||||
|
##### |
||||||
|
# |
||||||
|
# "BibTeX parser" |
||||||
|
# http://wiki.tcl.tk/13719 |
||||||
|
# |
||||||
|
# Tcl code harvested on: 7 Mar 2005, 23:55 GMT |
||||||
|
# Wiki page last updated: ??? |
||||||
|
# |
||||||
|
##### |
||||||
|
|
||||||
|
# bibtex.tcl -- |
||||||
|
# |
||||||
|
# A basic parser for BibTeX bibliography databases. |
||||||
|
# |
||||||
|
# Copyright (c) 2005 Neil Madden. |
||||||
|
# Copyright (c) 2005 Andreas Kupries. |
||||||
|
# License: Tcl/BSD style. |
||||||
|
|
||||||
|
### NOTES |
||||||
|
### |
||||||
|
### Need commands to introspect parser state. Especially the string |
||||||
|
### map (for testing of 'addStrings', should be useful in general as |
||||||
|
### well). |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requisites |
||||||
|
|
||||||
|
package require Tcl 8.5 9 |
||||||
|
package require cmdline |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Implementation: Public API |
||||||
|
|
||||||
|
namespace eval ::bibtex {} |
||||||
|
|
||||||
|
# bibtex::parse -- |
||||||
|
# |
||||||
|
# Parse a bibtex file. |
||||||
|
# |
||||||
|
# parse ?options? ?bibtex? |
||||||
|
|
||||||
|
proc ::bibtex::parse {args} { |
||||||
|
variable data |
||||||
|
variable id |
||||||
|
|
||||||
|
# Argument processing |
||||||
|
if {[llength $args] < 1} { |
||||||
|
set err "[lindex [info level 0] 0] ?options? ?bibtex?" |
||||||
|
return -code error "wrong # args: should be \"$err\"" |
||||||
|
} |
||||||
|
|
||||||
|
array set state {} |
||||||
|
GetOptions $args state |
||||||
|
|
||||||
|
# Initialize the parser state from the options, fill in default |
||||||
|
# values, and handle the input according the specified mode. |
||||||
|
|
||||||
|
set token bibtex[incr id] |
||||||
|
foreach {k v} [array get state] { |
||||||
|
set data($token,$k) $v |
||||||
|
} |
||||||
|
|
||||||
|
if {$state(stream)} { |
||||||
|
# Text not in memory |
||||||
|
if {!$state(bg)} { |
||||||
|
# Text from a channel, no async processing. We read everything |
||||||
|
# into memory and the handle it as before. |
||||||
|
|
||||||
|
set blockmode [fconfigure $state(-channel) -blocking] |
||||||
|
fconfigure $state(-channel) -blocking 1 |
||||||
|
set data($token,buffer) [read $state(-channel)] |
||||||
|
fconfigure $state(-channel) -blocking $blockmode |
||||||
|
|
||||||
|
# Tell upcoming processing that the text is in memory. |
||||||
|
set state(stream) 0 |
||||||
|
} else { |
||||||
|
# Text from a channel, and processing is async. Create an |
||||||
|
# event handler for the incoming data. |
||||||
|
|
||||||
|
set data($token,done) 0 |
||||||
|
fileevent $state(-channel) readable \ |
||||||
|
[list ::bibtex::ReadChan $token] |
||||||
|
|
||||||
|
# Initialize the parser internal result buffer if we use plain |
||||||
|
# -command, and not the SAX api. |
||||||
|
if {!$state(sax)} { |
||||||
|
set data($token,result) {} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Initialize the string mappings (none known), and the result |
||||||
|
# accumulator. |
||||||
|
set data($token,strings) {} |
||||||
|
set data($token,result) {} |
||||||
|
|
||||||
|
if {!$state(stream)} { |
||||||
|
ParseRecords $token 1 |
||||||
|
if {$state(sax)} { |
||||||
|
set result $token |
||||||
|
} else { |
||||||
|
set result $data($token,result) |
||||||
|
destroy $token |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
# Assert: Processing is in background. |
||||||
|
return $token |
||||||
|
} |
||||||
|
|
||||||
|
# Cleanup a parser, cancelling any callbacks etc. |
||||||
|
|
||||||
|
proc ::bibtex::destroy {token} { |
||||||
|
variable data |
||||||
|
|
||||||
|
if {![info exists data($token,stream)]} { |
||||||
|
return -code error "Illegal bibtex parser \"$token\"" |
||||||
|
} |
||||||
|
if {$data($token,stream)} { |
||||||
|
fileevent $data($token,-channel) readable {} |
||||||
|
} |
||||||
|
|
||||||
|
array unset data $token,* |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::bibtex::wait {token} { |
||||||
|
variable data |
||||||
|
|
||||||
|
if {![info exists data($token,stream)]} { |
||||||
|
return -code error "Illegal bibtex parser \"$token\"" |
||||||
|
} |
||||||
|
vwait ::bibtex::data($token,done) |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# bibtex::addStrings -- |
||||||
|
# |
||||||
|
# Add strings to the map for a particular parser. All strings are |
||||||
|
# expanded at parse time. |
||||||
|
|
||||||
|
proc ::bibtex::addStrings {token strings} { |
||||||
|
variable data |
||||||
|
eval [linsert $strings 0 lappend data($token,strings)] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Implementation: Private utility routines |
||||||
|
|
||||||
|
proc ::bibtex::AddRecord {token type key recdata} { |
||||||
|
variable data |
||||||
|
lappend data($token,result) [list $type $key $recdata] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::bibtex::GetOptions {argv statevar} { |
||||||
|
upvar 1 $statevar state |
||||||
|
|
||||||
|
# Basic processing of the argument list |
||||||
|
# and the options found therein. |
||||||
|
|
||||||
|
set opts [lrange [::cmdline::GetOptionDefaults { |
||||||
|
{command.arg {}} |
||||||
|
{channel.arg {}} |
||||||
|
{recordcommand.arg {}} |
||||||
|
{preamblecommand.arg {}} |
||||||
|
{stringcommand.arg {}} |
||||||
|
{commentcommand.arg {}} |
||||||
|
{progresscommand.arg {}} |
||||||
|
{casesensitivestrings.arg {}} |
||||||
|
} result] 2 end] ;# Remove ? and help. |
||||||
|
|
||||||
|
set argc [llength $argv] |
||||||
|
while {[set err [::cmdline::getopt argv $opts opt arg]]} { |
||||||
|
if {$err < 0} { |
||||||
|
set olist "" |
||||||
|
foreach o [lsort $opts] { |
||||||
|
if {[string match *.arg $o]} { |
||||||
|
set o [string range $o 0 end-4] |
||||||
|
} |
||||||
|
lappend olist -$o |
||||||
|
} |
||||||
|
return -code error "bad option \"$opt\",\ |
||||||
|
should be one of\ |
||||||
|
[linsert [join $olist ", "] end-1 or]" |
||||||
|
} |
||||||
|
set state(-$opt) $arg |
||||||
|
} |
||||||
|
|
||||||
|
# Check the information gained so far |
||||||
|
# for inconsistencies and/or missing |
||||||
|
# pieces. |
||||||
|
|
||||||
|
set sax [expr { |
||||||
|
[info exists state(-recordcommand)] || |
||||||
|
[info exists state(-preamblecommand)] || |
||||||
|
[info exists state(-stringcommand)] || |
||||||
|
[info exists state(-commentcommand)] || |
||||||
|
[info exists state(-progresscommand)] |
||||||
|
}] ; # {} |
||||||
|
|
||||||
|
set bg [info exists state(-command)] |
||||||
|
|
||||||
|
if {$sax && $bg} { |
||||||
|
# Sax callbacks and channel completion callback exclude each |
||||||
|
# other. |
||||||
|
return -code error "The options -command and -TYPEcommand exclude each other" |
||||||
|
} |
||||||
|
|
||||||
|
set stream [info exists state(-channel)] |
||||||
|
|
||||||
|
if {$stream} { |
||||||
|
# Channel is present, a text is not allowed. |
||||||
|
if {[llength $argv]} { |
||||||
|
return -code error "Option -channel and text exclude each other" |
||||||
|
} |
||||||
|
|
||||||
|
# The channel has to exist as well. |
||||||
|
if {[lsearch -exact [file channels] $state(-channel)] < 0} { |
||||||
|
return -code error "Illegal channel handle \"$state(-channel)\"" |
||||||
|
} |
||||||
|
} else { |
||||||
|
# Channel is not present, we have to have a text, and only |
||||||
|
# exactly one. And a general -command callback is not allowed. |
||||||
|
|
||||||
|
if {![llength $argv]} { |
||||||
|
return -code error "Neither -channel nor text specified" |
||||||
|
} elseif {[llength $argv] > 1} { |
||||||
|
return -code error "wrong # args: [lindex [info level 1] 0] ?options? ?bibtex?" |
||||||
|
} |
||||||
|
|
||||||
|
# Channel completion callback is not allowed if we are not |
||||||
|
# reading from a channel. |
||||||
|
|
||||||
|
if {$bg} { |
||||||
|
return -code error "Option -command and text exclude each other" |
||||||
|
} |
||||||
|
|
||||||
|
set state(buffer) [lindex $argv 0] |
||||||
|
} |
||||||
|
|
||||||
|
set state(stream) $stream |
||||||
|
set state(sax) $sax |
||||||
|
set state(bg) [expr {$sax || $bg}] |
||||||
|
|
||||||
|
if {![info exists state(-stringcommand)]} { |
||||||
|
set state(-stringcommand) [list ::bibtex::addStrings] |
||||||
|
} |
||||||
|
if {![info exists state(-recordcommand)] && (!$sax)} { |
||||||
|
set state(-recordcommand) [list ::bibtex::AddRecord] |
||||||
|
} |
||||||
|
if {[info exists state(-casesensitivestrings)] && |
||||||
|
$state(-casesensitivestrings) |
||||||
|
} { |
||||||
|
set state(casesensitivestrings) 1 |
||||||
|
} else { |
||||||
|
set state(casesensitivestrings) 0 |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::bibtex::Callback {token type args} { |
||||||
|
variable data |
||||||
|
|
||||||
|
#puts stdout "Callback ($token $type ($args))" |
||||||
|
|
||||||
|
if {[info exists data($token,-${type}command)]} { |
||||||
|
eval $data($token,-${type}command) [linsert $args 0 $token] |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::bibtex::ReadChan {token} { |
||||||
|
variable data |
||||||
|
|
||||||
|
# Read the waiting characters into our buffer and process |
||||||
|
# them. The records are saved either through a user supplied |
||||||
|
# record callback, or the standard callback for our non-sax |
||||||
|
# processing. |
||||||
|
|
||||||
|
set chan $data($token,-channel) |
||||||
|
append data($token,buffer) [read $chan] |
||||||
|
|
||||||
|
if {[eof $chan]} { |
||||||
|
# Final processing. In non-SAX mode we have to deliver the |
||||||
|
# completed result before destroying the parser. |
||||||
|
|
||||||
|
ParseRecords $token 1 |
||||||
|
set data($token,done) 1 |
||||||
|
if {!$data($token,sax)} { |
||||||
|
Callback $token {} $data($token,result) |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# Processing of partial data. |
||||||
|
|
||||||
|
ParseRecords $token 0 |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::bibtex::Tidy {str} { |
||||||
|
return [string tolower [string trim $str]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::bibtex::ParseRecords {token eof} { |
||||||
|
# A rough BibTeX grammar (case-insensitive): |
||||||
|
# |
||||||
|
# Database ::= (Junk '@' Entry)* |
||||||
|
# Junk ::= .*? |
||||||
|
# Entry ::= Record |
||||||
|
# | Comment |
||||||
|
# | String |
||||||
|
# | Preamble |
||||||
|
# Comment ::= "comment" [^\n]* \n -- ignored |
||||||
|
# String ::= "string" '{' Field* '}' |
||||||
|
# Preamble ::= "preamble" '{' .* '}' -- (balanced) |
||||||
|
# Record ::= Type '{' Key ',' Field* '}' |
||||||
|
# | Type '(' Key ',' Field* ')' -- not handled |
||||||
|
# Type ::= Name |
||||||
|
# Key ::= Name |
||||||
|
# Field ::= Name '=' Value |
||||||
|
# Name ::= [^\s\"#%'(){}]* |
||||||
|
# Value ::= [0-9]+ |
||||||
|
# | '"' ([^'"']|\\'"')* '"' |
||||||
|
# | '{' .* '}' -- (balanced) |
||||||
|
|
||||||
|
# " - Fixup emacs hilit confusion from the grammar above. |
||||||
|
variable data |
||||||
|
set bibtex $data($token,buffer) |
||||||
|
|
||||||
|
# Split at each @ character which is at the beginning of a line, |
||||||
|
# modulo whitespace. This is a heuristic to distinguish the @'s |
||||||
|
# starting a new record from the @'s occuring inside a record, as |
||||||
|
# part of email addresses. Empty pices at beginning or end are |
||||||
|
# stripped before the split. |
||||||
|
|
||||||
|
regsub -line -all {^[\n\r\f\t ]*@} $bibtex \000 bibtex |
||||||
|
set db [split [string trim $bibtex \000] \000] |
||||||
|
|
||||||
|
if {$eof} { |
||||||
|
set total [llength $db] |
||||||
|
set step [expr {double($total) / 100.0}] |
||||||
|
set istep [expr {$step > 1 ? int($step) : 1}] |
||||||
|
set count 0 |
||||||
|
} else { |
||||||
|
if {[llength $db] < 2} { |
||||||
|
# Nothing to process, or data which ay be incomplete. |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
set data($token,buffer) [lindex $db end] |
||||||
|
set db [lrange $db 0 end-1] |
||||||
|
|
||||||
|
# Fake progress meter. |
||||||
|
set count -1 |
||||||
|
} |
||||||
|
|
||||||
|
foreach block $db { |
||||||
|
if {$count < 0} { |
||||||
|
Callback $token progress -1 |
||||||
|
} elseif {([incr count] % $istep) == 0} { |
||||||
|
Callback $token progress [expr {int($count / $step)}] |
||||||
|
} |
||||||
|
if {[regexp -nocase {\s*comment([^\n])*\n(.*)} $block \ |
||||||
|
-> cmnt rest]} { |
||||||
|
# Are @comments blocks, or just 1 line? |
||||||
|
# Does anyone care? |
||||||
|
Callback $token comment $cmnt |
||||||
|
|
||||||
|
} elseif {[regexp -nocase {^\s*string[^\{]*\{(.*)\}[^\}]*} \ |
||||||
|
$block -> rest]} { |
||||||
|
# string macro defs |
||||||
|
if {$data($token,casesensitivestrings)} { |
||||||
|
Callback $token string [ParseString $rest] |
||||||
|
} else { |
||||||
|
Callback $token string [ParseBlock $rest] |
||||||
|
} |
||||||
|
} elseif {[regexp -nocase {\s*preamble[^\{]*\{(.*)\}[^\}]*} \ |
||||||
|
$block -> rest]} { |
||||||
|
Callback $token preamble $rest |
||||||
|
|
||||||
|
} elseif {[regexp {([^\{]+)\{([^,]*),(.*)\}[^\}]*} \ |
||||||
|
$block -> type key rest]} { |
||||||
|
# Do any @string mappings |
||||||
|
if {$data($token,casesensitivestrings)} { |
||||||
|
# puts $data($token,strings) |
||||||
|
set rest [string map $data($token,strings) $rest] |
||||||
|
} else { |
||||||
|
set rest [string map -nocase $data($token,strings) $rest] |
||||||
|
} |
||||||
|
Callback $token record [Tidy $type] [string trim $key] \ |
||||||
|
[ParseBlock $rest] |
||||||
|
} else { |
||||||
|
## FUTURE: Use a logger. |
||||||
|
puts stderr "Skipping: $block" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::bibtex::ParseString {block} { |
||||||
|
regexp {(\S+)[^=]*=(.*)} $block -> key rest |
||||||
|
return [list $key $rest] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::bibtex::ParseBlock {block} { |
||||||
|
set ret [list] |
||||||
|
set index 0 |
||||||
|
while { |
||||||
|
[regexp -start $index -indices -- \ |
||||||
|
{(\S+)\s*=(.*)} $block -> key rest] |
||||||
|
} { |
||||||
|
foreach {ks ke} $key break |
||||||
|
set k [Tidy [string range $block $ks $ke]] |
||||||
|
foreach {rs re} $rest break |
||||||
|
foreach {v index} \ |
||||||
|
[ParseBibString $rs [string range $block $rs $re]] \ |
||||||
|
break |
||||||
|
lappend ret $k $v |
||||||
|
} |
||||||
|
return $ret |
||||||
|
} |
||||||
|
|
||||||
|
proc ::bibtex::ParseBibString {index str} { |
||||||
|
set count 0 |
||||||
|
set retstr "" |
||||||
|
set escape 0 |
||||||
|
set string 0 |
||||||
|
foreach char [split $str ""] { |
||||||
|
incr index |
||||||
|
if {$escape} { |
||||||
|
set escape 0 |
||||||
|
} else { |
||||||
|
if {$char eq "\{"} { |
||||||
|
incr count |
||||||
|
continue |
||||||
|
} elseif {$char eq "\}"} { |
||||||
|
incr count -1 |
||||||
|
if {$count < 0} {incr index -1; break} |
||||||
|
continue |
||||||
|
} elseif {$char eq ","} { |
||||||
|
if {$count == 0} break |
||||||
|
} elseif {$char eq "\\"} { |
||||||
|
set escape 1 |
||||||
|
continue |
||||||
|
} elseif {$char eq "\""} { |
||||||
|
# Handling the case where str is surrounded by |
||||||
|
# quotation marks instead of braces (as some journals |
||||||
|
# may, perhaps erroneously, print some field. e.g.: |
||||||
|
# https://www.epj.org/) |
||||||
|
if {$count == 0} { |
||||||
|
incr count |
||||||
|
} elseif {$count == 1} { |
||||||
|
incr count -1 |
||||||
|
} |
||||||
|
continue |
||||||
|
} |
||||||
|
# else: Nothing |
||||||
|
} |
||||||
|
append retstr $char |
||||||
|
} |
||||||
|
regsub -all {\s+} $retstr { } retstr |
||||||
|
return [list [string trim $retstr] $index] |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Internal. Package configuration and state. |
||||||
|
|
||||||
|
namespace eval bibtex { |
||||||
|
# Counter for the generation of parser tokens. |
||||||
|
variable id 0 |
||||||
|
|
||||||
|
# State of all parsers. Keys for each parser are prefixed with the |
||||||
|
# parser token. |
||||||
|
variable data |
||||||
|
array set data {} |
||||||
|
|
||||||
|
# Keys and their meaning (listed without token prefix) |
||||||
|
## |
||||||
|
# buffer |
||||||
|
# eof |
||||||
|
# channel <-\/- Difference ? |
||||||
|
# strings | |
||||||
|
# -async | |
||||||
|
# -blocksize | |
||||||
|
# -channel <-/ |
||||||
|
# -recordcommand -- callback for each record |
||||||
|
# -preamblecommand -- callback for @preamble blocks |
||||||
|
# -stringcommand -- callback for @string macros |
||||||
|
# -commentcommand -- callback for @comment blocks |
||||||
|
# -progresscommand -- callback to indicate progress of parse |
||||||
|
## |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready to go |
||||||
|
package provide bibtex 0.8 |
||||||
|
# EOF |
||||||
@ -0,0 +1,2 @@ |
|||||||
|
if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} |
||||||
|
package ifneeded bibtex 0.8 [list source [file join $dir bibtex.tcl]] |
||||||
@ -0,0 +1,755 @@ |
|||||||
|
# blowfish.tcl - |
||||||
|
# |
||||||
|
# Pure-Tcl implementation of the Blowfish algorithm. |
||||||
|
# |
||||||
|
# See http://www.schneier.com/blowfish.html for information about the |
||||||
|
# Blowfish algorithm. |
||||||
|
# |
||||||
|
# The implementation is derived from Paul Kocher's implementation, |
||||||
|
# available at http://www.schneier.com/blowfish-download.html |
||||||
|
# |
||||||
|
# Copyright (C) 2004 Frank Pilhofer |
||||||
|
# Copyright (C) 2004 Pat Thoyts <patthoyts@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 Tcl 8.5 9 |
||||||
|
|
||||||
|
namespace eval blowfish { |
||||||
|
variable uid |
||||||
|
if {![info exists uid]} { set uid 0 } |
||||||
|
|
||||||
|
variable accel |
||||||
|
array set accel {trf 0} |
||||||
|
|
||||||
|
namespace export blowfish |
||||||
|
|
||||||
|
variable ORIG_P { |
||||||
|
0x243F6A88 0x85A308D3 0x13198A2E 0x03707344 |
||||||
|
0xA4093822 0x299F31D0 0x082EFA98 0xEC4E6C89 |
||||||
|
0x452821E6 0x38D01377 0xBE5466CF 0x34E90C6C |
||||||
|
0xC0AC29B7 0xC97C50DD 0x3F84D5B5 0xB5470917 |
||||||
|
0x9216D5D9 0x8979FB1B |
||||||
|
} |
||||||
|
|
||||||
|
variable ORIG_S { |
||||||
|
0xD1310BA6 0x98DFB5AC 0x2FFD72DB 0xD01ADFB7 |
||||||
|
0xB8E1AFED 0x6A267E96 0xBA7C9045 0xF12C7F99 |
||||||
|
0x24A19947 0xB3916CF7 0x0801F2E2 0x858EFC16 |
||||||
|
0x636920D8 0x71574E69 0xA458FEA3 0xF4933D7E |
||||||
|
0x0D95748F 0x728EB658 0x718BCD58 0x82154AEE |
||||||
|
0x7B54A41D 0xC25A59B5 0x9C30D539 0x2AF26013 |
||||||
|
0xC5D1B023 0x286085F0 0xCA417918 0xB8DB38EF |
||||||
|
0x8E79DCB0 0x603A180E 0x6C9E0E8B 0xB01E8A3E |
||||||
|
0xD71577C1 0xBD314B27 0x78AF2FDA 0x55605C60 |
||||||
|
0xE65525F3 0xAA55AB94 0x57489862 0x63E81440 |
||||||
|
0x55CA396A 0x2AAB10B6 0xB4CC5C34 0x1141E8CE |
||||||
|
0xA15486AF 0x7C72E993 0xB3EE1411 0x636FBC2A |
||||||
|
0x2BA9C55D 0x741831F6 0xCE5C3E16 0x9B87931E |
||||||
|
0xAFD6BA33 0x6C24CF5C 0x7A325381 0x28958677 |
||||||
|
0x3B8F4898 0x6B4BB9AF 0xC4BFE81B 0x66282193 |
||||||
|
0x61D809CC 0xFB21A991 0x487CAC60 0x5DEC8032 |
||||||
|
0xEF845D5D 0xE98575B1 0xDC262302 0xEB651B88 |
||||||
|
0x23893E81 0xD396ACC5 0x0F6D6FF3 0x83F44239 |
||||||
|
0x2E0B4482 0xA4842004 0x69C8F04A 0x9E1F9B5E |
||||||
|
0x21C66842 0xF6E96C9A 0x670C9C61 0xABD388F0 |
||||||
|
0x6A51A0D2 0xD8542F68 0x960FA728 0xAB5133A3 |
||||||
|
0x6EEF0B6C 0x137A3BE4 0xBA3BF050 0x7EFB2A98 |
||||||
|
0xA1F1651D 0x39AF0176 0x66CA593E 0x82430E88 |
||||||
|
0x8CEE8619 0x456F9FB4 0x7D84A5C3 0x3B8B5EBE |
||||||
|
0xE06F75D8 0x85C12073 0x401A449F 0x56C16AA6 |
||||||
|
0x4ED3AA62 0x363F7706 0x1BFEDF72 0x429B023D |
||||||
|
0x37D0D724 0xD00A1248 0xDB0FEAD3 0x49F1C09B |
||||||
|
0x075372C9 0x80991B7B 0x25D479D8 0xF6E8DEF7 |
||||||
|
0xE3FE501A 0xB6794C3B 0x976CE0BD 0x04C006BA |
||||||
|
0xC1A94FB6 0x409F60C4 0x5E5C9EC2 0x196A2463 |
||||||
|
0x68FB6FAF 0x3E6C53B5 0x1339B2EB 0x3B52EC6F |
||||||
|
0x6DFC511F 0x9B30952C 0xCC814544 0xAF5EBD09 |
||||||
|
0xBEE3D004 0xDE334AFD 0x660F2807 0x192E4BB3 |
||||||
|
0xC0CBA857 0x45C8740F 0xD20B5F39 0xB9D3FBDB |
||||||
|
0x5579C0BD 0x1A60320A 0xD6A100C6 0x402C7279 |
||||||
|
0x679F25FE 0xFB1FA3CC 0x8EA5E9F8 0xDB3222F8 |
||||||
|
0x3C7516DF 0xFD616B15 0x2F501EC8 0xAD0552AB |
||||||
|
0x323DB5FA 0xFD238760 0x53317B48 0x3E00DF82 |
||||||
|
0x9E5C57BB 0xCA6F8CA0 0x1A87562E 0xDF1769DB |
||||||
|
0xD542A8F6 0x287EFFC3 0xAC6732C6 0x8C4F5573 |
||||||
|
0x695B27B0 0xBBCA58C8 0xE1FFA35D 0xB8F011A0 |
||||||
|
0x10FA3D98 0xFD2183B8 0x4AFCB56C 0x2DD1D35B |
||||||
|
0x9A53E479 0xB6F84565 0xD28E49BC 0x4BFB9790 |
||||||
|
0xE1DDF2DA 0xA4CB7E33 0x62FB1341 0xCEE4C6E8 |
||||||
|
0xEF20CADA 0x36774C01 0xD07E9EFE 0x2BF11FB4 |
||||||
|
0x95DBDA4D 0xAE909198 0xEAAD8E71 0x6B93D5A0 |
||||||
|
0xD08ED1D0 0xAFC725E0 0x8E3C5B2F 0x8E7594B7 |
||||||
|
0x8FF6E2FB 0xF2122B64 0x8888B812 0x900DF01C |
||||||
|
0x4FAD5EA0 0x688FC31C 0xD1CFF191 0xB3A8C1AD |
||||||
|
0x2F2F2218 0xBE0E1777 0xEA752DFE 0x8B021FA1 |
||||||
|
0xE5A0CC0F 0xB56F74E8 0x18ACF3D6 0xCE89E299 |
||||||
|
0xB4A84FE0 0xFD13E0B7 0x7CC43B81 0xD2ADA8D9 |
||||||
|
0x165FA266 0x80957705 0x93CC7314 0x211A1477 |
||||||
|
0xE6AD2065 0x77B5FA86 0xC75442F5 0xFB9D35CF |
||||||
|
0xEBCDAF0C 0x7B3E89A0 0xD6411BD3 0xAE1E7E49 |
||||||
|
0x00250E2D 0x2071B35E 0x226800BB 0x57B8E0AF |
||||||
|
0x2464369B 0xF009B91E 0x5563911D 0x59DFA6AA |
||||||
|
0x78C14389 0xD95A537F 0x207D5BA2 0x02E5B9C5 |
||||||
|
0x83260376 0x6295CFA9 0x11C81968 0x4E734A41 |
||||||
|
0xB3472DCA 0x7B14A94A 0x1B510052 0x9A532915 |
||||||
|
0xD60F573F 0xBC9BC6E4 0x2B60A476 0x81E67400 |
||||||
|
0x08BA6FB5 0x571BE91F 0xF296EC6B 0x2A0DD915 |
||||||
|
0xB6636521 0xE7B9F9B6 0xFF34052E 0xC5855664 |
||||||
|
0x53B02D5D 0xA99F8FA1 0x08BA4799 0x6E85076A |
||||||
|
0x4B7A70E9 0xB5B32944 0xDB75092E 0xC4192623 |
||||||
|
0xAD6EA6B0 0x49A7DF7D 0x9CEE60B8 0x8FEDB266 |
||||||
|
0xECAA8C71 0x699A17FF 0x5664526C 0xC2B19EE1 |
||||||
|
0x193602A5 0x75094C29 0xA0591340 0xE4183A3E |
||||||
|
0x3F54989A 0x5B429D65 0x6B8FE4D6 0x99F73FD6 |
||||||
|
0xA1D29C07 0xEFE830F5 0x4D2D38E6 0xF0255DC1 |
||||||
|
0x4CDD2086 0x8470EB26 0x6382E9C6 0x021ECC5E |
||||||
|
0x09686B3F 0x3EBAEFC9 0x3C971814 0x6B6A70A1 |
||||||
|
0x687F3584 0x52A0E286 0xB79C5305 0xAA500737 |
||||||
|
0x3E07841C 0x7FDEAE5C 0x8E7D44EC 0x5716F2B8 |
||||||
|
0xB03ADA37 0xF0500C0D 0xF01C1F04 0x0200B3FF |
||||||
|
0xAE0CF51A 0x3CB574B2 0x25837A58 0xDC0921BD |
||||||
|
0xD19113F9 0x7CA92FF6 0x94324773 0x22F54701 |
||||||
|
0x3AE5E581 0x37C2DADC 0xC8B57634 0x9AF3DDA7 |
||||||
|
0xA9446146 0x0FD0030E 0xECC8C73E 0xA4751E41 |
||||||
|
0xE238CD99 0x3BEA0E2F 0x3280BBA1 0x183EB331 |
||||||
|
0x4E548B38 0x4F6DB908 0x6F420D03 0xF60A04BF |
||||||
|
0x2CB81290 0x24977C79 0x5679B072 0xBCAF89AF |
||||||
|
0xDE9A771F 0xD9930810 0xB38BAE12 0xDCCF3F2E |
||||||
|
0x5512721F 0x2E6B7124 0x501ADDE6 0x9F84CD87 |
||||||
|
0x7A584718 0x7408DA17 0xBC9F9ABC 0xE94B7D8C |
||||||
|
0xEC7AEC3A 0xDB851DFA 0x63094366 0xC464C3D2 |
||||||
|
0xEF1C1847 0x3215D908 0xDD433B37 0x24C2BA16 |
||||||
|
0x12A14D43 0x2A65C451 0x50940002 0x133AE4DD |
||||||
|
0x71DFF89E 0x10314E55 0x81AC77D6 0x5F11199B |
||||||
|
0x043556F1 0xD7A3C76B 0x3C11183B 0x5924A509 |
||||||
|
0xF28FE6ED 0x97F1FBFA 0x9EBABF2C 0x1E153C6E |
||||||
|
0x86E34570 0xEAE96FB1 0x860E5E0A 0x5A3E2AB3 |
||||||
|
0x771FE71C 0x4E3D06FA 0x2965DCB9 0x99E71D0F |
||||||
|
0x803E89D6 0x5266C825 0x2E4CC978 0x9C10B36A |
||||||
|
0xC6150EBA 0x94E2EA78 0xA5FC3C53 0x1E0A2DF4 |
||||||
|
0xF2F74EA7 0x361D2B3D 0x1939260F 0x19C27960 |
||||||
|
0x5223A708 0xF71312B6 0xEBADFE6E 0xEAC31F66 |
||||||
|
0xE3BC4595 0xA67BC883 0xB17F37D1 0x018CFF28 |
||||||
|
0xC332DDEF 0xBE6C5AA5 0x65582185 0x68AB9802 |
||||||
|
0xEECEA50F 0xDB2F953B 0x2AEF7DAD 0x5B6E2F84 |
||||||
|
0x1521B628 0x29076170 0xECDD4775 0x619F1510 |
||||||
|
0x13CCA830 0xEB61BD96 0x0334FE1E 0xAA0363CF |
||||||
|
0xB5735C90 0x4C70A239 0xD59E9E0B 0xCBAADE14 |
||||||
|
0xEECC86BC 0x60622CA7 0x9CAB5CAB 0xB2F3846E |
||||||
|
0x648B1EAF 0x19BDF0CA 0xA02369B9 0x655ABB50 |
||||||
|
0x40685A32 0x3C2AB4B3 0x319EE9D5 0xC021B8F7 |
||||||
|
0x9B540B19 0x875FA099 0x95F7997E 0x623D7DA8 |
||||||
|
0xF837889A 0x97E32D77 0x11ED935F 0x16681281 |
||||||
|
0x0E358829 0xC7E61FD6 0x96DEDFA1 0x7858BA99 |
||||||
|
0x57F584A5 0x1B227263 0x9B83C3FF 0x1AC24696 |
||||||
|
0xCDB30AEB 0x532E3054 0x8FD948E4 0x6DBC3128 |
||||||
|
0x58EBF2EF 0x34C6FFEA 0xFE28ED61 0xEE7C3C73 |
||||||
|
0x5D4A14D9 0xE864B7E3 0x42105D14 0x203E13E0 |
||||||
|
0x45EEE2B6 0xA3AAABEA 0xDB6C4F15 0xFACB4FD0 |
||||||
|
0xC742F442 0xEF6ABBB5 0x654F3B1D 0x41CD2105 |
||||||
|
0xD81E799E 0x86854DC7 0xE44B476A 0x3D816250 |
||||||
|
0xCF62A1F2 0x5B8D2646 0xFC8883A0 0xC1C7B6A3 |
||||||
|
0x7F1524C3 0x69CB7492 0x47848A0B 0x5692B285 |
||||||
|
0x095BBF00 0xAD19489D 0x1462B174 0x23820E00 |
||||||
|
0x58428D2A 0x0C55F5EA 0x1DADF43E 0x233F7061 |
||||||
|
0x3372F092 0x8D937E41 0xD65FECF1 0x6C223BDB |
||||||
|
0x7CDE3759 0xCBEE7460 0x4085F2A7 0xCE77326E |
||||||
|
0xA6078084 0x19F8509E 0xE8EFD855 0x61D99735 |
||||||
|
0xA969A7AA 0xC50C06C2 0x5A04ABFC 0x800BCADC |
||||||
|
0x9E447A2E 0xC3453484 0xFDD56705 0x0E1E9EC9 |
||||||
|
0xDB73DBD3 0x105588CD 0x675FDA79 0xE3674340 |
||||||
|
0xC5C43465 0x713E38D8 0x3D28F89E 0xF16DFF20 |
||||||
|
0x153E21E7 0x8FB03D4A 0xE6E39F2B 0xDB83ADF7 |
||||||
|
0xE93D5A68 0x948140F7 0xF64C261C 0x94692934 |
||||||
|
0x411520F7 0x7602D4F7 0xBCF46B2E 0xD4A20068 |
||||||
|
0xD4082471 0x3320F46A 0x43B7D4B7 0x500061AF |
||||||
|
0x1E39F62E 0x97244546 0x14214F74 0xBF8B8840 |
||||||
|
0x4D95FC1D 0x96B591AF 0x70F4DDD3 0x66A02F45 |
||||||
|
0xBFBC09EC 0x03BD9785 0x7FAC6DD0 0x31CB8504 |
||||||
|
0x96EB27B3 0x55FD3941 0xDA2547E6 0xABCA0A9A |
||||||
|
0x28507825 0x530429F4 0x0A2C86DA 0xE9B66DFB |
||||||
|
0x68DC1462 0xD7486900 0x680EC0A4 0x27A18DEE |
||||||
|
0x4F3FFEA2 0xE887AD8C 0xB58CE006 0x7AF4D6B6 |
||||||
|
0xAACE1E7C 0xD3375FEC 0xCE78A399 0x406B2A42 |
||||||
|
0x20FE9E35 0xD9F385B9 0xEE39D7AB 0x3B124E8B |
||||||
|
0x1DC9FAF7 0x4B6D1856 0x26A36631 0xEAE397B2 |
||||||
|
0x3A6EFA74 0xDD5B4332 0x6841E7F7 0xCA7820FB |
||||||
|
0xFB0AF54E 0xD8FEB397 0x454056AC 0xBA489527 |
||||||
|
0x55533A3A 0x20838D87 0xFE6BA9B7 0xD096954B |
||||||
|
0x55A867BC 0xA1159A58 0xCCA92963 0x99E1DB33 |
||||||
|
0xA62A4A56 0x3F3125F9 0x5EF47E1C 0x9029317C |
||||||
|
0xFDF8E802 0x04272F70 0x80BB155C 0x05282CE3 |
||||||
|
0x95C11548 0xE4C66D22 0x48C1133F 0xC70F86DC |
||||||
|
0x07F9C9EE 0x41041F0F 0x404779A4 0x5D886E17 |
||||||
|
0x325F51EB 0xD59BC0D1 0xF2BCC18F 0x41113564 |
||||||
|
0x257B7834 0x602A9C60 0xDFF8E8A3 0x1F636C1B |
||||||
|
0x0E12B4C2 0x02E1329E 0xAF664FD1 0xCAD18115 |
||||||
|
0x6B2395E0 0x333E92E1 0x3B240B62 0xEEBEB922 |
||||||
|
0x85B2A20E 0xE6BA0D99 0xDE720C8C 0x2DA2F728 |
||||||
|
0xD0127845 0x95B794FD 0x647D0862 0xE7CCF5F0 |
||||||
|
0x5449A36F 0x877D48FA 0xC39DFD27 0xF33E8D1E |
||||||
|
0x0A476341 0x992EFF74 0x3A6F6EAB 0xF4F8FD37 |
||||||
|
0xA812DC60 0xA1EBDDF8 0x991BE14C 0xDB6E6B0D |
||||||
|
0xC67B5510 0x6D672C37 0x2765D43B 0xDCD0E804 |
||||||
|
0xF1290DC7 0xCC00FFA3 0xB5390F92 0x690FED0B |
||||||
|
0x667B9FFB 0xCEDB7D9C 0xA091CF0B 0xD9155EA3 |
||||||
|
0xBB132F88 0x515BAD24 0x7B9479BF 0x763BD6EB |
||||||
|
0x37392EB3 0xCC115979 0x8026E297 0xF42E312D |
||||||
|
0x6842ADA7 0xC66A2B3B 0x12754CCC 0x782EF11C |
||||||
|
0x6A124237 0xB79251E7 0x06A1BBE6 0x4BFB6350 |
||||||
|
0x1A6B1018 0x11CAEDFA 0x3D25BDD8 0xE2E1C3C9 |
||||||
|
0x44421659 0x0A121386 0xD90CEC6E 0xD5ABEA2A |
||||||
|
0x64AF674E 0xDA86A85F 0xBEBFE988 0x64E4C3FE |
||||||
|
0x9DBC8057 0xF0F7C086 0x60787BF8 0x6003604D |
||||||
|
0xD1FD8346 0xF6381FB0 0x7745AE04 0xD736FCCC |
||||||
|
0x83426B33 0xF01EAB71 0xB0804187 0x3C005E5F |
||||||
|
0x77A057BE 0xBDE8AE24 0x55464299 0xBF582E61 |
||||||
|
0x4E58F48F 0xF2DDFDA2 0xF474EF38 0x8789BDC2 |
||||||
|
0x5366F9C3 0xC8B38E74 0xB475F255 0x46FCD9B9 |
||||||
|
0x7AEB2661 0x8B1DDF84 0x846A0E79 0x915F95E2 |
||||||
|
0x466E598E 0x20B45770 0x8CD55591 0xC902DE4C |
||||||
|
0xB90BACE1 0xBB8205D0 0x11A86248 0x7574A99E |
||||||
|
0xB77F19B6 0xE0A9DC09 0x662D09A1 0xC4324633 |
||||||
|
0xE85A1F02 0x09F0BE8C 0x4A99A025 0x1D6EFE10 |
||||||
|
0x1AB93D1D 0x0BA5A4DF 0xA186F20F 0x2868F169 |
||||||
|
0xDCB7DA83 0x573906FE 0xA1E2CE9B 0x4FCD7F52 |
||||||
|
0x50115E01 0xA70683FA 0xA002B5C4 0x0DE6D027 |
||||||
|
0x9AF88C27 0x773F8641 0xC3604C06 0x61A806B5 |
||||||
|
0xF0177A28 0xC0F586E0 0x006058AA 0x30DC7D62 |
||||||
|
0x11E69ED7 0x2338EA63 0x53C2DD94 0xC2C21634 |
||||||
|
0xBBCBEE56 0x90BCB6DE 0xEBFC7DA1 0xCE591D76 |
||||||
|
0x6F05E409 0x4B7C0188 0x39720A3D 0x7C927C24 |
||||||
|
0x86E3725F 0x724D9DB9 0x1AC15BB4 0xD39EB8FC |
||||||
|
0xED545578 0x08FCA5B5 0xD83D7CD3 0x4DAD0FC4 |
||||||
|
0x1E50EF5E 0xB161E6F8 0xA28514D9 0x6C51133C |
||||||
|
0x6FD5C7E7 0x56E14EC4 0x362ABFCE 0xDDC6C837 |
||||||
|
0xD79A3234 0x92638212 0x670EFA8E 0x406000E0 |
||||||
|
0x3A39CE37 0xD3FAF5CF 0xABC27737 0x5AC52D1B |
||||||
|
0x5CB0679E 0x4FA33742 0xD3822740 0x99BC9BBE |
||||||
|
0xD5118E9D 0xBF0F7315 0xD62D1C7E 0xC700C47B |
||||||
|
0xB78C1B6B 0x21A19045 0xB26EB1BE 0x6A366EB4 |
||||||
|
0x5748AB2F 0xBC946E79 0xC6A376D2 0x6549C2C8 |
||||||
|
0x530FF8EE 0x468DDE7D 0xD5730A1D 0x4CD04DC6 |
||||||
|
0x2939BBDB 0xA9BA4650 0xAC9526E8 0xBE5EE304 |
||||||
|
0xA1FAD5F0 0x6A2D519A 0x63EF8CE2 0x9A86EE22 |
||||||
|
0xC089C2B8 0x43242EF6 0xA51E03AA 0x9CF2D0A4 |
||||||
|
0x83C061BA 0x9BE96A4D 0x8FE51550 0xBA645BD6 |
||||||
|
0x2826A2F9 0xA73A3AE1 0x4BA99586 0xEF5562E9 |
||||||
|
0xC72FEFD3 0xF752F7DA 0x3F046F69 0x77FA0A59 |
||||||
|
0x80E4A915 0x87B08601 0x9B09E6AD 0x3B3EE593 |
||||||
|
0xE990FD5A 0x9E34D797 0x2CF0B7D9 0x022B8B51 |
||||||
|
0x96D5AC3A 0x017DA67D 0xD1CF3ED6 0x7C7D2D28 |
||||||
|
0x1F9F25CF 0xADF2B89B 0x5AD6B472 0x5A88F54C |
||||||
|
0xE029AC71 0xE019A5E6 0x47B0ACFD 0xED93FA9B |
||||||
|
0xE8D3C48D 0x283B57CC 0xF8D56629 0x79132E28 |
||||||
|
0x785F0191 0xED756055 0xF7960E44 0xE3D35E8C |
||||||
|
0x15056DD4 0x88F46DBA 0x03A16125 0x0564F0BD |
||||||
|
0xC3EB9E15 0x3C9057A2 0x97271AEC 0xA93A072A |
||||||
|
0x1B3F6D9B 0x1E6321F5 0xF59C66FB 0x26DCF319 |
||||||
|
0x7533D928 0xB155FDF5 0x03563482 0x8ABA3CBB |
||||||
|
0x28517711 0xC20AD9F8 0xABCC5167 0xCCAD925F |
||||||
|
0x4DE81751 0x3830DC8E 0x379D5862 0x9320F991 |
||||||
|
0xEA7A90C2 0xFB3E7BCE 0x5121CE64 0x774FBE32 |
||||||
|
0xA8B6E37E 0xC3293D46 0x48DE5369 0x6413E680 |
||||||
|
0xA2AE0810 0xDD6DB224 0x69852DFD 0x09072166 |
||||||
|
0xB39A460A 0x6445C0DD 0x586CDECF 0x1C20C8AE |
||||||
|
0x5BBEF7DD 0x1B588D40 0xCCD2017F 0x6BB4E3BB |
||||||
|
0xDDA26A7E 0x3A59FF45 0x3E350A44 0xBCB4CDD5 |
||||||
|
0x72EACEA8 0xFA6484BB 0x8D6612AE 0xBF3C6F47 |
||||||
|
0xD29BE463 0x542F5D9E 0xAEC2771B 0xF64E6370 |
||||||
|
0x740E0D8D 0xE75B1357 0xF8721671 0xAF537D5D |
||||||
|
0x4040CB08 0x4EB4E2CC 0x34D2466A 0x0115AF84 |
||||||
|
0xE1B00428 0x95983A1D 0x06B89FB4 0xCE6EA048 |
||||||
|
0x6F3F3B82 0x3520AB82 0x011A1D4B 0x277227F8 |
||||||
|
0x611560B1 0xE7933FDC 0xBB3A792B 0x344525BD |
||||||
|
0xA08839E1 0x51CE794B 0x2F32C9B7 0xA01FBAC9 |
||||||
|
0xE01CC87E 0xBCC7D1F6 0xCF0111C3 0xA1E8AAC7 |
||||||
|
0x1A908749 0xD44FBD9A 0xD0DADECB 0xD50ADA38 |
||||||
|
0x0339C32A 0xC6913667 0x8DF9317C 0xE0B12B4F |
||||||
|
0xF79E59B7 0x43F5BB3A 0xF2D519FF 0x27D9459C |
||||||
|
0xBF97222C 0x15E6FC2A 0x0F91FC71 0x9B941525 |
||||||
|
0xFAE59361 0xCEB69CEB 0xC2A86459 0x12BAA8D1 |
||||||
|
0xB6C1075E 0xE3056A0C 0x10D25065 0xCB03A442 |
||||||
|
0xE0EC6E0E 0x1698DB3B 0x4C98A0BE 0x3278E964 |
||||||
|
0x9F1F9532 0xE0D392DF 0xD3A0342B 0x8971F21E |
||||||
|
0x1B0A7441 0x4BA3348C 0xC5BE7120 0xC37632D8 |
||||||
|
0xDF359F8D 0x9B992F2E 0xE60B6F47 0x0FE3F11D |
||||||
|
0xE54CDA54 0x1EDAD891 0xCE6279CF 0xCD3E7E6F |
||||||
|
0x1618B166 0xFD2C1D05 0x848FD2C5 0xF6FB2299 |
||||||
|
0xF523F357 0xA6327623 0x93A83531 0x56CCCD02 |
||||||
|
0xACF08162 0x5A75EBB5 0x6E163697 0x88D273CC |
||||||
|
0xDE966292 0x81B949D0 0x4C50901B 0x71C65614 |
||||||
|
0xE6C6C7BD 0x327A140A 0x45E1D006 0xC3F27B9A |
||||||
|
0xC9AA53FD 0x62A80F00 0xBB25BFE2 0x35BDD2F6 |
||||||
|
0x71126905 0xB2040222 0xB6CBCF7C 0xCD769C2B |
||||||
|
0x53113EC0 0x1640E3D3 0x38ABBD60 0x2547ADF0 |
||||||
|
0xBA38209C 0xF746CE76 0x77AFA1C5 0x20756060 |
||||||
|
0x85CBFE4E 0x8AE88DD8 0x7AAAF9B0 0x4CF9AA7E |
||||||
|
0x1948C25C 0x02FB8A8C 0x01C36AE4 0xD6EBE1F9 |
||||||
|
0x90D4F869 0xA65CDEA0 0x3F09252D 0xC208E69F |
||||||
|
0xB74E6132 0xCE77E25B 0x578FDFE3 0x3AC372E6 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::blowfish::intEncrypt {P S xl xr} { |
||||||
|
for {set i 0} {$i < 16} {incr i} { |
||||||
|
set xl [expr {$xl ^ [lindex $P $i]}] |
||||||
|
|
||||||
|
set S0a [lindex $S [expr { ($xl >> 24) & 0xff}]] |
||||||
|
set S1b [lindex $S [expr {(($xl >> 16) & 0xff) + 256}]] |
||||||
|
set S2c [lindex $S [expr {(($xl >> 8) & 0xff) + 512}]] |
||||||
|
set S3d [lindex $S [expr { ($xl & 0xff) + 768}]] |
||||||
|
set xr [expr {(((($S0a + $S1b) ^ $S2c) + $S3d) & 0xffffffff) ^ $xr}] |
||||||
|
|
||||||
|
set temp $xl ; set xl $xr ; set xr $temp |
||||||
|
} |
||||||
|
|
||||||
|
set temp $xl ; set xl $xr ; set xr $temp |
||||||
|
return [list [expr {$xl ^ [lindex $P 17]}] [expr {$xr ^ [lindex $P 16]}]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::blowfish::intDecrypt {P S xl xr} { |
||||||
|
for {set i 17} {$i > 1} {incr i -1} { |
||||||
|
set xl [expr {$xl ^ [lindex $P $i]}] |
||||||
|
|
||||||
|
set S0a [lindex $S [expr { ($xl >> 24) & 0xff}]] |
||||||
|
set S1b [lindex $S [expr {(($xl >> 16) & 0xff) + 256}]] |
||||||
|
set S2c [lindex $S [expr {(($xl >> 8) & 0xff) + 512}]] |
||||||
|
set S3d [lindex $S [expr { ($xl & 0xff) + 768}]] |
||||||
|
set xr [expr {(((($S0a + $S1b) ^ $S2c) + $S3d) & 0xffffffff) ^ $xr}] |
||||||
|
|
||||||
|
set temp $xl ; set xl $xr ; set xr $temp |
||||||
|
} |
||||||
|
|
||||||
|
set temp $xl ; set xl $xr ; set xr $temp |
||||||
|
return [list [expr {$xl ^ [lindex $P 0]}] [expr {$xr ^ [lindex $P 1]}]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::blowfish::Init {mode key iv} { |
||||||
|
variable ORIG_S |
||||||
|
variable ORIG_P |
||||||
|
variable uid |
||||||
|
|
||||||
|
set S $ORIG_S |
||||||
|
set P [list] |
||||||
|
|
||||||
|
set kl [string length $key] |
||||||
|
binary scan $key c* kc |
||||||
|
|
||||||
|
set j 0 |
||||||
|
for {set i 0} {$i < 18} {incr i} { |
||||||
|
set data 0 |
||||||
|
for {set k 0} {$k < 4} {incr k} { |
||||||
|
set data [expr {(($data << 8) | ([lindex $kc $j] & 0xff)) & 0xffffffff}] |
||||||
|
if {[incr j] >= $kl} { |
||||||
|
set j 0 |
||||||
|
} |
||||||
|
} |
||||||
|
set OPi [lindex $ORIG_P $i] |
||||||
|
lappend P [expr {$OPi ^ $data}] |
||||||
|
} |
||||||
|
|
||||||
|
set datal 0 |
||||||
|
set datar 0 |
||||||
|
|
||||||
|
for {set i 0} {$i < 18} {incr i} { |
||||||
|
set ed [intEncrypt $P $S $datal $datar] |
||||||
|
set datal [lindex $ed 0] |
||||||
|
set datar [lindex $ed 1] |
||||||
|
set P [lreplace $P $i [incr i] $datal $datar] |
||||||
|
} |
||||||
|
|
||||||
|
for {set i 0} {$i < 4} {incr i} { |
||||||
|
for {set j 0} {$j < 256} {incr j 2} { |
||||||
|
set ed [intEncrypt $P $S $datal $datar] |
||||||
|
set datal [lindex $ed 0] |
||||||
|
set datar [lindex $ed 1] |
||||||
|
set t [expr {$i * 256 + $j}] |
||||||
|
set S [lreplace $S $t [incr t] $datal $datar] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set token [namespace current]::[incr uid] |
||||||
|
variable $token |
||||||
|
upvar #0 $token state |
||||||
|
array set state [list P $P S $S M $mode I $iv] |
||||||
|
return $token |
||||||
|
} |
||||||
|
|
||||||
|
proc ::blowfish::Reset {token iv} { |
||||||
|
upvar #0 $token state |
||||||
|
set state(I) $iv |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::blowfish::Final {token} { |
||||||
|
# PRAGMA: nocheck |
||||||
|
variable $token |
||||||
|
unset $token |
||||||
|
} |
||||||
|
|
||||||
|
proc ::blowfish::EncryptBlock {token block} { |
||||||
|
upvar #0 $token state |
||||||
|
if {[binary scan $block II xl xr] != 2} { |
||||||
|
error "block must be 8 bytes" |
||||||
|
} |
||||||
|
set xl [expr {$xl & 0xffffffff}] |
||||||
|
set xr [expr {$xr & 0xffffffff}] |
||||||
|
set d [intEncrypt $state(P) $state(S) $xl $xr] |
||||||
|
return [binary format I2 $d] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::blowfish::Encrypt {Key data} { |
||||||
|
upvar #0 $Key state |
||||||
|
set P $state(P) |
||||||
|
set S $state(S) |
||||||
|
set cbc_mode [string equal "cbc" $state(M)] |
||||||
|
|
||||||
|
if {[binary scan $state(I) II s0 s1] != 2} { |
||||||
|
return -code error "invalid initialization vector: must be 8 bytes" |
||||||
|
} |
||||||
|
|
||||||
|
set len [string length $data] |
||||||
|
if {($len % 8) != 0} { |
||||||
|
return -code error "invalid block size: blocks must be 8 bytes" |
||||||
|
} |
||||||
|
|
||||||
|
set s0 [expr {$s0 & 0xffffffff}] |
||||||
|
set s1 [expr {$s1 & 0xffffffff}] |
||||||
|
|
||||||
|
set result "" |
||||||
|
for {set i 0} {$i < $len} {incr i 8} { |
||||||
|
if {[binary scan $data @[set i]II xl xr] != 2} { |
||||||
|
return -code error "oops" |
||||||
|
} |
||||||
|
if {$cbc_mode} { |
||||||
|
set xl [expr {($xl & 0xffffffff) ^ $s0}] |
||||||
|
set xr [expr {($xr & 0xffffffff) ^ $s1}] |
||||||
|
} |
||||||
|
set d [intEncrypt $P $S $xl $xr] |
||||||
|
if {$cbc_mode} { |
||||||
|
set s0 [lindex $d 0] |
||||||
|
set s1 [lindex $d 1] |
||||||
|
} |
||||||
|
append result [binary format I2 $d] |
||||||
|
} |
||||||
|
if {$cbc_mode} { |
||||||
|
set state(I) [binary format II $s0 $s1] |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
proc ::blowfish::DecryptBlock {Key block} { |
||||||
|
upvar #0 $Key state |
||||||
|
if {[binary scan $block II xl xr] != 2} { |
||||||
|
return -code error "invalid block size: block must be 8 bytes" |
||||||
|
} |
||||||
|
set xl [expr {$xl & 0xffffffff}] |
||||||
|
set xr [expr {$xr & 0xffffffff}] |
||||||
|
set d [intDecrypt $state(P) $state(S) $xl $xr] |
||||||
|
return [binary format I2 $d] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::blowfish::Decrypt {token data} { |
||||||
|
upvar #0 $token state |
||||||
|
set P $state(P) |
||||||
|
set S $state(S) |
||||||
|
set cbc_mode [string equal "cbc" $state(M)] |
||||||
|
|
||||||
|
if {[binary scan $state(I) II s0 s1] != 2} { |
||||||
|
return -code error "initialization vector must be 8 bytes" |
||||||
|
} |
||||||
|
|
||||||
|
set len [string length $data] |
||||||
|
if {($len % 8) != 0} { |
||||||
|
return -code error "block size invalid" |
||||||
|
} |
||||||
|
|
||||||
|
set s0 [expr {$s0 & 0xffffffff}] |
||||||
|
set s1 [expr {$s1 & 0xffffffff}] |
||||||
|
|
||||||
|
set result "" |
||||||
|
for {set i 0} {$i < $len} {incr i 8} { |
||||||
|
if {[binary scan $data @[set i]II xl xr] != 2} { |
||||||
|
error "oops" |
||||||
|
} |
||||||
|
set xl [expr {$xl & 0xffffffff}] |
||||||
|
set xr [expr {$xr & 0xffffffff}] |
||||||
|
set d [intDecrypt $P $S $xl $xr] |
||||||
|
if {$cbc_mode} { |
||||||
|
set d0 [lindex $d 0] |
||||||
|
set d1 [lindex $d 1] |
||||||
|
set c0 [expr {$d0 ^ $s0}] |
||||||
|
set c1 [expr {$d1 ^ $s1}] |
||||||
|
set s0 $xl |
||||||
|
set s1 $xr |
||||||
|
append result [binary format II $c0 $c1] |
||||||
|
} else { |
||||||
|
append result [binary format I2 $d] |
||||||
|
} |
||||||
|
} |
||||||
|
if {$cbc_mode} { |
||||||
|
set state(I) [binary format II $s0 $s1] |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# Fileevent handler for chunked file reading. |
||||||
|
# |
||||||
|
proc ::blowfish::Chunk {Key in {out {}} {chunksize 4096} {pad \0}} { |
||||||
|
upvar #0 $Key state |
||||||
|
|
||||||
|
if {[eof $in]} { |
||||||
|
fileevent $in readable {} |
||||||
|
set state(reading) 0 |
||||||
|
set data $state(remainder) |
||||||
|
|
||||||
|
# Only pad at the end of the stream. |
||||||
|
if {[string length $pad] > 0} { |
||||||
|
set data [Pad $data 8 $pad] |
||||||
|
} |
||||||
|
} else { |
||||||
|
set data [read $in $chunksize] |
||||||
|
#puts "Chunk: reading [string len $data] bytes" |
||||||
|
set data $state(remainder)$data |
||||||
|
|
||||||
|
# If data is not a multiple of 8, state(remainder) will hold |
||||||
|
# excess bytes for the next round. |
||||||
|
set pagedlen [expr {([string length $data] / 8) * 8}] |
||||||
|
set state(remainder) [string range $data $pagedlen end] |
||||||
|
incr pagedlen -1 |
||||||
|
set data [string range $data 0 $pagedlen] |
||||||
|
} |
||||||
|
|
||||||
|
if {![string length $data]} return |
||||||
|
|
||||||
|
if {[set code [catch { |
||||||
|
set cipher [$state(cmd) $Key $data] |
||||||
|
} msg]]} { |
||||||
|
fileevent $in readable {} |
||||||
|
set state(reading) 0 |
||||||
|
set state(err) [list $code $msg] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
if {$out == {}} { |
||||||
|
append state(output) $cipher |
||||||
|
} else { |
||||||
|
puts -nonewline $out $cipher |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# LoadAccelerator -- |
||||||
|
# |
||||||
|
# This package can make use of a number of compiled extensions to |
||||||
|
# accelerate the digest computation. This procedure manages the |
||||||
|
# use of these extensions within the package. During normal usage |
||||||
|
# this should not be called, but the test package manipulates the |
||||||
|
# list of enabled accelerators. |
||||||
|
# |
||||||
|
proc ::blowfish::LoadAccelerator {name} { |
||||||
|
variable accel |
||||||
|
set r 0 |
||||||
|
switch -exact -- $name { |
||||||
|
trf { |
||||||
|
if {![catch {package require Trfcrypt}]} { |
||||||
|
set block [string repeat \0 8] |
||||||
|
set r [expr {![catch {::blowfish -dir enc -mode ecb -key $block $block} msg]}] |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "invalid accelerator package:\ |
||||||
|
must be one of [join [array names accel] {, }]" |
||||||
|
} |
||||||
|
} |
||||||
|
set accel($name) $r |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
proc ::blowfish::Hex {data} { |
||||||
|
binary scan $data H* r |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
proc ::blowfish::SetOneOf {lst item} { |
||||||
|
set ndx [lsearch -glob $lst "${item}*"] |
||||||
|
if {$ndx == -1} { |
||||||
|
set err [join $lst ", "] |
||||||
|
return -code error "invalid mode \"$item\": must be one of $err" |
||||||
|
} |
||||||
|
return [lindex $lst $ndx] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::blowfish::CheckSize {what size thing} { |
||||||
|
if {[string length $thing] != $size} { |
||||||
|
return -code error "invalid value for $what: must be $size bytes long" |
||||||
|
} |
||||||
|
return $thing |
||||||
|
} |
||||||
|
|
||||||
|
proc ::blowfish::CheckPad {char} { |
||||||
|
if {[string length $char] > 1} { |
||||||
|
return -code error "invalid value: should be a char or empty string" |
||||||
|
} |
||||||
|
return $char |
||||||
|
} |
||||||
|
|
||||||
|
proc ::blowfish::Pad {data blocksize {fill \0}} { |
||||||
|
set len [string length $data] |
||||||
|
if {$len == 0} { |
||||||
|
# do not pad an empty string |
||||||
|
} elseif {($len % $blocksize) != 0} { |
||||||
|
set pad [expr {$blocksize - ($len % $blocksize)}] |
||||||
|
append data [string repeat $fill $pad] |
||||||
|
} |
||||||
|
return $data |
||||||
|
} |
||||||
|
|
||||||
|
# Description: |
||||||
|
# Pop the nth element off a list. Used in options processing. |
||||||
|
# |
||||||
|
proc ::blowfish::Pop {varname {nth 0}} { |
||||||
|
upvar $varname args |
||||||
|
set r [lindex $args $nth] |
||||||
|
set args [lreplace $args $nth $nth] |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
proc ::blowfish::blowfish {args} { |
||||||
|
variable accel |
||||||
|
array set opts {-dir encrypt -mode cbc -key {} -in {} -out {} -hex 0 -pad \0} |
||||||
|
set opts(-chunksize) 4096 |
||||||
|
set opts(-iv) [string repeat \0 8] |
||||||
|
set modes {ecb cbc} |
||||||
|
set dirs {encrypt decrypt} |
||||||
|
while {[string match -* [set option [lindex $args 0]]]} { |
||||||
|
switch -exact -- $option { |
||||||
|
-mode { set opts(-mode) [SetOneOf $modes [Pop args 1]] } |
||||||
|
-dir { set opts(-dir) [SetOneOf $dirs [Pop args 1]] } |
||||||
|
-iv { set opts(-iv) [CheckSize -iv 8 [Pop args 1]] } |
||||||
|
-key { set opts(-key) [Pop args 1] } |
||||||
|
-in { set opts(-in) [Pop args 1] } |
||||||
|
-out { set opts(-out) [Pop args 1] } |
||||||
|
-chunksize { set opts(-chunksize) [Pop args 1] } |
||||||
|
-hex { set opts(-hex) 1 } |
||||||
|
-pad { set opts(-pad) [CheckPad [Pop args 1]] } |
||||||
|
-- { Pop args; break } |
||||||
|
default { |
||||||
|
if {[string length $opts(-in)] == 0 && [llength $args] == 1} break |
||||||
|
set err [join [lsort [array names opts]] ", "] |
||||||
|
return -code error "bad option \"$option\":\ |
||||||
|
must be one of $err" |
||||||
|
} |
||||||
|
} |
||||||
|
Pop args |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-key) == {}} { |
||||||
|
return -code error "no key provided: the -key option is required" |
||||||
|
} |
||||||
|
|
||||||
|
set r {} |
||||||
|
if {$opts(-in) == {}} { |
||||||
|
# Immediate data (plain text is argument). |
||||||
|
|
||||||
|
if {[llength $args] != 1} { |
||||||
|
return -code error "wrong \# args:\ |
||||||
|
should be \"blowfish ?options...? -key keydata plaintext\"" |
||||||
|
} |
||||||
|
|
||||||
|
set data [lindex $args 0] |
||||||
|
if {[string length $opts(-pad)] > 0} { |
||||||
|
set data [Pad [lindex $args 0] 8 $opts(-pad)] |
||||||
|
} |
||||||
|
if {$accel(trf)} { |
||||||
|
set r [::blowfish -dir $opts(-dir) -mode $opts(-mode) \ |
||||||
|
-key $opts(-key) -iv $opts(-iv) -- $data] |
||||||
|
} else { |
||||||
|
set Key [Init $opts(-mode) $opts(-key) $opts(-iv)] |
||||||
|
if {[string equal $opts(-dir) "encrypt"]} { |
||||||
|
set r [Encrypt $Key $data] |
||||||
|
} else { |
||||||
|
set r [Decrypt $Key $data] |
||||||
|
} |
||||||
|
Final $Key |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-out) != {}} { |
||||||
|
puts -nonewline $opts(-out) $r |
||||||
|
set r {} |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
# Channel data (plain text is read from a binary channel). |
||||||
|
|
||||||
|
if {[llength $args] != 0} { |
||||||
|
return -code error "wrong \# args:\ |
||||||
|
should be \"blowfish ?options...? -key keydata -in channel\"" |
||||||
|
} |
||||||
|
|
||||||
|
set Key [Init $opts(-mode) $opts(-key) $opts(-iv)] |
||||||
|
upvar $Key state |
||||||
|
set state(reading) 1 |
||||||
|
if {[string equal $opts(-dir) "encrypt"]} { |
||||||
|
set state(cmd) Encrypt |
||||||
|
} else { |
||||||
|
set state(cmd) Decrypt |
||||||
|
} |
||||||
|
set state(output) "" |
||||||
|
set state(remainder) "" |
||||||
|
fileevent $opts(-in) readable \ |
||||||
|
[list [namespace origin Chunk] \ |
||||||
|
$Key $opts(-in) $opts(-out) $opts(-chunksize) $opts(-pad)] |
||||||
|
if {[info commands ::tkwait] != {}} { |
||||||
|
tkwait variable [subst $Key](reading) |
||||||
|
} else { |
||||||
|
vwait [subst $Key](reading) |
||||||
|
} |
||||||
|
|
||||||
|
if {[info exists state(err)]} { |
||||||
|
foreach {code msg} $state(err) break |
||||||
|
return -code $code $msg |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-out) == {}} { |
||||||
|
set r $state(output) |
||||||
|
} |
||||||
|
Final $Key |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-hex)} { |
||||||
|
set r [Hex $r] |
||||||
|
} |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# Try and load a compiled extension to help. |
||||||
|
namespace eval ::blowfish { |
||||||
|
variable e {} |
||||||
|
foreach e {trf} { |
||||||
|
if {[LoadAccelerator $e]} break |
||||||
|
} |
||||||
|
unset e |
||||||
|
} |
||||||
|
|
||||||
|
package provide blowfish 1.0.6 |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# |
||||||
|
# Local Variables: |
||||||
|
# mode: tcl |
||||||
|
# indent-tabs-mode: nil |
||||||
|
# End: |
||||||
@ -0,0 +1,5 @@ |
|||||||
|
if {![package vsatisfies [package provide Tcl] 8.5 9]} { |
||||||
|
# PRAGMA: returnok |
||||||
|
return |
||||||
|
} |
||||||
|
package ifneeded blowfish 1.0.6 [list source [file join $dir blowfish.tcl]] |
||||||
@ -0,0 +1,185 @@ |
|||||||
|
## -*- tcl -*- |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
|
||||||
|
# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||||
|
|
||||||
|
# Aynchronous in-memory cache. Queries of the cache generate |
||||||
|
# asynchronous requests for data for unknown parts, with asynchronous |
||||||
|
# result return. Data found in the cache may return fully asynchronous |
||||||
|
# as well, or semi-synchronous. The latter meaning that the regular |
||||||
|
# callbacks are used, but invoked directly, and not decoupled through |
||||||
|
# events. The cache can be pre-filled synchronously. |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requisites |
||||||
|
|
||||||
|
package require Tcl 8.5 9 ; # |
||||||
|
package require snit ; # |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## |
||||||
|
|
||||||
|
snit::type cache::async { |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Unknown methods and options are forwared to the object actually |
||||||
|
## providing the cached data, making the cache a proper facade for |
||||||
|
## it. |
||||||
|
|
||||||
|
delegate method * to myprovider |
||||||
|
delegate option * to myprovider |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## API |
||||||
|
|
||||||
|
option -full-async-results -default 1 -type snit::boolean |
||||||
|
|
||||||
|
constructor {provider args} { |
||||||
|
set myprovider $provider |
||||||
|
$self configurelist $args |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method get {key donecmd} { |
||||||
|
# Register request |
||||||
|
lappend mywaiting($key) $donecmd |
||||||
|
|
||||||
|
# Check if the request can be satisfied from the cache. If yes |
||||||
|
# then that is done. |
||||||
|
|
||||||
|
if {[info exists mymiss($key)]} { |
||||||
|
$self NotifyUnset 1 $key |
||||||
|
return |
||||||
|
} elseif {[info exists myhit($key)]} { |
||||||
|
$self NotifySet 1 $key |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# We have to ask our provider if there is data or |
||||||
|
# not. however, if a request for this key is already in flight |
||||||
|
# then we have to do nothing more. Our registration at the |
||||||
|
# beginning ensures that we will get notified when the |
||||||
|
# requested information comes back. |
||||||
|
|
||||||
|
if {[llength $mywaiting($key)] > 1} return |
||||||
|
|
||||||
|
# This is the first query for this key, ask the provider. |
||||||
|
|
||||||
|
after idle [linsert $myprovider end get $key $self] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method clear {args} { |
||||||
|
# Note: This method cannot interfere with async queries caused |
||||||
|
# by 'get' invokations. If the data is present, and now |
||||||
|
# removed, all 'get' invokations before this call were |
||||||
|
# satisfied from the cache and only invokations coming after |
||||||
|
# it can trigger async queries of the provider. If the data is |
||||||
|
# not present the state will not change, and queries in flight |
||||||
|
# simply refill the cache as they would do anyway without the |
||||||
|
# 'clear'. |
||||||
|
|
||||||
|
if {![llength $args]} { |
||||||
|
array unset myhit * |
||||||
|
array unset mymiss * |
||||||
|
} elseif {[llength $args] == 1} { |
||||||
|
set key [lindex $args 0] |
||||||
|
unset -nocomplain myhit($key) |
||||||
|
unset -nocomplain mymiss($key) |
||||||
|
} else { |
||||||
|
WrongArgs ?key? |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method exists {key} { |
||||||
|
return [expr {[info exists myhit($key)] || [info exists mymiss($key)]}] |
||||||
|
} |
||||||
|
|
||||||
|
method set {key value} { |
||||||
|
# Add data to the cache, and notify all outstanding queries. |
||||||
|
# Nothing is done if the key is already known and has the same |
||||||
|
# value. |
||||||
|
|
||||||
|
# This is the method invoked by the provider in response to |
||||||
|
# queries, and also the method to use to prefill the cache |
||||||
|
# with data. |
||||||
|
|
||||||
|
if { |
||||||
|
[info exists myhit($key)] && |
||||||
|
($value eq $myhit($key)) |
||||||
|
} return |
||||||
|
|
||||||
|
set myhit($key) $value |
||||||
|
unset -nocomplain mymiss($key) |
||||||
|
$self NotifySet 0 $key |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method unset {key} { |
||||||
|
# Add hole to the cache, and notify all outstanding queries. |
||||||
|
# This is the method invoked by the provider in response to |
||||||
|
# queries, and also the method to use to prefill the cache |
||||||
|
# with holes. |
||||||
|
unset -nocomplain myhit($key) |
||||||
|
set mymiss($key) . |
||||||
|
$self NotifyUnset 0 $key |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method NotifySet {found key} { |
||||||
|
if {![info exists mywaiting($key)] || ![llength $mywaiting($key)]} return |
||||||
|
|
||||||
|
set pending $mywaiting($key) |
||||||
|
unset mywaiting($key) |
||||||
|
|
||||||
|
set value $myhit($key) |
||||||
|
if {$found && !$options(-full-async-results)} { |
||||||
|
foreach donecmd $pending { |
||||||
|
uplevel \#0 [linsert $donecmd end set $key $value] |
||||||
|
} |
||||||
|
} else { |
||||||
|
foreach donecmd $pending { |
||||||
|
after idle [linsert $donecmd end set $key $value] |
||||||
|
} |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method NotifyUnset {found key} { |
||||||
|
if {![info exists mywaiting($key)] || ![llength $mywaiting($key)]} return |
||||||
|
|
||||||
|
set pending $mywaiting($key) |
||||||
|
unset mywaiting($key) |
||||||
|
|
||||||
|
if {$found && !$options(-full-async-results)} { |
||||||
|
foreach donecmd $pending { |
||||||
|
uplevel \#0 [linsert $donecmd end unset $key] |
||||||
|
} |
||||||
|
} else { |
||||||
|
foreach donecmd $pending { |
||||||
|
after idle [linsert $donecmd end unset $key] |
||||||
|
} |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc WrongArgs {expected} { |
||||||
|
return -code error "wrong#args: Expected $expected" |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## State |
||||||
|
|
||||||
|
variable myprovider ; # Command prefix providing the data to cache. |
||||||
|
variable myhit -array {} ; # Cache array mapping keys to values. |
||||||
|
variable mymiss -array {} ; # Cache array mapping keys to holes. |
||||||
|
variable mywaiting -array {} ; # Map of keys pending to notifier commands. |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide cache::async 0.3.2 |
||||||
@ -0,0 +1,3 @@ |
|||||||
|
if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} |
||||||
|
package ifneeded cache::async 0.3.2 [list source [file join $dir async.tcl]] |
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,3 @@ |
|||||||
|
if {![package vsatisfies [package provide Tcl] 8.6 9]} {return} |
||||||
|
package ifneeded clay 0.8.8 [list source [file join $dir clay.tcl]] |
||||||
|
|
||||||
@ -0,0 +1,280 @@ |
|||||||
|
## -*- tcl -*- |
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Copyright (c) 2004 Kevin Kenny |
||||||
|
## Origin http://wiki.tcl.tk/13094 |
||||||
|
## Modified for Tcl 8.5 only (eval -> {*}). |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Requisites |
||||||
|
|
||||||
|
package require Tcl 8.5 9 |
||||||
|
package provide clock::iso8601 0.2 |
||||||
|
namespace eval ::clock::iso8601 {} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## API |
||||||
|
|
||||||
|
# iso8601::parse_date -- |
||||||
|
# |
||||||
|
# Parse an ISO8601 date/time string in an unknown variant. |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# string -- String to parse |
||||||
|
# args -- Arguments as for [clock scan]; may include any of |
||||||
|
# the '-base', '-gmt', '-locale' or '-timezone options. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# Returns the given date in seconds from the Posix epoch. |
||||||
|
|
||||||
|
proc ::clock::iso8601::parse_date { string args } { |
||||||
|
variable DatePatterns |
||||||
|
variable Repattern |
||||||
|
foreach { regex interpretation } $DatePatterns { |
||||||
|
if { [regexp "^$regex\$" $string] } { |
||||||
|
#puts A|$string|\t|$regex|\t|$interpretation| |
||||||
|
|
||||||
|
# For incomplete dates (month and/or day missing), we have |
||||||
|
# to set our own default values to overcome clock scan's |
||||||
|
# settings. We do this by switching to a different pattern |
||||||
|
# and extending the input properly for that pattern. |
||||||
|
|
||||||
|
if {[dict exists $Repattern $interpretation]} { |
||||||
|
lassign [dict get $Repattern $interpretation] interpretation adjust modifier |
||||||
|
{*}$modifier |
||||||
|
# adjust irrelevant here, see parse_time for use. |
||||||
|
} |
||||||
|
|
||||||
|
#puts B|$string|\t|$regex|\t|$interpretation| |
||||||
|
return [clock scan $string -format $interpretation {*}$args] |
||||||
|
} |
||||||
|
} |
||||||
|
return -code error "not an iso8601 date string" |
||||||
|
} |
||||||
|
|
||||||
|
# iso8601::parse_time -- |
||||||
|
# |
||||||
|
# Parse a point-in-time in ISO8601 format |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# string -- String to parse |
||||||
|
# args -- Arguments as for [clock scan]; may include any of |
||||||
|
# the '-base', '-gmt', '-locale' or '-timezone options. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# Returns the given time in seconds from the Posix epoch. |
||||||
|
|
||||||
|
proc ::clock::iso8601::parse_time { string args } { |
||||||
|
variable DatePatterns |
||||||
|
variable Repattern |
||||||
|
if {![MatchTime $string field]} { |
||||||
|
return -code error "not an iso8601 time string" |
||||||
|
} |
||||||
|
|
||||||
|
#parray field |
||||||
|
#puts A|$string| |
||||||
|
|
||||||
|
set pattern {} |
||||||
|
foreach {regex interpretation} $DatePatterns { |
||||||
|
if {[Has $interpretation tstart]} { |
||||||
|
append pattern $interpretation |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[dict exists $Repattern $pattern]} { |
||||||
|
lassign [dict get $Repattern $pattern] interpretation adjust modifier |
||||||
|
{*}$modifier |
||||||
|
incr tstart $adjust |
||||||
|
} |
||||||
|
|
||||||
|
append pattern [Get T len] |
||||||
|
incr tstart $len |
||||||
|
|
||||||
|
if {[Has %H tstart]} { |
||||||
|
append pattern %H [Get Hcolon len] |
||||||
|
incr tstart $len |
||||||
|
|
||||||
|
if {[Has %M tstart]} { |
||||||
|
append pattern %M [Get Mcolon len] |
||||||
|
incr tstart $len |
||||||
|
|
||||||
|
if {[Has %S tstart]} { |
||||||
|
append pattern %S |
||||||
|
} else { |
||||||
|
# No seconds, default to start of minute. |
||||||
|
append pattern %S |
||||||
|
Insert string $tstart 00 |
||||||
|
} |
||||||
|
} else { |
||||||
|
# No minutes, nor seconds, default to start of hour. |
||||||
|
append pattern %M%S |
||||||
|
Insert string $tstart 0000 |
||||||
|
} |
||||||
|
} else { |
||||||
|
# No time information, default to midnight. |
||||||
|
append pattern %H%M%S |
||||||
|
Insert string $tstart 000000 |
||||||
|
} |
||||||
|
if {[Has %Z _]} { |
||||||
|
append pattern %Z |
||||||
|
} |
||||||
|
|
||||||
|
#puts B|$string|\t|$pattern| |
||||||
|
return [clock scan $string -format $pattern {*}$args] |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
|
||||||
|
proc ::clock::iso8601::Get {x lv} { |
||||||
|
upvar 1 field field string string $lv len |
||||||
|
lassign $field($x) s e |
||||||
|
if {($s >= 0) && ($e >= 0)} { |
||||||
|
set len [expr {$e - $s + 1}] |
||||||
|
return [string range $string $s $e] |
||||||
|
} |
||||||
|
set len 0 |
||||||
|
return "" |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
proc ::clock::iso8601::Has {x nv} { |
||||||
|
upvar 1 field field string string $nv next |
||||||
|
lassign $field($x) s e |
||||||
|
if {($s >= 0) && ($e >= 0)} { |
||||||
|
set next $e |
||||||
|
incr next |
||||||
|
return 1 |
||||||
|
} |
||||||
|
return 0 |
||||||
|
} |
||||||
|
|
||||||
|
proc ::clock::iso8601::Insert {sv index str} { |
||||||
|
upvar 1 $sv string |
||||||
|
append r [string range $string 0 ${index}-1] |
||||||
|
append r $str |
||||||
|
append r [string range $string $index end] |
||||||
|
set string $r |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## State |
||||||
|
|
||||||
|
namespace eval ::clock::iso8601 { |
||||||
|
|
||||||
|
namespace export parse_date parse_time |
||||||
|
namespace ensemble create |
||||||
|
|
||||||
|
# Enumerate the patterns that we recognize for an ISO8601 date as both |
||||||
|
# the regexp patterns that match them and the [clock] patterns that scan |
||||||
|
# them. |
||||||
|
|
||||||
|
variable DatePatterns { |
||||||
|
{\d\d\d\d-\d\d-\d\d} {%Y-%m-%d} |
||||||
|
{\d\d\d\d\d\d\d\d} {%Y%m%d} |
||||||
|
{\d\d\d\d-\d\d\d} {%Y-%j} |
||||||
|
{\d\d\d\d\d\d\d} {%Y%j} |
||||||
|
{\d\d-\d\d-\d\d} {%y-%m-%d} |
||||||
|
{\d\d\d\d-\d\d} {%Y-%m} |
||||||
|
{\d\d\d\d\d\d} {%y%m%d} |
||||||
|
{\d\d-\d\d\d} {%y-%j} |
||||||
|
{\d\d\d\d\d} {%y%j} |
||||||
|
{--\d\d-\d\d} {--%m-%d} |
||||||
|
{--\d\d\d\d} {--%m%d} |
||||||
|
{--\d\d\d} {--%j} |
||||||
|
{---\d\d} {---%d} |
||||||
|
{\d\d\d\d-W\d\d-\d} {%G-W%V-%u} |
||||||
|
{\d\d\d\dW\d\d\d} {%GW%V%u} |
||||||
|
{\d\d-W\d\d-\d} {%g-W%V-%u} |
||||||
|
{\d\dW\d\d\d} {%gW%V%u} |
||||||
|
{\d\d\d\d-W\d\d} {%G-W%V} |
||||||
|
{\d\d\d\dW\d\d} {%GW%V} |
||||||
|
{-W\d\d-\d} {-W%V-%u} |
||||||
|
{-W\d\d\d} {-W%V%u} |
||||||
|
{-W-\d} {%u} |
||||||
|
{\d\d\d\d} {%Y} |
||||||
|
} |
||||||
|
|
||||||
|
# Dictionary of the patterns requiring modifications to the input |
||||||
|
# for proper month and/or day defaults. |
||||||
|
variable Repattern { |
||||||
|
%Y-%m {%Y-%m-%d 3 {Insert string 7 -01}} |
||||||
|
%Y {%Y-%m-%d 5 {Insert string 4 -01-01}} |
||||||
|
%G-W%V {%G-W%V-%u 1 {Insert string 8 -1}} |
||||||
|
%GW%V {%GW%V%u 1 {Insert string 6 1}} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Initialization |
||||||
|
|
||||||
|
apply {{} { |
||||||
|
# MatchTime -- (constructed procedure) |
||||||
|
# |
||||||
|
# Match an ISO8601 date/time string and indicate how it matched. |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# string -- String to match. |
||||||
|
# fieldArray -- Name of an array in caller's scope that will receive |
||||||
|
# parsed fields of the time. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# Returns 1 if the time was scanned successfully, 0 otherwise. |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
# Initializes the field array. The keys that are significant: |
||||||
|
# - Any date pattern in 'DatePatterns' indicates that the |
||||||
|
# corresponding value, if non-empty, contains a date string |
||||||
|
# in the given format. |
||||||
|
# - The patterns T, Hcolon, and Mcolon indicate a literal |
||||||
|
# T preceding the time, a colon following the hour, or |
||||||
|
# a colon following the minute. |
||||||
|
# - %H, %M, %S, and %Z indicate the presence of the |
||||||
|
# corresponding parts of the time. |
||||||
|
|
||||||
|
variable DatePatterns |
||||||
|
|
||||||
|
set cmd {regexp -indices -expanded -nocase -- {PATTERN} $timeString ->} |
||||||
|
set re \(?:\(?: |
||||||
|
set sep {} |
||||||
|
foreach {regex interpretation} $DatePatterns { |
||||||
|
append re $sep \( $regex \) |
||||||
|
append cmd " " [list field($interpretation)] |
||||||
|
set sep | |
||||||
|
} |
||||||
|
append re \) {(T|[[:space:]]+)} \)? |
||||||
|
append cmd { field(T)} |
||||||
|
append re {(\d\d)(?:(:?)(\d\d)(?:(:?)(\d\d)?))?} |
||||||
|
append cmd { field(%H) field(Hcolon) } {field(%M) field(Mcolon) field(%S)} |
||||||
|
append re {[[:space:]]*(Z|[-+]\d\d:?\d\d)?} |
||||||
|
append cmd { field(%Z)} |
||||||
|
set cmd [string map [list {{PATTERN}} [list $re]] \ |
||||||
|
$cmd] |
||||||
|
|
||||||
|
proc MatchTime { timeString fieldArray } " |
||||||
|
upvar 1 \$fieldArray field |
||||||
|
$cmd |
||||||
|
" |
||||||
|
|
||||||
|
#puts [info body MatchTime] |
||||||
|
|
||||||
|
} ::clock::iso8601} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
|
||||||
|
return |
||||||
|
# Usage examples, disabled. |
||||||
|
|
||||||
|
if { [info exists ::argv0] && ( $::argv0 eq [info script] ) } { |
||||||
|
puts "::clock::iso8601::parse_date" |
||||||
|
puts [::clock::iso8601::parse_date 1970-01-02 -timezone :UTC] |
||||||
|
puts [::clock::iso8601::parse_date 1970-W01-5 -timezone :UTC] |
||||||
|
puts [time {::clock::iso8601::parse_date 1970-01-02 -timezone :UTC} 1000] |
||||||
|
puts [time {::clock::iso8601::parse_date 1970-W01-5 -timezone :UTC} 1000] |
||||||
|
puts "::clock::iso8601::parse_time" |
||||||
|
puts [clock format [::clock::iso8601::parse_time 2004-W33-2T18:52:24Z] \ |
||||||
|
-format {%X %x %z} -locale system] |
||||||
|
puts [clock format [::clock::iso8601::parse_time 18:52:24Z] \ |
||||||
|
-format {%X %x %z} -locale system] |
||||||
|
puts [time {::clock::iso8601::parse_time 2004-W33-2T18:52:24Z} 1000] |
||||||
|
puts [time {::clock::iso8601::parse_time 18:52:24Z} 1000] |
||||||
|
} |
||||||
@ -0,0 +1,3 @@ |
|||||||
|
if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} |
||||||
|
package ifneeded clock::rfc2822 0.2 [list source [file join $dir rfc2822.tcl]] |
||||||
|
package ifneeded clock::iso8601 0.2 [list source [file join $dir iso8601.tcl]] |
||||||
@ -0,0 +1,214 @@ |
|||||||
|
## -*- tcl -*- |
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Copyright (c) 2004 Kevin Kenny |
||||||
|
## Origin http://wiki.tcl.tk/24074 |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Requisites |
||||||
|
|
||||||
|
package require Tcl 8.5 9 |
||||||
|
package provide clock::rfc2822 0.2 |
||||||
|
namespace eval ::clock::rfc2822 {} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## API |
||||||
|
|
||||||
|
# ::clock::rfc2822::parse_date -- |
||||||
|
# |
||||||
|
# Parses a date expressed in RFC2822 format |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# date - The date to parse |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# Returns the date expressed in seconds from the Epoch, or throws |
||||||
|
# an error if the date could not be parsed. |
||||||
|
|
||||||
|
proc ::clock::rfc2822::parse_date { date } { |
||||||
|
variable datepats |
||||||
|
|
||||||
|
# Strip comments and excess whitespace from the date field |
||||||
|
|
||||||
|
regsub -all -expanded { |
||||||
|
\( # open parenthesis |
||||||
|
(:? |
||||||
|
[^()[.\.]] # character other than ()\ |
||||||
|
|\\. # or backslash escape |
||||||
|
)* # any number of times |
||||||
|
\) # close paren |
||||||
|
} $date {} date |
||||||
|
set date [string trim $date] |
||||||
|
|
||||||
|
# Match the patterns in order of preference, returning the first success |
||||||
|
|
||||||
|
foreach {regexp pat} $datepats { |
||||||
|
if { [regexp -nocase $regexp $date] } { |
||||||
|
return [clock scan $date -format $pat] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return -code error -errorcode {CLOCK RFC2822 BADDATE} \ |
||||||
|
"expected an RFC2822 date, got \"$date\"" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## Internals, transient, removed after initialization. |
||||||
|
|
||||||
|
# AddDatePat -- |
||||||
|
# |
||||||
|
# Internal procedure that adds a date pattern to the pattern list |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# wpat - Regexp pattern that matches the weekday |
||||||
|
# wgrp - Format group that matches the weekday |
||||||
|
# ypat - Regexp pattern that matches the year |
||||||
|
# ygrp - Format group that matches the year |
||||||
|
# mdpat - Regexp pattern that matches month and day |
||||||
|
# mdgrp - Format group that matches month and day |
||||||
|
# spat - Regexp pattern that matches the seconds of the minute |
||||||
|
# sgrp - Format group that matches the seconds of the minute |
||||||
|
# zpat - Regexp pattern that matches the time zone |
||||||
|
# zgrp - Format group that matches the time zone |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# None |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
# Adds a complete regexp and a complete [clock scan] pattern to |
||||||
|
# 'datepats' |
||||||
|
|
||||||
|
proc ::clock::rfc2822::AddDatePat { wpat wgrp ypat ygrp mdpat mdgrp |
||||||
|
spat sgrp zpat zgrp } { |
||||||
|
variable datepats |
||||||
|
|
||||||
|
set regexp {^[[:space:]]*} |
||||||
|
set pat {} |
||||||
|
append regexp $wpat $mdpat {[[:space:]]+} $ypat |
||||||
|
append pat $wgrp $mdgrp $ygrp |
||||||
|
append regexp {[[:space:]]+\d\d?:\d\d} $spat |
||||||
|
append pat { %H:%M} $sgrp |
||||||
|
append regexp $zpat |
||||||
|
append pat $zgrp |
||||||
|
append regexp {[[:space:]]*$} |
||||||
|
lappend datepats $regexp $pat |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# InitDatePats -- |
||||||
|
# |
||||||
|
# Internal procedure that initializes the set of date patterns |
||||||
|
# allowed in an RFC2822 date |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# permissible - 1 if erroneous (but common) time zones are to be |
||||||
|
# allowed, 0 if they are to be rejected |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# None. |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
|
||||||
|
proc ::clock::rfc2822::InitDatePats { permissible } { |
||||||
|
# Produce formats for the observed variants of RFC 2822 dates. |
||||||
|
# Permissible variants come first in the list; impermissible ones |
||||||
|
# come later. |
||||||
|
|
||||||
|
# The month and day may be "%b %d" or "%d %b" |
||||||
|
|
||||||
|
foreach mdpat {{[[:alpha:]]+[[:space:]]+\d\d?} |
||||||
|
{\d\d?[[:space:]]+[[:alpha:]]+}} \ |
||||||
|
mdgrp {{%b %d} {%d %b}} \ |
||||||
|
mdperm {0 1} { |
||||||
|
# The year may be two digits, or four. Four digit year is |
||||||
|
# done first. |
||||||
|
|
||||||
|
foreach ypat {{\d\d\d\d} {\d\d}} ygrp {%Y %y} { |
||||||
|
# The seconds of the minute may be provided, or |
||||||
|
# omitted. |
||||||
|
|
||||||
|
foreach spat {{:\d\d} {}} sgrp {:%S {}} { |
||||||
|
# The weekday may be provided or omitted. It is |
||||||
|
# common but impermissible to omit the comma after |
||||||
|
# the weekday name. |
||||||
|
|
||||||
|
foreach wpat { |
||||||
|
{(?:Mon|T(?:ue|hu)|Wed|Fri|S(?:at|un)),[[:space:]]+} |
||||||
|
{(?:Mon|T(?:ue|hu)|Wed|Fri|S(?:at|un))[[:space:]]+} |
||||||
|
{} |
||||||
|
} wgrp { |
||||||
|
{%a, } |
||||||
|
{%a } |
||||||
|
{} |
||||||
|
} wperm { |
||||||
|
1 |
||||||
|
0 |
||||||
|
1 |
||||||
|
} { |
||||||
|
# Time zone is defined as +/- hhmm, or as a |
||||||
|
# named time zone. Other common but buggy |
||||||
|
# formats are GMT+-hh:mm, a time zone name in |
||||||
|
# quotation marks, and complete omission of |
||||||
|
# the time zone. |
||||||
|
|
||||||
|
foreach zpat { |
||||||
|
{[[:space:]]+(?:[-+]\d\d\d\d|[[:alpha:]]+)} |
||||||
|
{[[:space:]]+GMT[-+]\d\d:?\d\d} |
||||||
|
{[[:space:]]+"[[:alpha:]]+"} |
||||||
|
{} |
||||||
|
} zgrp { |
||||||
|
{ %Z} |
||||||
|
{ GMT%Z} |
||||||
|
{ "%Z"} |
||||||
|
{} |
||||||
|
} zperm { |
||||||
|
1 |
||||||
|
0 |
||||||
|
0 |
||||||
|
0 |
||||||
|
} { |
||||||
|
if { ($zperm && $wperm && $mdperm) |
||||||
|
== $permissible } { |
||||||
|
AddDatePat $wpat $wgrp $ypat $ygrp \ |
||||||
|
$mdpat $mdgrp \ |
||||||
|
$spat $sgrp $zpat $zgrp |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
## State |
||||||
|
|
||||||
|
namespace eval ::clock::rfc2822 { |
||||||
|
namespace export parse_date |
||||||
|
namespace ensemble create |
||||||
|
|
||||||
|
variable datepats {} |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
# Initialize the date patterns |
||||||
|
|
||||||
|
namespace eval ::clock::rfc2822 { |
||||||
|
InitDatePats 1 |
||||||
|
InitDatePats 0 |
||||||
|
rename AddDatePat {} |
||||||
|
rename InitDatePats {} |
||||||
|
#puts [join $datepats \n] |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
|
||||||
|
return |
||||||
|
# Usage example, disabled |
||||||
|
|
||||||
|
if {![info exists ::argv0] || [info script] ne $::argv0} return |
||||||
|
puts [clock format \ |
||||||
|
[::clock::rfc2822::parse_date {Mon(day), 23 Aug(ust) 2004 01:23:45 UT}]] |
||||||
|
puts [clock format \ |
||||||
|
[::clock::rfc2822::parse_date "Tue, Jul 21 2009 19:37:47 GMT-0400"]] |
||||||
@ -0,0 +1,933 @@ |
|||||||
|
# cmdline.tcl -- |
||||||
|
# |
||||||
|
# This package provides a utility for parsing command line |
||||||
|
# arguments that are processed by our various applications. |
||||||
|
# It also includes a utility routine to determine the |
||||||
|
# application name for use in command line errors. |
||||||
|
# |
||||||
|
# Copyright (c) 1998-2000 by Ajuba Solutions. |
||||||
|
# Copyright (c) 2001-2015 by Andreas Kupries <andreas_kupries@users.sf.net>. |
||||||
|
# Copyright (c) 2003 by David N. Welton <davidw@dedasys.com> |
||||||
|
# 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.5 9 |
||||||
|
package provide cmdline 1.5.3 |
||||||
|
|
||||||
|
namespace eval ::cmdline { |
||||||
|
namespace export getArgv0 getopt getKnownOpt getfiles getoptions \ |
||||||
|
getKnownOptions usage |
||||||
|
} |
||||||
|
|
||||||
|
# ::cmdline::getopt -- |
||||||
|
# |
||||||
|
# The cmdline::getopt works in a fashion like the standard |
||||||
|
# C based getopt function. Given an option string and a |
||||||
|
# pointer to an array or args this command will process the |
||||||
|
# first argument and return info on how to proceed. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# argvVar Name of the argv list that you |
||||||
|
# want to process. If options are found the |
||||||
|
# arg list is modified and the processed arguments |
||||||
|
# are removed from the start of the list. |
||||||
|
# optstring A list of command options that the application |
||||||
|
# will accept. If the option ends in ".arg" the |
||||||
|
# getopt routine will use the next argument as |
||||||
|
# an argument to the option. Otherwise the option |
||||||
|
# is a boolean that is set to 1 if present. |
||||||
|
# optVar The variable pointed to by optVar |
||||||
|
# contains the option that was found (without the |
||||||
|
# leading '-' and without the .arg extension). |
||||||
|
# valVar Upon success, the variable pointed to by valVar |
||||||
|
# contains the value for the specified option. |
||||||
|
# This value comes from the command line for .arg |
||||||
|
# options, otherwise the value is 1. |
||||||
|
# If getopt fails, the valVar is filled with an |
||||||
|
# error message. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The getopt function returns 1 if an option was found, 0 if no more |
||||||
|
# options were found, and -1 if an error occurred. |
||||||
|
|
||||||
|
proc ::cmdline::getopt {argvVar optstring optVar valVar} { |
||||||
|
upvar 1 $argvVar argsList |
||||||
|
upvar 1 $optVar option |
||||||
|
upvar 1 $valVar value |
||||||
|
|
||||||
|
set result [getKnownOpt argsList $optstring option value] |
||||||
|
|
||||||
|
if {$result < 0} { |
||||||
|
# Collapse unknown-option error into any-other-error result. |
||||||
|
set result -1 |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
# ::cmdline::getKnownOpt -- |
||||||
|
# |
||||||
|
# The cmdline::getKnownOpt works in a fashion like the standard |
||||||
|
# C based getopt function. Given an option string and a |
||||||
|
# pointer to an array or args this command will process the |
||||||
|
# first argument and return info on how to proceed. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# argvVar Name of the argv list that you |
||||||
|
# want to process. If options are found the |
||||||
|
# arg list is modified and the processed arguments |
||||||
|
# are removed from the start of the list. Note that |
||||||
|
# unknown options and the args that follow them are |
||||||
|
# left in this list. |
||||||
|
# optstring A list of command options that the application |
||||||
|
# will accept. If the option ends in ".arg" the |
||||||
|
# getopt routine will use the next argument as |
||||||
|
# an argument to the option. Otherwise the option |
||||||
|
# is a boolean that is set to 1 if present. |
||||||
|
# optVar The variable pointed to by optVar |
||||||
|
# contains the option that was found (without the |
||||||
|
# leading '-' and without the .arg extension). |
||||||
|
# valVar Upon success, the variable pointed to by valVar |
||||||
|
# contains the value for the specified option. |
||||||
|
# This value comes from the command line for .arg |
||||||
|
# options, otherwise the value is 1. |
||||||
|
# If getopt fails, the valVar is filled with an |
||||||
|
# error message. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The getKnownOpt function returns 1 if an option was found, |
||||||
|
# 0 if no more options were found, -1 if an unknown option was |
||||||
|
# encountered, and -2 if any other error occurred. |
||||||
|
|
||||||
|
proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} { |
||||||
|
upvar 1 $argvVar argsList |
||||||
|
upvar 1 $optVar option |
||||||
|
upvar 1 $valVar value |
||||||
|
|
||||||
|
# default settings for a normal return |
||||||
|
set value "" |
||||||
|
set option "" |
||||||
|
set result 0 |
||||||
|
|
||||||
|
# check if we're past the end of the args list |
||||||
|
if {[llength $argsList] != 0} { |
||||||
|
|
||||||
|
# if we got -- or an option that doesn't begin with -, return (skipping |
||||||
|
# the --). otherwise process the option arg. |
||||||
|
switch -glob -- [set arg [lindex $argsList 0]] { |
||||||
|
"--" { |
||||||
|
set argsList [lrange $argsList 1 end] |
||||||
|
} |
||||||
|
"--*" - |
||||||
|
"-*" { |
||||||
|
set option [string range $arg 1 end] |
||||||
|
if {[string equal [string range $option 0 0] "-"]} { |
||||||
|
set option [string range $arg 2 end] |
||||||
|
} |
||||||
|
|
||||||
|
# support for format: [-]-option=value |
||||||
|
set idx [string first "=" $option 1] |
||||||
|
if {$idx != -1} { |
||||||
|
set _val [string range $option [expr {$idx+1}] end] |
||||||
|
set option [string range $option 0 [expr {$idx-1}]] |
||||||
|
} |
||||||
|
|
||||||
|
if {[lsearch -exact $optstring $option] != -1} { |
||||||
|
# Booleans are set to 1 when present |
||||||
|
set value 1 |
||||||
|
set result 1 |
||||||
|
set argsList [lrange $argsList 1 end] |
||||||
|
} elseif {[lsearch -exact $optstring "$option.arg"] != -1} { |
||||||
|
set result 1 |
||||||
|
set argsList [lrange $argsList 1 end] |
||||||
|
|
||||||
|
if {[info exists _val]} { |
||||||
|
set value $_val |
||||||
|
} elseif {[llength $argsList]} { |
||||||
|
set value [lindex $argsList 0] |
||||||
|
set argsList [lrange $argsList 1 end] |
||||||
|
} else { |
||||||
|
set value "Option \"$option\" requires an argument" |
||||||
|
set result -2 |
||||||
|
} |
||||||
|
} else { |
||||||
|
# Unknown option. |
||||||
|
set value "Illegal option \"-$option\"" |
||||||
|
set result -1 |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
# Skip ahead |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
# ::cmdline::getoptions -- |
||||||
|
# |
||||||
|
# Process a set of command line options, filling in defaults |
||||||
|
# for those not specified. This also generates an error message |
||||||
|
# that lists the allowed flags if an incorrect flag is specified. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# argvVar The name of the argument list, typically argv. |
||||||
|
# We remove all known options and their args from it. |
||||||
|
# In other words, after the call to this command the |
||||||
|
# referenced variable contains only the non-options, |
||||||
|
# and unknown options. |
||||||
|
# optlist A list-of-lists where each element specifies an option |
||||||
|
# in the form: |
||||||
|
# (where flag takes no argument) |
||||||
|
# flag comment |
||||||
|
# |
||||||
|
# (or where flag takes an argument) |
||||||
|
# flag default comment |
||||||
|
# |
||||||
|
# If flag ends in ".arg" then the value is taken from the |
||||||
|
# command line. Otherwise it is a boolean and appears in |
||||||
|
# the result if present on the command line. If flag ends |
||||||
|
# in ".secret", it will not be displayed in the usage. |
||||||
|
# usage Text to include in the usage display. Defaults to |
||||||
|
# "options:" |
||||||
|
# |
||||||
|
# Results |
||||||
|
# Name value pairs suitable for using with array set. |
||||||
|
# A modified `argvVar`. |
||||||
|
|
||||||
|
proc ::cmdline::getoptions {argvVar optlist {usage options:}} { |
||||||
|
upvar 1 $argvVar argv |
||||||
|
|
||||||
|
set opts [GetOptionDefaults $optlist result] |
||||||
|
|
||||||
|
set argc [llength $argv] |
||||||
|
while {[set err [getopt argv $opts opt arg]]} { |
||||||
|
if {$err < 0} { |
||||||
|
set result(?) "" |
||||||
|
break |
||||||
|
} |
||||||
|
set result($opt) $arg |
||||||
|
} |
||||||
|
if {[info exist result(?)] || [info exists result(help)]} { |
||||||
|
Error [usage $optlist $usage] USAGE |
||||||
|
} |
||||||
|
return [array get result] |
||||||
|
} |
||||||
|
|
||||||
|
# ::cmdline::getKnownOptions -- |
||||||
|
# |
||||||
|
# Process a set of command line options, filling in defaults |
||||||
|
# for those not specified. This ignores unknown flags, but generates |
||||||
|
# an error message that lists the correct usage if a known option |
||||||
|
# is used incorrectly. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# argvVar The name of the argument list, typically argv. This |
||||||
|
# We remove all known options and their args from it. |
||||||
|
# In other words, after the call to this command the |
||||||
|
# referenced variable contains only the non-options, |
||||||
|
# and unknown options. |
||||||
|
# optlist A list-of-lists where each element specifies an option |
||||||
|
# in the form: |
||||||
|
# flag default comment |
||||||
|
# If flag ends in ".arg" then the value is taken from the |
||||||
|
# command line. Otherwise it is a boolean and appears in |
||||||
|
# the result if present on the command line. If flag ends |
||||||
|
# in ".secret", it will not be displayed in the usage. |
||||||
|
# usage Text to include in the usage display. Defaults to |
||||||
|
# "options:" |
||||||
|
# |
||||||
|
# Results |
||||||
|
# Name value pairs suitable for using with array set. |
||||||
|
# A modified `argvVar`. |
||||||
|
|
||||||
|
proc ::cmdline::getKnownOptions {argvVar optlist {usage options:}} { |
||||||
|
upvar 1 $argvVar argv |
||||||
|
|
||||||
|
set opts [GetOptionDefaults $optlist result] |
||||||
|
|
||||||
|
# As we encounter them, keep the unknown options and their |
||||||
|
# arguments in this list. Before we return from this procedure, |
||||||
|
# we'll prepend these args to the argList so that the application |
||||||
|
# doesn't lose them. |
||||||
|
|
||||||
|
set unknownOptions [list] |
||||||
|
|
||||||
|
set argc [llength $argv] |
||||||
|
while {[set err [getKnownOpt argv $opts opt arg]]} { |
||||||
|
if {$err == -1} { |
||||||
|
# Unknown option. |
||||||
|
|
||||||
|
# Skip over any non-option items that follow it. |
||||||
|
# For now, add them to the list of unknownOptions. |
||||||
|
lappend unknownOptions [lindex $argv 0] |
||||||
|
set argv [lrange $argv 1 end] |
||||||
|
while {([llength $argv] != 0) \ |
||||||
|
&& ![string match "-*" [lindex $argv 0]]} { |
||||||
|
lappend unknownOptions [lindex $argv 0] |
||||||
|
set argv [lrange $argv 1 end] |
||||||
|
} |
||||||
|
} elseif {$err == -2} { |
||||||
|
set result(?) "" |
||||||
|
break |
||||||
|
} else { |
||||||
|
set result($opt) $arg |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Before returning, prepend the any unknown args back onto the |
||||||
|
# argList so that the application doesn't lose them. |
||||||
|
set argv [concat $unknownOptions $argv] |
||||||
|
|
||||||
|
if {[info exist result(?)] || [info exists result(help)]} { |
||||||
|
Error [usage $optlist $usage] USAGE |
||||||
|
} |
||||||
|
return [array get result] |
||||||
|
} |
||||||
|
|
||||||
|
# ::cmdline::GetOptionDefaults -- |
||||||
|
# |
||||||
|
# This internal procedure processes the option list (that was passed to |
||||||
|
# the getopt or getKnownOpt procedure). The defaultArray gets an index |
||||||
|
# for each option in the option list, the value of which is the option's |
||||||
|
# default value. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# optlist A list-of-lists where each element specifies an option |
||||||
|
# in the form: |
||||||
|
# flag default comment |
||||||
|
# If flag ends in ".arg" then the value is taken from the |
||||||
|
# command line. Otherwise it is a boolean and appears in |
||||||
|
# the result if present on the command line. If flag ends |
||||||
|
# in ".secret", it will not be displayed in the usage. |
||||||
|
# defaultArrayVar The name of the array in which to put argument defaults. |
||||||
|
# |
||||||
|
# Results |
||||||
|
# Name value pairs suitable for using with array set. |
||||||
|
|
||||||
|
proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} { |
||||||
|
upvar 1 $defaultArrayVar result |
||||||
|
|
||||||
|
set opts {? help} |
||||||
|
foreach opt $optlist { |
||||||
|
set name [lindex $opt 0] |
||||||
|
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||||
|
# Need to hide this from the usage display and getopt |
||||||
|
} |
||||||
|
lappend opts $name |
||||||
|
if {[regsub -- {\.arg$} $name {} name] == 1} { |
||||||
|
|
||||||
|
# Set defaults for those that take values. |
||||||
|
|
||||||
|
set default [lindex $opt 1] |
||||||
|
set result($name) $default |
||||||
|
} else { |
||||||
|
# The default for booleans is false |
||||||
|
set result($name) 0 |
||||||
|
} |
||||||
|
} |
||||||
|
return $opts |
||||||
|
} |
||||||
|
|
||||||
|
# ::cmdline::usage -- |
||||||
|
# |
||||||
|
# Generate an error message that lists the allowed flags. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# optlist As for cmdline::getoptions |
||||||
|
# usage Text to include in the usage display. Defaults to |
||||||
|
# "options:" |
||||||
|
# |
||||||
|
# Results |
||||||
|
# A formatted usage message |
||||||
|
|
||||||
|
proc ::cmdline::usage {optlist {usage {options:}}} { |
||||||
|
set str "[getArgv0] $usage\n" |
||||||
|
set longest 20 |
||||||
|
set lines {} |
||||||
|
foreach opt [concat $optlist \ |
||||||
|
{{- "Forcibly stop option processing"} {help "Print this message"} {? "Print this message"}}] { |
||||||
|
set name "-[lindex $opt 0]" |
||||||
|
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||||
|
# Hidden option |
||||||
|
continue |
||||||
|
} |
||||||
|
if {[regsub -- {\.arg$} $name {} name] == 1} { |
||||||
|
append name " value" |
||||||
|
set desc "[lindex $opt 2] <[lindex $opt 1]>" |
||||||
|
} else { |
||||||
|
set desc "[lindex $opt 1]" |
||||||
|
} |
||||||
|
set n [string length $name] |
||||||
|
if {$n > $longest} { set longest $n } |
||||||
|
# max not available before 8.5 - set longest [expr {max($longest, )}] |
||||||
|
lappend lines $name $desc |
||||||
|
} |
||||||
|
foreach {name desc} $lines { |
||||||
|
append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" |
||||||
|
} |
||||||
|
|
||||||
|
return $str |
||||||
|
} |
||||||
|
|
||||||
|
# ::cmdline::getfiles -- |
||||||
|
# |
||||||
|
# Given a list of file arguments from the command line, compute |
||||||
|
# the set of valid files. On windows, file globbing is performed |
||||||
|
# on each argument. On Unix, only file existence is tested. If |
||||||
|
# a file argument produces no valid files, a warning is optionally |
||||||
|
# generated. |
||||||
|
# |
||||||
|
# This code also uses the full path for each file. If not |
||||||
|
# given it prepends [pwd] to the filename. This ensures that |
||||||
|
# these files will never conflict with files in our zip file. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# patterns The file patterns specified by the user. |
||||||
|
# quiet If this flag is set, no warnings will be generated. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# Returns the list of files that match the input patterns. |
||||||
|
|
||||||
|
proc ::cmdline::getfiles {patterns quiet} { |
||||||
|
set result {} |
||||||
|
if {$::tcl_platform(platform) == "windows"} { |
||||||
|
foreach pattern $patterns { |
||||||
|
set pat [file join $pattern] |
||||||
|
set files [glob -nocomplain -- $pat] |
||||||
|
if {$files == {}} { |
||||||
|
if {! $quiet} { |
||||||
|
puts stdout "warning: no files match \"$pattern\"" |
||||||
|
} |
||||||
|
} else { |
||||||
|
foreach file $files { |
||||||
|
lappend result $file |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
set result $patterns |
||||||
|
} |
||||||
|
set files {} |
||||||
|
foreach file $result { |
||||||
|
# Make file an absolute path so that we will never conflict |
||||||
|
# with files that might be contained in our zip file. |
||||||
|
set fullPath [file join [pwd] $file] |
||||||
|
|
||||||
|
if {[file isfile $fullPath]} { |
||||||
|
lappend files $fullPath |
||||||
|
} elseif {! $quiet} { |
||||||
|
puts stdout "warning: no files match \"$file\"" |
||||||
|
} |
||||||
|
} |
||||||
|
return $files |
||||||
|
} |
||||||
|
|
||||||
|
# ::cmdline::getArgv0 -- |
||||||
|
# |
||||||
|
# This command returns the "sanitized" version of argv0. It will strip |
||||||
|
# off the leading path and remove the ".bin" extensions that our apps |
||||||
|
# use because they must be wrapped by a shell script. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# None. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The application name that can be used in error messages. |
||||||
|
|
||||||
|
proc ::cmdline::getArgv0 {} { |
||||||
|
global argv0 |
||||||
|
|
||||||
|
set name [file tail $argv0] |
||||||
|
return [file rootname $name] |
||||||
|
} |
||||||
|
|
||||||
|
## |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## |
||||||
|
# Now the typed versions of the above commands. |
||||||
|
## |
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## |
||||||
|
|
||||||
|
# typedCmdline.tcl -- |
||||||
|
# |
||||||
|
# This package provides a utility for parsing typed command |
||||||
|
# line arguments that may be processed by various applications. |
||||||
|
# |
||||||
|
# Copyright (c) 2000 by Ross Palmer Mohn. |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: cmdline.tcl,v 1.28 2011/02/23 17:41:52 andreas_kupries Exp $ |
||||||
|
|
||||||
|
namespace eval ::cmdline { |
||||||
|
namespace export typedGetopt typedGetoptions typedUsage |
||||||
|
|
||||||
|
# variable cmdline::charclasses -- |
||||||
|
# |
||||||
|
# Create regexp list of allowable character classes |
||||||
|
# from "string is" error message. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# String of character class names separated by "|" characters. |
||||||
|
|
||||||
|
variable charclasses |
||||||
|
#checker exclude badKey |
||||||
|
catch {string is . .} charclasses |
||||||
|
variable dummy |
||||||
|
regexp -- {must be (.+)$} $charclasses dummy charclasses |
||||||
|
regsub -all -- {, (or )?} $charclasses {|} charclasses |
||||||
|
unset dummy |
||||||
|
} |
||||||
|
|
||||||
|
# ::cmdline::typedGetopt -- |
||||||
|
# |
||||||
|
# The cmdline::typedGetopt works in a fashion like the standard |
||||||
|
# C based getopt function. Given an option string and a |
||||||
|
# pointer to a list of args this command will process the |
||||||
|
# first argument and return info on how to proceed. In addition, |
||||||
|
# you may specify a type for the argument to each option. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# argvVar Name of the argv list that you want to process. |
||||||
|
# If options are found, the arg list is modified |
||||||
|
# and the processed arguments are removed from the |
||||||
|
# start of the list. |
||||||
|
# |
||||||
|
# optstring A list of command options that the application |
||||||
|
# will accept. If the option ends in ".xxx", where |
||||||
|
# xxx is any valid character class to the tcl |
||||||
|
# command "string is", then typedGetopt routine will |
||||||
|
# use the next argument as a typed argument to the |
||||||
|
# option. The argument must match the specified |
||||||
|
# character classes (e.g. integer, double, boolean, |
||||||
|
# xdigit, etc.). Alternatively, you may specify |
||||||
|
# ".arg" for an untyped argument. |
||||||
|
# |
||||||
|
# optVar Upon success, the variable pointed to by optVar |
||||||
|
# contains the option that was found (without the |
||||||
|
# leading '-' and without the .xxx extension). If |
||||||
|
# typedGetopt fails the variable is set to the empty |
||||||
|
# string. SOMETIMES! Different for each -value! |
||||||
|
# |
||||||
|
# argVar Upon success, the variable pointed to by argVar |
||||||
|
# contains the argument for the specified option. |
||||||
|
# If typedGetopt fails, the variable is filled with |
||||||
|
# an error message. |
||||||
|
# |
||||||
|
# Argument type syntax: |
||||||
|
# Option that takes no argument. |
||||||
|
# foo |
||||||
|
# |
||||||
|
# Option that takes a typeless argument. |
||||||
|
# foo.arg |
||||||
|
# |
||||||
|
# Option that takes a typed argument. Allowable types are all |
||||||
|
# valid character classes to the tcl command "string is". |
||||||
|
# Currently must be one of alnum, alpha, ascii, control, |
||||||
|
# boolean, digit, double, false, graph, integer, lower, print, |
||||||
|
# punct, space, true, upper, wordchar, or xdigit. |
||||||
|
# foo.double |
||||||
|
# |
||||||
|
# Option that takes an argument from a list. |
||||||
|
# foo.(bar|blat) |
||||||
|
# |
||||||
|
# Argument quantifier syntax: |
||||||
|
# Option that takes an optional argument. |
||||||
|
# foo.arg? |
||||||
|
# |
||||||
|
# Option that takes a list of arguments terminated by "--". |
||||||
|
# foo.arg+ |
||||||
|
# |
||||||
|
# Option that takes an optional list of arguments terminated by "--". |
||||||
|
# foo.arg* |
||||||
|
# |
||||||
|
# Argument quantifiers work on all argument types, so, for |
||||||
|
# example, the following is a valid option specification. |
||||||
|
# foo.(bar|blat|blah)? |
||||||
|
# |
||||||
|
# Argument syntax miscellany: |
||||||
|
# Options may be specified on the command line using a unique, |
||||||
|
# shortened version of the option name. Given that program foo |
||||||
|
# has an option list of {bar.alpha blah.arg blat.double}, |
||||||
|
# "foo -b fob" returns an error, but "foo -ba fob" |
||||||
|
# successfully returns {bar fob} |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The typedGetopt function returns one of the following: |
||||||
|
# 1 a valid option was found |
||||||
|
# 0 no more options found to process |
||||||
|
# -1 invalid option |
||||||
|
# -2 missing argument to a valid option |
||||||
|
# -3 argument to a valid option does not match type |
||||||
|
# |
||||||
|
# Known Bugs: |
||||||
|
# When using options which include special glob characters, |
||||||
|
# you must use the exact option. Abbreviating it can cause |
||||||
|
# an error in the "cmdline::prefixSearch" procedure. |
||||||
|
|
||||||
|
proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} { |
||||||
|
variable charclasses |
||||||
|
|
||||||
|
upvar $argvVar argsList |
||||||
|
|
||||||
|
upvar $optVar retvar |
||||||
|
upvar $argVar optarg |
||||||
|
|
||||||
|
# default settings for a normal return |
||||||
|
set optarg "" |
||||||
|
set retvar "" |
||||||
|
set retval 0 |
||||||
|
|
||||||
|
# check if we're past the end of the args list |
||||||
|
if {[llength $argsList] != 0} { |
||||||
|
|
||||||
|
# if we got -- or an option that doesn't begin with -, return (skipping |
||||||
|
# the --). otherwise process the option arg. |
||||||
|
switch -glob -- [set arg [lindex $argsList 0]] { |
||||||
|
"--" { |
||||||
|
set argsList [lrange $argsList 1 end] |
||||||
|
} |
||||||
|
|
||||||
|
"-*" { |
||||||
|
# Create list of options without their argument extensions |
||||||
|
|
||||||
|
set optstr "" |
||||||
|
foreach str $optstring { |
||||||
|
lappend optstr [file rootname $str] |
||||||
|
} |
||||||
|
|
||||||
|
set _opt [string range $arg 1 end] |
||||||
|
|
||||||
|
set i [prefixSearch $optstr [file rootname $_opt]] |
||||||
|
if {$i != -1} { |
||||||
|
set opt [lindex $optstring $i] |
||||||
|
|
||||||
|
set quantifier "none" |
||||||
|
if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} { |
||||||
|
set opt [string range $opt 0 end-1] |
||||||
|
} |
||||||
|
|
||||||
|
if {[string first . $opt] == -1} { |
||||||
|
set retval 1 |
||||||
|
set retvar $opt |
||||||
|
set argsList [lrange $argsList 1 end] |
||||||
|
|
||||||
|
} elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass] |
||||||
|
|| [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} { |
||||||
|
if {[string equal arg $charclass]} { |
||||||
|
set type arg |
||||||
|
} elseif {[regexp -- "^($charclasses)\$" $charclass]} { |
||||||
|
set type class |
||||||
|
} else { |
||||||
|
set type oneof |
||||||
|
} |
||||||
|
|
||||||
|
set argsList [lrange $argsList 1 end] |
||||||
|
set opt [file rootname $opt] |
||||||
|
|
||||||
|
while {1} { |
||||||
|
if {[llength $argsList] == 0 |
||||||
|
|| [string equal "--" [lindex $argsList 0]]} { |
||||||
|
if {[string equal "--" [lindex $argsList 0]]} { |
||||||
|
set argsList [lrange $argsList 1 end] |
||||||
|
} |
||||||
|
|
||||||
|
set oneof "" |
||||||
|
if {$type == "arg"} { |
||||||
|
set charclass an |
||||||
|
} elseif {$type == "oneof"} { |
||||||
|
set oneof ", one of $charclass" |
||||||
|
set charclass an |
||||||
|
} |
||||||
|
|
||||||
|
if {$quantifier == "?"} { |
||||||
|
set retval 1 |
||||||
|
set retvar $opt |
||||||
|
set optarg "" |
||||||
|
} elseif {$quantifier == "+"} { |
||||||
|
set retvar $opt |
||||||
|
if {[llength $optarg] < 1} { |
||||||
|
set retval -2 |
||||||
|
set optarg "Option requires at least one $charclass argument$oneof -- $opt" |
||||||
|
} else { |
||||||
|
set retval 1 |
||||||
|
} |
||||||
|
} elseif {$quantifier == "*"} { |
||||||
|
set retval 1 |
||||||
|
set retvar $opt |
||||||
|
} else { |
||||||
|
set optarg "Option requires $charclass argument$oneof -- $opt" |
||||||
|
set retvar $opt |
||||||
|
set retval -2 |
||||||
|
} |
||||||
|
set quantifier "" |
||||||
|
} elseif {($type == "arg") |
||||||
|
|| (($type == "oneof") |
||||||
|
&& [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1) |
||||||
|
|| (($type == "class") |
||||||
|
&& [string is $charclass [lindex $argsList 0]])} { |
||||||
|
set retval 1 |
||||||
|
set retvar $opt |
||||||
|
lappend optarg [lindex $argsList 0] |
||||||
|
set argsList [lrange $argsList 1 end] |
||||||
|
} else { |
||||||
|
set oneof "" |
||||||
|
if {$type == "arg"} { |
||||||
|
set charclass an |
||||||
|
} elseif {$type == "oneof"} { |
||||||
|
set oneof ", one of $charclass" |
||||||
|
set charclass an |
||||||
|
} |
||||||
|
set optarg "Option requires $charclass argument$oneof -- $opt" |
||||||
|
set retvar $opt |
||||||
|
set retval -3 |
||||||
|
|
||||||
|
if {$quantifier == "?"} { |
||||||
|
set retval 1 |
||||||
|
set optarg "" |
||||||
|
} |
||||||
|
set quantifier "" |
||||||
|
} |
||||||
|
if {![regexp -- {[+*]} $quantifier]} { |
||||||
|
break; |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
Error \ |
||||||
|
"Illegal option type specification: must be one of $charclasses" \ |
||||||
|
BAD OPTION TYPE |
||||||
|
} |
||||||
|
} else { |
||||||
|
set optarg "Illegal option -- $_opt" |
||||||
|
set retvar $_opt |
||||||
|
set retval -1 |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
# Skip ahead |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return $retval |
||||||
|
} |
||||||
|
|
||||||
|
# ::cmdline::typedGetoptions -- |
||||||
|
# |
||||||
|
# Process a set of command line options, filling in defaults |
||||||
|
# for those not specified. This also generates an error message |
||||||
|
# that lists the allowed options if an incorrect option is |
||||||
|
# specified. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# argvVar The name of the argument list, typically argv |
||||||
|
# optlist A list-of-lists where each element specifies an option |
||||||
|
# in the form: |
||||||
|
# |
||||||
|
# option default comment |
||||||
|
# |
||||||
|
# Options formatting is as described for the optstring |
||||||
|
# argument of typedGetopt. Default is for optionally |
||||||
|
# specifying a default value. Comment is for optionally |
||||||
|
# specifying a comment for the usage display. The |
||||||
|
# options "--", "-help", and "-?" are automatically included |
||||||
|
# in optlist. |
||||||
|
# |
||||||
|
# Argument syntax miscellany: |
||||||
|
# Options formatting and syntax is as described in typedGetopt. |
||||||
|
# There are two additional suffixes that may be applied when |
||||||
|
# passing options to typedGetoptions. |
||||||
|
# |
||||||
|
# You may add ".multi" as a suffix to any option. For options |
||||||
|
# that take an argument, this means that the option may be used |
||||||
|
# more than once on the command line and that each additional |
||||||
|
# argument will be appended to a list, which is then returned |
||||||
|
# to the application. |
||||||
|
# foo.double.multi |
||||||
|
# |
||||||
|
# If a non-argument option is specified as ".multi", it is |
||||||
|
# toggled on and off for each time it is used on the command |
||||||
|
# line. |
||||||
|
# foo.multi |
||||||
|
# |
||||||
|
# If an option specification does not contain the ".multi" |
||||||
|
# suffix, it is not an error to use an option more than once. |
||||||
|
# In this case, the behavior for options with arguments is that |
||||||
|
# the last argument is the one that will be returned. For |
||||||
|
# options that do not take arguments, using them more than once |
||||||
|
# has no additional effect. |
||||||
|
# |
||||||
|
# Options may also be hidden from the usage display by |
||||||
|
# appending the suffix ".secret" to any option specification. |
||||||
|
# Please note that the ".secret" suffix must be the last suffix, |
||||||
|
# after any argument type specification and ".multi" suffix. |
||||||
|
# foo.xdigit.multi.secret |
||||||
|
# |
||||||
|
# Results |
||||||
|
# Name value pairs suitable for using with array set. |
||||||
|
|
||||||
|
proc ::cmdline::typedGetoptions {argvVar optlist {usage options:}} { |
||||||
|
variable charclasses |
||||||
|
|
||||||
|
upvar 1 $argvVar argv |
||||||
|
|
||||||
|
set opts {? help} |
||||||
|
foreach opt $optlist { |
||||||
|
set name [lindex $opt 0] |
||||||
|
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||||
|
# Remove this extension before passing to typedGetopt. |
||||||
|
} |
||||||
|
if {[regsub -- {\.multi$} $name {} name] == 1} { |
||||||
|
# Remove this extension before passing to typedGetopt. |
||||||
|
|
||||||
|
regsub -- {\..*$} $name {} temp |
||||||
|
set multi($temp) 1 |
||||||
|
} |
||||||
|
lappend opts $name |
||||||
|
if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} { |
||||||
|
# Set defaults for those that take values. |
||||||
|
# Booleans are set just by being present, or not |
||||||
|
|
||||||
|
set dflt [lindex $opt 1] |
||||||
|
if {$dflt != {}} { |
||||||
|
set defaults($name) $dflt |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set argc [llength $argv] |
||||||
|
while {[set err [typedGetopt argv $opts opt arg]]} { |
||||||
|
if {$err == 1} { |
||||||
|
if {[info exists result($opt)] |
||||||
|
&& [info exists multi($opt)]} { |
||||||
|
# Toggle boolean options or append new arguments |
||||||
|
|
||||||
|
if {$arg == ""} { |
||||||
|
unset result($opt) |
||||||
|
} else { |
||||||
|
set result($opt) "$result($opt) $arg" |
||||||
|
} |
||||||
|
} else { |
||||||
|
set result($opt) "$arg" |
||||||
|
} |
||||||
|
} elseif {($err == -1) || ($err == -3)} { |
||||||
|
Error [typedUsage $optlist $usage] USAGE |
||||||
|
} elseif {$err == -2 && ![info exists defaults($opt)]} { |
||||||
|
Error [typedUsage $optlist $usage] USAGE |
||||||
|
} |
||||||
|
} |
||||||
|
if {[info exists result(?)] || [info exists result(help)]} { |
||||||
|
Error [typedUsage $optlist $usage] USAGE |
||||||
|
} |
||||||
|
foreach {opt dflt} [array get defaults] { |
||||||
|
if {![info exists result($opt)]} { |
||||||
|
set result($opt) $dflt |
||||||
|
} |
||||||
|
} |
||||||
|
return [array get result] |
||||||
|
} |
||||||
|
|
||||||
|
# ::cmdline::typedUsage -- |
||||||
|
# |
||||||
|
# Generate an error message that lists the allowed flags, |
||||||
|
# type of argument taken (if any), default value (if any), |
||||||
|
# and an optional description. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# optlist As for cmdline::typedGetoptions |
||||||
|
# |
||||||
|
# Results |
||||||
|
# A formatted usage message |
||||||
|
|
||||||
|
proc ::cmdline::typedUsage {optlist {usage {options:}}} { |
||||||
|
variable charclasses |
||||||
|
|
||||||
|
set str "[getArgv0] $usage\n" |
||||||
|
set longest 20 |
||||||
|
set lines {} |
||||||
|
foreach opt [concat $optlist \ |
||||||
|
{{help "Print this message"} {? "Print this message"}}] { |
||||||
|
set name "-[lindex $opt 0]" |
||||||
|
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||||
|
# Hidden option |
||||||
|
continue |
||||||
|
} |
||||||
|
|
||||||
|
if {[regsub -- {\.multi$} $name {} name] == 1} { |
||||||
|
# Display something about multiple options |
||||||
|
} |
||||||
|
|
||||||
|
if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass] || |
||||||
|
[regexp -- {\.\(([^)]+)\)} $opt dummy charclass] |
||||||
|
} { |
||||||
|
regsub -- "\\..+\$" $name {} name |
||||||
|
append name " $charclass" |
||||||
|
set desc [lindex $opt 2] |
||||||
|
set default [lindex $opt 1] |
||||||
|
if {$default != ""} { |
||||||
|
append desc " <$default>" |
||||||
|
} |
||||||
|
} else { |
||||||
|
set desc [lindex $opt 1] |
||||||
|
} |
||||||
|
lappend accum $name $desc |
||||||
|
set n [string length $name] |
||||||
|
if {$n > $longest} { set longest $n } |
||||||
|
# max not available before 8.5 - set longest [expr {max($longest, [string length $name])}] |
||||||
|
} |
||||||
|
foreach {name desc} $accum { |
||||||
|
append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" |
||||||
|
} |
||||||
|
return $str |
||||||
|
} |
||||||
|
|
||||||
|
# ::cmdline::prefixSearch -- |
||||||
|
# |
||||||
|
# Search a Tcl list for a pattern; searches first for an exact match, |
||||||
|
# and if that fails, for a unique prefix that matches the pattern |
||||||
|
# (i.e, first "lsearch -exact", then "lsearch -glob $pattern*" |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# list list of words |
||||||
|
# pattern word to search for |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# Index of found word is returned. If no exact match or |
||||||
|
# unique short version is found then -1 is returned. |
||||||
|
|
||||||
|
proc ::cmdline::prefixSearch {list pattern} { |
||||||
|
# Check for an exact match |
||||||
|
|
||||||
|
if {[set pos [::lsearch -exact $list $pattern]] > -1} { |
||||||
|
return $pos |
||||||
|
} |
||||||
|
|
||||||
|
# Check for a unique short version |
||||||
|
|
||||||
|
set slist [lsort $list] |
||||||
|
if {[set pos [::lsearch -glob $slist $pattern*]] > -1} { |
||||||
|
# What if there is nothing for the check variable? |
||||||
|
|
||||||
|
set check [lindex $slist [expr {$pos + 1}]] |
||||||
|
if {[string first $pattern $check] != 0} { |
||||||
|
return [::lsearch -exact $list [lindex $slist $pos]] |
||||||
|
} |
||||||
|
} |
||||||
|
return -1 |
||||||
|
} |
||||||
|
# ::cmdline::Error -- |
||||||
|
# |
||||||
|
# Internal helper to throw errors with a proper error-code attached. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# message text of the error message to throw. |
||||||
|
# args additional parts of the error code to use, |
||||||
|
# with CMDLINE as basic prefix added by this command. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# An error is thrown, always. |
||||||
|
|
||||||
|
proc ::cmdline::Error {message args} { |
||||||
|
return -code error -errorcode [linsert $args 0 CMDLINE] $message |
||||||
|
} |
||||||
@ -0,0 +1,2 @@ |
|||||||
|
if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} |
||||||
|
package ifneeded cmdline 1.5.3 [list source [file join $dir cmdline.tcl]] |
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,2 @@ |
|||||||
|
if {![package vsatisfies [package provide Tcl] 8.5 9]} {return} |
||||||
|
package ifneeded comm 4.7.3 [list source [file join $dir comm.tcl]] |
||||||
@ -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 |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue