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. |
||||
|
||||
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