431 changed files with 325046 additions and 0 deletions
@ -0,0 +1,20 @@ |
|||||||
|
|
||||||
|
project_layout information |
||||||
|
========================== |
||||||
|
|
||||||
|
project layouts don't show as available unless referenced by an entry in a layout_ref folder within the src/decktemplates structure. |
||||||
|
|
||||||
|
This is because some layouts may be intended for use with child projects generated from 'deck project.new' - but not directly by this parent project. |
||||||
|
|
||||||
|
The structure of decktemplates and project_layouts is designed to avoid circular dependencies arising during creation of layouts for child projects - that may then need to in turn support the same layout if the child project creates projects. |
||||||
|
|
||||||
|
Layouts are not included in the resource files of modules for the same reason. (modules may need to be included in layouts) |
||||||
|
Instead they are pointed to via the decktemplates custom & vendor structure. |
||||||
|
|
||||||
|
-------- |
||||||
|
|
||||||
|
layouts within project_layouts/vendor should generally not be customised directly |
||||||
|
The vendor layouts should be created and updated by loading the appropriate vendor modules. |
||||||
|
These are plugin modules that are providers of the punk.projectlayout capability |
||||||
|
(see punk::cap module documentation and the project_layouts/vendor/punk/sample-0.1 layout) |
||||||
|
|
||||||
@ -0,0 +1,6 @@ |
|||||||
|
#!/bin/sh |
||||||
|
# -*- tcl -*- \ |
||||||
|
# 'build.tcl' name as required by kettle |
||||||
|
# Can be run directly - but also using `deck Kettle ...` or `deck KettleShell ...`\ |
||||||
|
exec ./kettle -f "$0" "${1+$@}" |
||||||
|
kettle doc |
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,200 @@ |
|||||||
|
# cksum.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||||
|
# |
||||||
|
# Provides a Tcl only implementation of the unix cksum(1) command. This is |
||||||
|
# similar to the sum(1) command but the algorithm is better defined and |
||||||
|
# standardized across multiple platforms by POSIX 1003.2/D11.2 |
||||||
|
# |
||||||
|
# This command has been verified against the cksum command from the GNU |
||||||
|
# textutils package version 2.0 |
||||||
|
# |
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# 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-; # tcl minimum version |
||||||
|
|
||||||
|
namespace eval ::crc { |
||||||
|
namespace export cksum |
||||||
|
|
||||||
|
variable cksum_tbl [list 0x0 \ |
||||||
|
0x04C11DB7 0x09823B6E 0x0D4326D9 0x130476DC 0x17C56B6B \ |
||||||
|
0x1A864DB2 0x1E475005 0x2608EDB8 0x22C9F00F 0x2F8AD6D6 \ |
||||||
|
0x2B4BCB61 0x350C9B64 0x31CD86D3 0x3C8EA00A 0x384FBDBD \ |
||||||
|
0x4C11DB70 0x48D0C6C7 0x4593E01E 0x4152FDA9 0x5F15ADAC \ |
||||||
|
0x5BD4B01B 0x569796C2 0x52568B75 0x6A1936C8 0x6ED82B7F \ |
||||||
|
0x639B0DA6 0x675A1011 0x791D4014 0x7DDC5DA3 0x709F7B7A \ |
||||||
|
0x745E66CD 0x9823B6E0 0x9CE2AB57 0x91A18D8E 0x95609039 \ |
||||||
|
0x8B27C03C 0x8FE6DD8B 0x82A5FB52 0x8664E6E5 0xBE2B5B58 \ |
||||||
|
0xBAEA46EF 0xB7A96036 0xB3687D81 0xAD2F2D84 0xA9EE3033 \ |
||||||
|
0xA4AD16EA 0xA06C0B5D 0xD4326D90 0xD0F37027 0xDDB056FE \ |
||||||
|
0xD9714B49 0xC7361B4C 0xC3F706FB 0xCEB42022 0xCA753D95 \ |
||||||
|
0xF23A8028 0xF6FB9D9F 0xFBB8BB46 0xFF79A6F1 0xE13EF6F4 \ |
||||||
|
0xE5FFEB43 0xE8BCCD9A 0xEC7DD02D 0x34867077 0x30476DC0 \ |
||||||
|
0x3D044B19 0x39C556AE 0x278206AB 0x23431B1C 0x2E003DC5 \ |
||||||
|
0x2AC12072 0x128E9DCF 0x164F8078 0x1B0CA6A1 0x1FCDBB16 \ |
||||||
|
0x018AEB13 0x054BF6A4 0x0808D07D 0x0CC9CDCA 0x7897AB07 \ |
||||||
|
0x7C56B6B0 0x71159069 0x75D48DDE 0x6B93DDDB 0x6F52C06C \ |
||||||
|
0x6211E6B5 0x66D0FB02 0x5E9F46BF 0x5A5E5B08 0x571D7DD1 \ |
||||||
|
0x53DC6066 0x4D9B3063 0x495A2DD4 0x44190B0D 0x40D816BA \ |
||||||
|
0xACA5C697 0xA864DB20 0xA527FDF9 0xA1E6E04E 0xBFA1B04B \ |
||||||
|
0xBB60ADFC 0xB6238B25 0xB2E29692 0x8AAD2B2F 0x8E6C3698 \ |
||||||
|
0x832F1041 0x87EE0DF6 0x99A95DF3 0x9D684044 0x902B669D \ |
||||||
|
0x94EA7B2A 0xE0B41DE7 0xE4750050 0xE9362689 0xEDF73B3E \ |
||||||
|
0xF3B06B3B 0xF771768C 0xFA325055 0xFEF34DE2 0xC6BCF05F \ |
||||||
|
0xC27DEDE8 0xCF3ECB31 0xCBFFD686 0xD5B88683 0xD1799B34 \ |
||||||
|
0xDC3ABDED 0xD8FBA05A 0x690CE0EE 0x6DCDFD59 0x608EDB80 \ |
||||||
|
0x644FC637 0x7A089632 0x7EC98B85 0x738AAD5C 0x774BB0EB \ |
||||||
|
0x4F040D56 0x4BC510E1 0x46863638 0x42472B8F 0x5C007B8A \ |
||||||
|
0x58C1663D 0x558240E4 0x51435D53 0x251D3B9E 0x21DC2629 \ |
||||||
|
0x2C9F00F0 0x285E1D47 0x36194D42 0x32D850F5 0x3F9B762C \ |
||||||
|
0x3B5A6B9B 0x0315D626 0x07D4CB91 0x0A97ED48 0x0E56F0FF \ |
||||||
|
0x1011A0FA 0x14D0BD4D 0x19939B94 0x1D528623 0xF12F560E \ |
||||||
|
0xF5EE4BB9 0xF8AD6D60 0xFC6C70D7 0xE22B20D2 0xE6EA3D65 \ |
||||||
|
0xEBA91BBC 0xEF68060B 0xD727BBB6 0xD3E6A601 0xDEA580D8 \ |
||||||
|
0xDA649D6F 0xC423CD6A 0xC0E2D0DD 0xCDA1F604 0xC960EBB3 \ |
||||||
|
0xBD3E8D7E 0xB9FF90C9 0xB4BCB610 0xB07DABA7 0xAE3AFBA2 \ |
||||||
|
0xAAFBE615 0xA7B8C0CC 0xA379DD7B 0x9B3660C6 0x9FF77D71 \ |
||||||
|
0x92B45BA8 0x9675461F 0x8832161A 0x8CF30BAD 0x81B02D74 \ |
||||||
|
0x857130C3 0x5D8A9099 0x594B8D2E 0x5408ABF7 0x50C9B640 \ |
||||||
|
0x4E8EE645 0x4A4FFBF2 0x470CDD2B 0x43CDC09C 0x7B827D21 \ |
||||||
|
0x7F436096 0x7200464F 0x76C15BF8 0x68860BFD 0x6C47164A \ |
||||||
|
0x61043093 0x65C52D24 0x119B4BE9 0x155A565E 0x18197087 \ |
||||||
|
0x1CD86D30 0x029F3D35 0x065E2082 0x0B1D065B 0x0FDC1BEC \ |
||||||
|
0x3793A651 0x3352BBE6 0x3E119D3F 0x3AD08088 0x2497D08D \ |
||||||
|
0x2056CD3A 0x2D15EBE3 0x29D4F654 0xC5A92679 0xC1683BCE \ |
||||||
|
0xCC2B1D17 0xC8EA00A0 0xD6AD50A5 0xD26C4D12 0xDF2F6BCB \ |
||||||
|
0xDBEE767C 0xE3A1CBC1 0xE760D676 0xEA23F0AF 0xEEE2ED18 \ |
||||||
|
0xF0A5BD1D 0xF464A0AA 0xF9278673 0xFDE69BC4 0x89B8FD09 \ |
||||||
|
0x8D79E0BE 0x803AC667 0x84FBDBD0 0x9ABC8BD5 0x9E7D9662 \ |
||||||
|
0x933EB0BB 0x97FFAD0C 0xAFB010B1 0xAB710D06 0xA6322BDF \ |
||||||
|
0xA2F33668 0xBCB4666D 0xB8757BDA 0xB5365D03 0xB1F740B4 ] |
||||||
|
|
||||||
|
variable uid |
||||||
|
if {![info exists uid]} {set uid 0} |
||||||
|
} |
||||||
|
|
||||||
|
# crc::CksumInit -- |
||||||
|
# |
||||||
|
# Create and initialize a cksum context. This is cleaned up when we |
||||||
|
# call CksumFinal to obtain the result. |
||||||
|
# |
||||||
|
proc ::crc::CksumInit {} { |
||||||
|
variable uid |
||||||
|
set token [namespace current]::[incr uid] |
||||||
|
upvar #0 $token state |
||||||
|
array set state {t 0 l 0} |
||||||
|
return $token |
||||||
|
} |
||||||
|
|
||||||
|
proc ::crc::CksumUpdate {token data} { |
||||||
|
variable cksum_tbl |
||||||
|
upvar #0 $token state |
||||||
|
set t $state(t) |
||||||
|
binary scan $data c* r |
||||||
|
foreach {n} $r { |
||||||
|
set index [expr { (($t >> 24) ^ ($n & 0xFF)) & 0xFF }] |
||||||
|
# Since the introduction of built-in bigInt support with Tcl |
||||||
|
# 8.5, bit-shifting $t to the left no longer overflows, |
||||||
|
# keeping it 32 bits long. The value grows bigger and bigger |
||||||
|
# instead - a severe hit on performance. For this reason we |
||||||
|
# do a bitwise AND against 0xFFFFFFFF at each step to keep the |
||||||
|
# value within limits. |
||||||
|
set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] |
||||||
|
incr state(l) |
||||||
|
} |
||||||
|
set state(t) $t |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::crc::CksumFinal {token} { |
||||||
|
variable cksum_tbl |
||||||
|
upvar #0 $token state |
||||||
|
set t $state(t) |
||||||
|
for {set i $state(l)} {$i > 0} {set i [expr {$i>>8}]} { |
||||||
|
set index [expr {(($t >> 24) ^ $i) & 0xFF}] |
||||||
|
set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] |
||||||
|
} |
||||||
|
unset state |
||||||
|
return [expr {~$t & 0xFFFFFFFF}] |
||||||
|
} |
||||||
|
|
||||||
|
# crc::Pop -- |
||||||
|
# |
||||||
|
# Pop the nth element off a list. Used in options processing. |
||||||
|
# |
||||||
|
proc ::crc::Pop {varname {nth 0}} { |
||||||
|
upvar $varname args |
||||||
|
set r [lindex $args $nth] |
||||||
|
set args [lreplace $args $nth $nth] |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# Description: |
||||||
|
# Provide a Tcl equivalent of the unix cksum(1) command. |
||||||
|
# Options: |
||||||
|
# -filename name - return a checksum for the specified file. |
||||||
|
# -format string - return the checksum using this format string. |
||||||
|
# -chunksize size - set the chunking read size |
||||||
|
# |
||||||
|
proc ::crc::cksum {args} { |
||||||
|
array set opts [list -filename {} -channel {} -chunksize 4096 \ |
||||||
|
-format %u -command {}] |
||||||
|
while {[string match -* [set option [lindex $args 0]]]} { |
||||||
|
switch -glob -- $option { |
||||||
|
-file* { set opts(-filename) [Pop args 1] } |
||||||
|
-chan* { set opts(-channel) [Pop args 1] } |
||||||
|
-chunk* { set opts(-chunksize) [Pop args 1] } |
||||||
|
-for* { set opts(-format) [Pop args 1] } |
||||||
|
-command { set opts(-command) [Pop args 1] } |
||||||
|
default { |
||||||
|
if {[llength $args] == 1} { break } |
||||||
|
if {[string compare $option "--"] == 0} { Pop args ; break } |
||||||
|
set err [join [lsort [array names opts -*]] ", "] |
||||||
|
return -code error "bad option \"option\": must be $err" |
||||||
|
} |
||||||
|
} |
||||||
|
Pop args |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-filename) != {}} { |
||||||
|
set opts(-channel) [open $opts(-filename) r] |
||||||
|
fconfigure $opts(-channel) -translation binary |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-channel) == {}} { |
||||||
|
|
||||||
|
if {[llength $args] != 1} { |
||||||
|
return -code error "wrong # args: should be\ |
||||||
|
cksum ?-format string?\ |
||||||
|
-channel chan | -filename file | string" |
||||||
|
} |
||||||
|
set tok [CksumInit] |
||||||
|
CksumUpdate $tok [lindex $args 0] |
||||||
|
set r [CksumFinal $tok] |
||||||
|
|
||||||
|
} else { |
||||||
|
|
||||||
|
set tok [CksumInit] |
||||||
|
while {![eof $opts(-channel)]} { |
||||||
|
CksumUpdate $tok [read $opts(-channel) $opts(-chunksize)] |
||||||
|
} |
||||||
|
set r [CksumFinal $tok] |
||||||
|
|
||||||
|
if {$opts(-filename) != {}} { |
||||||
|
close $opts(-channel) |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return [format $opts(-format) $r] |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
package provide cksum 1.1.4 |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# Local variables: |
||||||
|
# mode: tcl |
||||||
|
# indent-tabs-mode: nil |
||||||
|
# End: |
||||||
@ -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- |
||||||
|
package provide cmdline 1.5.2 |
||||||
|
|
||||||
|
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,145 @@ |
|||||||
|
# dictutils.tcl -- |
||||||
|
# |
||||||
|
# Various dictionary utilities. |
||||||
|
# |
||||||
|
# Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk). |
||||||
|
# |
||||||
|
# License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style). |
||||||
|
# |
||||||
|
|
||||||
|
#2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-" |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package provide dictutils 0.2.1 |
||||||
|
|
||||||
|
namespace eval dictutils { |
||||||
|
namespace export equal apply capture witharray nlappend |
||||||
|
namespace ensemble create |
||||||
|
|
||||||
|
# dictutils witharray dictVar arrayVar script -- |
||||||
|
# |
||||||
|
# Unpacks the elements of the dictionary in dictVar into the array |
||||||
|
# variable arrayVar and then evaluates the script. If the script |
||||||
|
# completes with an ok, return or continue status, then the result is copied |
||||||
|
# back into the dictionary variable, otherwise it is discarded. A |
||||||
|
# [break] can be used to explicitly abort the transaction. |
||||||
|
# |
||||||
|
proc witharray {dictVar arrayVar script} { |
||||||
|
upvar 1 $dictVar dict $arrayVar array |
||||||
|
array set array $dict |
||||||
|
try { uplevel 1 $script |
||||||
|
} on break {} { # Discard the result |
||||||
|
} on continue result - on ok result { |
||||||
|
set dict [array get array] ;# commit changes |
||||||
|
return $result |
||||||
|
} on return {result opts} { |
||||||
|
set dict [array get array] ;# commit changes |
||||||
|
dict incr opts -level ;# remove this proc from level |
||||||
|
return -options $opts $result |
||||||
|
} |
||||||
|
# All other cases will discard the changes and propagage |
||||||
|
} |
||||||
|
|
||||||
|
# dictutils equal equalp d1 d2 -- |
||||||
|
# |
||||||
|
# Compare two dictionaries for equality. Two dictionaries are equal |
||||||
|
# if they (a) have the same keys, (b) the corresponding values for |
||||||
|
# each key in the two dictionaries are equal when compared using the |
||||||
|
# equality predicate, equalp (passed as an argument). The equality |
||||||
|
# predicate is invoked with the key and the two values from each |
||||||
|
# dictionary as arguments. |
||||||
|
# |
||||||
|
proc equal {equalp d1 d2} { |
||||||
|
if {[dict size $d1] != [dict size $d2]} { return 0 } |
||||||
|
dict for {k v} $d1 { |
||||||
|
if {![dict exists $d2 $k]} { return 0 } |
||||||
|
if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 } |
||||||
|
} |
||||||
|
return 1 |
||||||
|
} |
||||||
|
|
||||||
|
# apply dictVar lambdaExpr ?arg1 arg2 ...? -- |
||||||
|
# |
||||||
|
# A combination of *dict with* and *apply*, this procedure creates a |
||||||
|
# new procedure scope populated with the values in the dictionary |
||||||
|
# variable. It then applies the lambdaTerm (anonymous procedure) in |
||||||
|
# this new scope. If the procedure completes normally, then any |
||||||
|
# changes made to variables in the dictionary are reflected back to |
||||||
|
# the dictionary variable, otherwise they are ignored. This provides |
||||||
|
# a transaction-style semantics whereby atomic updates to a |
||||||
|
# dictionary can be performed. This procedure can also be useful for |
||||||
|
# implementing a variety of control constructs, such as mutable |
||||||
|
# closures. |
||||||
|
# |
||||||
|
proc apply {dictVar lambdaExpr args} { |
||||||
|
upvar 1 $dictVar dict |
||||||
|
set env $dict ;# copy |
||||||
|
lassign $lambdaExpr params body ns |
||||||
|
if {$ns eq ""} { set ns "::" } |
||||||
|
set body [format { |
||||||
|
upvar 1 env __env__ |
||||||
|
dict with __env__ %s |
||||||
|
} [list $body]] |
||||||
|
set lambdaExpr [list $params $body $ns] |
||||||
|
set rc [catch { ::apply $lambdaExpr {*}$args } ret opts] |
||||||
|
if {$rc == 0} { |
||||||
|
# Copy back any updates |
||||||
|
set dict $env |
||||||
|
} |
||||||
|
return -options $opts $ret |
||||||
|
} |
||||||
|
|
||||||
|
# capture ?level? ?exclude? ?include? -- |
||||||
|
# |
||||||
|
# Captures a snapshot of the current (scalar) variable bindings at |
||||||
|
# $level on the stack into a dictionary environment. This dictionary |
||||||
|
# can later be used with *dictutils apply* to partially restore the |
||||||
|
# scope, creating a first approximation of closures. The *level* |
||||||
|
# argument should be of the forms accepted by *uplevel* and |
||||||
|
# designates which level to capture. It defaults to 1 as in uplevel. |
||||||
|
# The *exclude* argument specifies an optional list of literal |
||||||
|
# variable names to avoid when performing the capture. No variables |
||||||
|
# matching any item in this list will be captured. The *include* |
||||||
|
# argument can be used to specify a list of glob patterns of |
||||||
|
# variables to capture. Only variables matching one of these |
||||||
|
# patterns are captured. The default is a single pattern "*", for |
||||||
|
# capturing all visible variables (as determined by *info vars*). |
||||||
|
# |
||||||
|
proc capture {{level 1} {exclude {}} {include {*}}} { |
||||||
|
if {[string is integer $level]} { incr level } |
||||||
|
set env [dict create] |
||||||
|
foreach pattern $include { |
||||||
|
foreach name [uplevel $level [list info vars $pattern]] { |
||||||
|
if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue } |
||||||
|
upvar $level $name value |
||||||
|
catch { dict set env $name $value } ;# no arrays |
||||||
|
} |
||||||
|
} |
||||||
|
return $env |
||||||
|
} |
||||||
|
|
||||||
|
# nlappend dictVar keyList ?value ...? |
||||||
|
# |
||||||
|
# Append zero or more elements to the list value stored in the given |
||||||
|
# dictionary at the path of keys specified in $keyList. If $keyList |
||||||
|
# specifies a non-existent path of keys, nlappend will behave as if |
||||||
|
# the path mapped to an empty list. |
||||||
|
# |
||||||
|
proc nlappend {dictvar keylist args} { |
||||||
|
upvar 1 $dictvar dict |
||||||
|
if {[info exists dict] && [dict exists $dict {*}$keylist]} { |
||||||
|
set list [dict get $dict {*}$keylist] |
||||||
|
} |
||||||
|
lappend list {*}$args |
||||||
|
dict set dict {*}$keylist $list |
||||||
|
} |
||||||
|
|
||||||
|
# invoke cmd args... -- |
||||||
|
# |
||||||
|
# Helper procedure to invoke a callback command with arguments at |
||||||
|
# the global scope. The helper ensures that proper quotation is |
||||||
|
# used. The command is expected to be a list, e.g. {string equal}. |
||||||
|
# |
||||||
|
proc invoke {cmd args} { uplevel #0 $cmd $args } |
||||||
|
|
||||||
|
} |
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,739 @@ |
|||||||
|
# md5.tcl - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||||
|
# |
||||||
|
# MD5 defined by RFC 1321, "The MD5 Message-Digest Algorithm" |
||||||
|
# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication" |
||||||
|
# |
||||||
|
# This is an implementation of MD5 based upon the example code given in |
||||||
|
# RFC 1321 and upon the tcllib MD4 implementation and taking some ideas |
||||||
|
# from the earlier tcllib md5 version by Don Libes. |
||||||
|
# |
||||||
|
# This implementation permits incremental updating of the hash and |
||||||
|
# provides support for external compiled implementations either using |
||||||
|
# critcl (md5c) or Trf. |
||||||
|
# |
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
package require Tcl 8.2; # tcl minimum version |
||||||
|
|
||||||
|
namespace eval ::md5 { |
||||||
|
variable accel |
||||||
|
array set accel {critcl 0 cryptkit 0 trf 0} |
||||||
|
|
||||||
|
namespace export md5 hmac MD5Init MD5Update MD5Final |
||||||
|
|
||||||
|
variable uid |
||||||
|
if {![info exists uid]} { |
||||||
|
set uid 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# MD5Init -- |
||||||
|
# |
||||||
|
# Create and initialize an MD5 state variable. This will be |
||||||
|
# cleaned up when we call MD5Final |
||||||
|
# |
||||||
|
proc ::md5::MD5Init {} { |
||||||
|
variable accel |
||||||
|
variable uid |
||||||
|
set token [namespace current]::[incr uid] |
||||||
|
upvar #0 $token state |
||||||
|
|
||||||
|
# RFC1321:3.3 - Initialize MD5 state structure |
||||||
|
array set state \ |
||||||
|
[list \ |
||||||
|
A [expr {0x67452301}] \ |
||||||
|
B [expr {0xefcdab89}] \ |
||||||
|
C [expr {0x98badcfe}] \ |
||||||
|
D [expr {0x10325476}] \ |
||||||
|
n 0 i "" ] |
||||||
|
if {$accel(cryptkit)} { |
||||||
|
cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_MD5 |
||||||
|
} elseif {$accel(trf)} { |
||||||
|
set s {} |
||||||
|
switch -exact -- $::tcl_platform(platform) { |
||||||
|
windows { set s [open NUL w] } |
||||||
|
unix { set s [open /dev/null w] } |
||||||
|
} |
||||||
|
if {$s != {}} { |
||||||
|
fconfigure $s -translation binary -buffering none |
||||||
|
::md5 -attach $s -mode write \ |
||||||
|
-read-type variable \ |
||||||
|
-read-destination [subst $token](trfread) \ |
||||||
|
-write-type variable \ |
||||||
|
-write-destination [subst $token](trfwrite) |
||||||
|
array set state [list trfread 0 trfwrite 0 trf $s] |
||||||
|
} |
||||||
|
} |
||||||
|
return $token |
||||||
|
} |
||||||
|
|
||||||
|
# MD5Update -- |
||||||
|
# |
||||||
|
# This is called to add more data into the hash. You may call this |
||||||
|
# as many times as you require. Note that passing in "ABC" is equivalent |
||||||
|
# to passing these letters in as separate calls -- hence this proc |
||||||
|
# permits hashing of chunked data |
||||||
|
# |
||||||
|
# If we have a C-based implementation available, then we will use |
||||||
|
# it here in preference to the pure-Tcl implementation. |
||||||
|
# |
||||||
|
proc ::md5::MD5Update {token data} { |
||||||
|
variable accel |
||||||
|
upvar #0 $token state |
||||||
|
|
||||||
|
if {$accel(critcl)} { |
||||||
|
if {[info exists state(md5c)]} { |
||||||
|
set state(md5c) [md5c $data $state(md5c)] |
||||||
|
} else { |
||||||
|
set state(md5c) [md5c $data] |
||||||
|
} |
||||||
|
return |
||||||
|
} elseif {[info exists state(ckctx)]} { |
||||||
|
if {[string length $data] > 0} { |
||||||
|
cryptkit::cryptEncrypt $state(ckctx) $data |
||||||
|
} |
||||||
|
return |
||||||
|
} elseif {[info exists state(trf)]} { |
||||||
|
puts -nonewline $state(trf) $data |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# Update the state values |
||||||
|
incr state(n) [string length $data] |
||||||
|
append state(i) $data |
||||||
|
|
||||||
|
# Calculate the hash for any complete blocks |
||||||
|
set len [string length $state(i)] |
||||||
|
for {set n 0} {($n + 64) <= $len} {} { |
||||||
|
MD5Hash $token [string range $state(i) $n [incr n 64]] |
||||||
|
} |
||||||
|
|
||||||
|
# Adjust the state for the blocks completed. |
||||||
|
set state(i) [string range $state(i) $n end] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# MD5Final -- |
||||||
|
# |
||||||
|
# This procedure is used to close the current hash and returns the |
||||||
|
# hash data. Once this procedure has been called the hash context |
||||||
|
# is freed and cannot be used again. |
||||||
|
# |
||||||
|
# Note that the output is 128 bits represented as binary data. |
||||||
|
# |
||||||
|
proc ::md5::MD5Final {token} { |
||||||
|
upvar #0 $token state |
||||||
|
|
||||||
|
# Check for either of the C-compiled versions. |
||||||
|
if {[info exists state(md5c)]} { |
||||||
|
set r $state(md5c) |
||||||
|
unset state |
||||||
|
return $r |
||||||
|
} elseif {[info exists state(ckctx)]} { |
||||||
|
cryptkit::cryptEncrypt $state(ckctx) "" |
||||||
|
cryptkit::cryptGetAttributeString $state(ckctx) \ |
||||||
|
CRYPT_CTXINFO_HASHVALUE r 16 |
||||||
|
cryptkit::cryptDestroyContext $state(ckctx) |
||||||
|
# If nothing was hashed, we get no r variable set! |
||||||
|
if {[info exists r]} { |
||||||
|
unset state |
||||||
|
return $r |
||||||
|
} |
||||||
|
} elseif {[info exists state(trf)]} { |
||||||
|
close $state(trf) |
||||||
|
set r $state(trfwrite) |
||||||
|
unset state |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# RFC1321:3.1 - Padding |
||||||
|
# |
||||||
|
set len [string length $state(i)] |
||||||
|
set pad [expr {56 - ($len % 64)}] |
||||||
|
if {$len % 64 > 56} { |
||||||
|
incr pad 64 |
||||||
|
} |
||||||
|
if {$pad == 0} { |
||||||
|
incr pad 64 |
||||||
|
} |
||||||
|
|
||||||
|
#puts "P $pad|bits=[expr {8 * $state(n)}]" |
||||||
|
|
||||||
|
append state(i) [binary format a$pad \x80] |
||||||
|
|
||||||
|
# RFC1321:3.2 - Append length in bits as little-endian wide int. |
||||||
|
append state(i) [binary format ii [expr {8 * $state(n)}] 0] |
||||||
|
|
||||||
|
#puts DATA=[Hex $state(i)]([string length $state(i)]) |
||||||
|
|
||||||
|
# Calculate the hash for the remaining block. |
||||||
|
set len [string length $state(i)] |
||||||
|
for {set n 0} {($n + 64) <= $len} {} { |
||||||
|
MD5Hash $token [string range $state(i) $n [incr n 64]] |
||||||
|
} |
||||||
|
|
||||||
|
#puts md5-post__________________________________________ |
||||||
|
#parray ::${token} |
||||||
|
|
||||||
|
# RFC1321:3.5 - Output |
||||||
|
set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)] |
||||||
|
unset state |
||||||
|
|
||||||
|
#puts HASH=[Hex $r] |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# HMAC Hashed Message Authentication (RFC 2104) |
||||||
|
# |
||||||
|
# hmac = H(K xor opad, H(K xor ipad, text)) |
||||||
|
# |
||||||
|
|
||||||
|
# HMACInit -- |
||||||
|
# |
||||||
|
# This is equivalent to the MD5Init procedure except that a key is |
||||||
|
# added into the algorithm |
||||||
|
# |
||||||
|
proc ::md5::HMACInit {K} { |
||||||
|
|
||||||
|
# Key K is adjusted to be 64 bytes long. If K is larger, then use |
||||||
|
# the MD5 digest of K and pad this instead. |
||||||
|
set len [string length $K] |
||||||
|
if {$len > 64} { |
||||||
|
set tok [MD5Init] |
||||||
|
MD5Update $tok $K |
||||||
|
set K [MD5Final $tok] |
||||||
|
set len [string length $K] |
||||||
|
} |
||||||
|
set pad [expr {64 - $len}] |
||||||
|
append K [string repeat \0 $pad] |
||||||
|
|
||||||
|
# Cacluate the padding buffers. |
||||||
|
set Ki {} |
||||||
|
set Ko {} |
||||||
|
binary scan $K i16 Ks |
||||||
|
foreach k $Ks { |
||||||
|
append Ki [binary format i [expr {$k ^ 0x36363636}]] |
||||||
|
append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]] |
||||||
|
} |
||||||
|
|
||||||
|
set tok [MD5Init] |
||||||
|
MD5Update $tok $Ki; # initialize with the inner pad |
||||||
|
|
||||||
|
# preserve the Ko value for the final stage. |
||||||
|
# FRINK: nocheck |
||||||
|
set [subst $tok](Ko) $Ko |
||||||
|
|
||||||
|
return $tok |
||||||
|
} |
||||||
|
|
||||||
|
# HMACUpdate -- |
||||||
|
# |
||||||
|
# Identical to calling MD5Update |
||||||
|
# |
||||||
|
proc ::md5::HMACUpdate {token data} { |
||||||
|
MD5Update $token $data |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# HMACFinal -- |
||||||
|
# |
||||||
|
# This is equivalent to the MD5Final procedure. The hash context is |
||||||
|
# closed and the binary representation of the hash result is returned. |
||||||
|
# |
||||||
|
proc ::md5::HMACFinal {token} { |
||||||
|
upvar #0 $token state |
||||||
|
|
||||||
|
set tok [MD5Init]; # init the outer hashing function |
||||||
|
MD5Update $tok $state(Ko); # prepare with the outer pad. |
||||||
|
MD5Update $tok [MD5Final $token]; # hash the inner result |
||||||
|
return [MD5Final $tok] |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# Description: |
||||||
|
# This is the core MD5 algorithm. It is a lot like the MD4 algorithm but |
||||||
|
# includes an extra round and a set of constant modifiers throughout. |
||||||
|
# |
||||||
|
# Note: |
||||||
|
# This function body is substituted later on to inline some of the |
||||||
|
# procedures and to make is a bit more comprehensible. |
||||||
|
# |
||||||
|
set ::md5::MD5Hash_body { |
||||||
|
variable $token |
||||||
|
upvar 0 $token state |
||||||
|
|
||||||
|
#puts TR__=[Hex $msg]([string length $msg]) |
||||||
|
|
||||||
|
# RFC1321:3.4 - Process Message in 16-Word Blocks |
||||||
|
binary scan $msg i* blocks |
||||||
|
foreach {X0 X1 X2 X3 X4 X5 X6 X7 X8 X9 X10 X11 X12 X13 X14 X15} $blocks { |
||||||
|
#puts BL |
||||||
|
|
||||||
|
set A $state(A) |
||||||
|
set B $state(B) |
||||||
|
set C $state(C) |
||||||
|
set D $state(D) |
||||||
|
|
||||||
|
# Round 1 |
||||||
|
# Let [abcd k s i] denote the operation |
||||||
|
# a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s). |
||||||
|
# Do the following 16 operations. |
||||||
|
# [ABCD 0 7 1] [DABC 1 12 2] [CDAB 2 17 3] [BCDA 3 22 4] |
||||||
|
set A [expr {$B + (($A + [F $B $C $D] + $X0 + $T01) <<< 7)}] |
||||||
|
set D [expr {$A + (($D + [F $A $B $C] + $X1 + $T02) <<< 12)}] |
||||||
|
set C [expr {$D + (($C + [F $D $A $B] + $X2 + $T03) <<< 17)}] |
||||||
|
set B [expr {$C + (($B + [F $C $D $A] + $X3 + $T04) <<< 22)}] |
||||||
|
# [ABCD 4 7 5] [DABC 5 12 6] [CDAB 6 17 7] [BCDA 7 22 8] |
||||||
|
set A [expr {$B + (($A + [F $B $C $D] + $X4 + $T05) <<< 7)}] |
||||||
|
set D [expr {$A + (($D + [F $A $B $C] + $X5 + $T06) <<< 12)}] |
||||||
|
set C [expr {$D + (($C + [F $D $A $B] + $X6 + $T07) <<< 17)}] |
||||||
|
set B [expr {$C + (($B + [F $C $D $A] + $X7 + $T08) <<< 22)}] |
||||||
|
# [ABCD 8 7 9] [DABC 9 12 10] [CDAB 10 17 11] [BCDA 11 22 12] |
||||||
|
set A [expr {$B + (($A + [F $B $C $D] + $X8 + $T09) <<< 7)}] |
||||||
|
set D [expr {$A + (($D + [F $A $B $C] + $X9 + $T10) <<< 12)}] |
||||||
|
set C [expr {$D + (($C + [F $D $A $B] + $X10 + $T11) <<< 17)}] |
||||||
|
set B [expr {$C + (($B + [F $C $D $A] + $X11 + $T12) <<< 22)}] |
||||||
|
# [ABCD 12 7 13] [DABC 13 12 14] [CDAB 14 17 15] [BCDA 15 22 16] |
||||||
|
set A [expr {$B + (($A + [F $B $C $D] + $X12 + $T13) <<< 7)}] |
||||||
|
set D [expr {$A + (($D + [F $A $B $C] + $X13 + $T14) <<< 12)}] |
||||||
|
set C [expr {$D + (($C + [F $D $A $B] + $X14 + $T15) <<< 17)}] |
||||||
|
set B [expr {$C + (($B + [F $C $D $A] + $X15 + $T16) <<< 22)}] |
||||||
|
|
||||||
|
# Round 2. |
||||||
|
# Let [abcd k s i] denote the operation |
||||||
|
# a = b + ((a + G(b,c,d) + X[k] + Ti) <<< s) |
||||||
|
# Do the following 16 operations. |
||||||
|
# [ABCD 1 5 17] [DABC 6 9 18] [CDAB 11 14 19] [BCDA 0 20 20] |
||||||
|
set A [expr {$B + (($A + [G $B $C $D] + $X1 + $T17) <<< 5)}] |
||||||
|
set D [expr {$A + (($D + [G $A $B $C] + $X6 + $T18) <<< 9)}] |
||||||
|
set C [expr {$D + (($C + [G $D $A $B] + $X11 + $T19) <<< 14)}] |
||||||
|
set B [expr {$C + (($B + [G $C $D $A] + $X0 + $T20) <<< 20)}] |
||||||
|
# [ABCD 5 5 21] [DABC 10 9 22] [CDAB 15 14 23] [BCDA 4 20 24] |
||||||
|
set A [expr {$B + (($A + [G $B $C $D] + $X5 + $T21) <<< 5)}] |
||||||
|
set D [expr {$A + (($D + [G $A $B $C] + $X10 + $T22) <<< 9)}] |
||||||
|
set C [expr {$D + (($C + [G $D $A $B] + $X15 + $T23) <<< 14)}] |
||||||
|
set B [expr {$C + (($B + [G $C $D $A] + $X4 + $T24) <<< 20)}] |
||||||
|
# [ABCD 9 5 25] [DABC 14 9 26] [CDAB 3 14 27] [BCDA 8 20 28] |
||||||
|
set A [expr {$B + (($A + [G $B $C $D] + $X9 + $T25) <<< 5)}] |
||||||
|
set D [expr {$A + (($D + [G $A $B $C] + $X14 + $T26) <<< 9)}] |
||||||
|
set C [expr {$D + (($C + [G $D $A $B] + $X3 + $T27) <<< 14)}] |
||||||
|
set B [expr {$C + (($B + [G $C $D $A] + $X8 + $T28) <<< 20)}] |
||||||
|
# [ABCD 13 5 29] [DABC 2 9 30] [CDAB 7 14 31] [BCDA 12 20 32] |
||||||
|
set A [expr {$B + (($A + [G $B $C $D] + $X13 + $T29) <<< 5)}] |
||||||
|
set D [expr {$A + (($D + [G $A $B $C] + $X2 + $T30) <<< 9)}] |
||||||
|
set C [expr {$D + (($C + [G $D $A $B] + $X7 + $T31) <<< 14)}] |
||||||
|
set B [expr {$C + (($B + [G $C $D $A] + $X12 + $T32) <<< 20)}] |
||||||
|
|
||||||
|
# Round 3. |
||||||
|
# Let [abcd k s i] denote the operation |
||||||
|
# a = b + ((a + H(b,c,d) + X[k] + T[i]) <<< s) |
||||||
|
# Do the following 16 operations. |
||||||
|
# [ABCD 5 4 33] [DABC 8 11 34] [CDAB 11 16 35] [BCDA 14 23 36] |
||||||
|
set A [expr {$B + (($A + [H $B $C $D] + $X5 + $T33) <<< 4)}] |
||||||
|
set D [expr {$A + (($D + [H $A $B $C] + $X8 + $T34) <<< 11)}] |
||||||
|
set C [expr {$D + (($C + [H $D $A $B] + $X11 + $T35) <<< 16)}] |
||||||
|
set B [expr {$C + (($B + [H $C $D $A] + $X14 + $T36) <<< 23)}] |
||||||
|
# [ABCD 1 4 37] [DABC 4 11 38] [CDAB 7 16 39] [BCDA 10 23 40] |
||||||
|
set A [expr {$B + (($A + [H $B $C $D] + $X1 + $T37) <<< 4)}] |
||||||
|
set D [expr {$A + (($D + [H $A $B $C] + $X4 + $T38) <<< 11)}] |
||||||
|
set C [expr {$D + (($C + [H $D $A $B] + $X7 + $T39) <<< 16)}] |
||||||
|
set B [expr {$C + (($B + [H $C $D $A] + $X10 + $T40) <<< 23)}] |
||||||
|
# [ABCD 13 4 41] [DABC 0 11 42] [CDAB 3 16 43] [BCDA 6 23 44] |
||||||
|
set A [expr {$B + (($A + [H $B $C $D] + $X13 + $T41) <<< 4)}] |
||||||
|
set D [expr {$A + (($D + [H $A $B $C] + $X0 + $T42) <<< 11)}] |
||||||
|
set C [expr {$D + (($C + [H $D $A $B] + $X3 + $T43) <<< 16)}] |
||||||
|
set B [expr {$C + (($B + [H $C $D $A] + $X6 + $T44) <<< 23)}] |
||||||
|
# [ABCD 9 4 45] [DABC 12 11 46] [CDAB 15 16 47] [BCDA 2 23 48] |
||||||
|
set A [expr {$B + (($A + [H $B $C $D] + $X9 + $T45) <<< 4)}] |
||||||
|
set D [expr {$A + (($D + [H $A $B $C] + $X12 + $T46) <<< 11)}] |
||||||
|
set C [expr {$D + (($C + [H $D $A $B] + $X15 + $T47) <<< 16)}] |
||||||
|
set B [expr {$C + (($B + [H $C $D $A] + $X2 + $T48) <<< 23)}] |
||||||
|
|
||||||
|
# Round 4. |
||||||
|
# Let [abcd k s i] denote the operation |
||||||
|
# a = b + ((a + I(b,c,d) + X[k] + T[i]) <<< s) |
||||||
|
# Do the following 16 operations. |
||||||
|
# [ABCD 0 6 49] [DABC 7 10 50] [CDAB 14 15 51] [BCDA 5 21 52] |
||||||
|
set A [expr {$B + (($A + [I $B $C $D] + $X0 + $T49) <<< 6)}] |
||||||
|
set D [expr {$A + (($D + [I $A $B $C] + $X7 + $T50) <<< 10)}] |
||||||
|
set C [expr {$D + (($C + [I $D $A $B] + $X14 + $T51) <<< 15)}] |
||||||
|
set B [expr {$C + (($B + [I $C $D $A] + $X5 + $T52) <<< 21)}] |
||||||
|
# [ABCD 12 6 53] [DABC 3 10 54] [CDAB 10 15 55] [BCDA 1 21 56] |
||||||
|
set A [expr {$B + (($A + [I $B $C $D] + $X12 + $T53) <<< 6)}] |
||||||
|
set D [expr {$A + (($D + [I $A $B $C] + $X3 + $T54) <<< 10)}] |
||||||
|
set C [expr {$D + (($C + [I $D $A $B] + $X10 + $T55) <<< 15)}] |
||||||
|
set B [expr {$C + (($B + [I $C $D $A] + $X1 + $T56) <<< 21)}] |
||||||
|
# [ABCD 8 6 57] [DABC 15 10 58] [CDAB 6 15 59] [BCDA 13 21 60] |
||||||
|
set A [expr {$B + (($A + [I $B $C $D] + $X8 + $T57) <<< 6)}] |
||||||
|
set D [expr {$A + (($D + [I $A $B $C] + $X15 + $T58) <<< 10)}] |
||||||
|
set C [expr {$D + (($C + [I $D $A $B] + $X6 + $T59) <<< 15)}] |
||||||
|
set B [expr {$C + (($B + [I $C $D $A] + $X13 + $T60) <<< 21)}] |
||||||
|
# [ABCD 4 6 61] [DABC 11 10 62] [CDAB 2 15 63] [BCDA 9 21 64] |
||||||
|
set A [expr {$B + (($A + [I $B $C $D] + $X4 + $T61) <<< 6)}] |
||||||
|
set D [expr {$A + (($D + [I $A $B $C] + $X11 + $T62) <<< 10)}] |
||||||
|
set C [expr {$D + (($C + [I $D $A $B] + $X2 + $T63) <<< 15)}] |
||||||
|
set B [expr {$C + (($B + [I $C $D $A] + $X9 + $T64) <<< 21)}] |
||||||
|
|
||||||
|
# Then perform the following additions. (That is, increment each |
||||||
|
# of the four registers by the value it had before this block |
||||||
|
# was started.) |
||||||
|
incr state(A) $A |
||||||
|
incr state(B) $B |
||||||
|
incr state(C) $C |
||||||
|
incr state(D) $D |
||||||
|
} |
||||||
|
|
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::md5::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}} |
||||||
|
proc ::md5::bytes {v} { |
||||||
|
#format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v] |
||||||
|
format %c%c%c%c \ |
||||||
|
[expr {0xFF & $v}] \ |
||||||
|
[expr {(0xFF00 & $v) >> 8}] \ |
||||||
|
[expr {(0xFF0000 & $v) >> 16}] \ |
||||||
|
[expr {((0xFF000000 & $v) >> 24) & 0xFF}] |
||||||
|
} |
||||||
|
|
||||||
|
# 32bit rotate-left |
||||||
|
proc ::md5::<<< {v n} { |
||||||
|
return [expr {((($v << $n) \ |
||||||
|
| (($v >> (32 - $n)) \ |
||||||
|
& (0x7FFFFFFF >> (31 - $n))))) \ |
||||||
|
& 0xFFFFFFFF}] |
||||||
|
} |
||||||
|
|
||||||
|
# Convert our <<< pseudo-operator into a procedure call. |
||||||
|
regsub -all -line \ |
||||||
|
{\[expr {(\$[ABCD]) \+ \(\((.*)\)\s+<<<\s+(\d+)\)}\]} \ |
||||||
|
$::md5::MD5Hash_body \ |
||||||
|
{[expr {int(\1 + [<<< [expr {\2}] \3])}]} \ |
||||||
|
::md5::MD5Hash_body |
||||||
|
|
||||||
|
# RFC1321:3.4 - function F |
||||||
|
proc ::md5::F {X Y Z} { |
||||||
|
return [expr {($X & $Y) | ((~$X) & $Z)}] |
||||||
|
} |
||||||
|
|
||||||
|
# Inline the F function |
||||||
|
regsub -all -line \ |
||||||
|
{\[F (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \ |
||||||
|
$::md5::MD5Hash_body \ |
||||||
|
{( (\1 \& \2) | ((~\1) \& \3) )} \ |
||||||
|
::md5::MD5Hash_body |
||||||
|
|
||||||
|
# RFC1321:3.4 - function G |
||||||
|
proc ::md5::G {X Y Z} { |
||||||
|
return [expr {(($X & $Z) | ($Y & (~$Z)))}] |
||||||
|
} |
||||||
|
|
||||||
|
# Inline the G function |
||||||
|
regsub -all -line \ |
||||||
|
{\[G (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \ |
||||||
|
$::md5::MD5Hash_body \ |
||||||
|
{(((\1 \& \3) | (\2 \& (~\3))))} \ |
||||||
|
::md5::MD5Hash_body |
||||||
|
|
||||||
|
# RFC1321:3.4 - function H |
||||||
|
proc ::md5::H {X Y Z} { |
||||||
|
return [expr {$X ^ $Y ^ $Z}] |
||||||
|
} |
||||||
|
|
||||||
|
# Inline the H function |
||||||
|
regsub -all -line \ |
||||||
|
{\[H (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \ |
||||||
|
$::md5::MD5Hash_body \ |
||||||
|
{(\1 ^ \2 ^ \3)} \ |
||||||
|
::md5::MD5Hash_body |
||||||
|
|
||||||
|
# RFC1321:3.4 - function I |
||||||
|
proc ::md5::I {X Y Z} { |
||||||
|
return [expr {$Y ^ ($X | (~$Z))}] |
||||||
|
} |
||||||
|
|
||||||
|
# Inline the I function |
||||||
|
regsub -all -line \ |
||||||
|
{\[I (\$[ABCD]) (\$[ABCD]) (\$[ABCD])\]} \ |
||||||
|
$::md5::MD5Hash_body \ |
||||||
|
{(\2 ^ (\1 | (~\3)))} \ |
||||||
|
::md5::MD5Hash_body |
||||||
|
|
||||||
|
|
||||||
|
# RFC 1321:3.4 step 4: inline the set of constant modifiers. |
||||||
|
namespace eval md5 { |
||||||
|
variable tName |
||||||
|
variable tVal |
||||||
|
variable map |
||||||
|
foreach tName { |
||||||
|
T01 T02 T03 T04 T05 T06 T07 T08 T09 T10 |
||||||
|
T11 T12 T13 T14 T15 T16 T17 T18 T19 T20 |
||||||
|
T21 T22 T23 T24 T25 T26 T27 T28 T29 T30 |
||||||
|
T31 T32 T33 T34 T35 T36 T37 T38 T39 T40 |
||||||
|
T41 T42 T43 T44 T45 T46 T47 T48 T49 T50 |
||||||
|
T51 T52 T53 T54 T55 T56 T57 T58 T59 T60 |
||||||
|
T61 T62 T63 T64 |
||||||
|
} tVal { |
||||||
|
0xd76aa478 0xe8c7b756 0x242070db 0xc1bdceee |
||||||
|
0xf57c0faf 0x4787c62a 0xa8304613 0xfd469501 |
||||||
|
0x698098d8 0x8b44f7af 0xffff5bb1 0x895cd7be |
||||||
|
0x6b901122 0xfd987193 0xa679438e 0x49b40821 |
||||||
|
|
||||||
|
0xf61e2562 0xc040b340 0x265e5a51 0xe9b6c7aa |
||||||
|
0xd62f105d 0x2441453 0xd8a1e681 0xe7d3fbc8 |
||||||
|
0x21e1cde6 0xc33707d6 0xf4d50d87 0x455a14ed |
||||||
|
0xa9e3e905 0xfcefa3f8 0x676f02d9 0x8d2a4c8a |
||||||
|
|
||||||
|
0xfffa3942 0x8771f681 0x6d9d6122 0xfde5380c |
||||||
|
0xa4beea44 0x4bdecfa9 0xf6bb4b60 0xbebfbc70 |
||||||
|
0x289b7ec6 0xeaa127fa 0xd4ef3085 0x4881d05 |
||||||
|
0xd9d4d039 0xe6db99e5 0x1fa27cf8 0xc4ac5665 |
||||||
|
|
||||||
|
0xf4292244 0x432aff97 0xab9423a7 0xfc93a039 |
||||||
|
0x655b59c3 0x8f0ccc92 0xffeff47d 0x85845dd1 |
||||||
|
0x6fa87e4f 0xfe2ce6e0 0xa3014314 0x4e0811a1 |
||||||
|
0xf7537e82 0xbd3af235 0x2ad7d2bb 0xeb86d391 |
||||||
|
} { |
||||||
|
lappend map \$$tName $tVal |
||||||
|
} |
||||||
|
set ::md5::MD5Hash_body [string map $map $::md5::MD5Hash_body] |
||||||
|
unset map tName tVal |
||||||
|
} |
||||||
|
|
||||||
|
# Define the MD5 hashing procedure with inline functions. |
||||||
|
proc ::md5::MD5Hash {token msg} $::md5::MD5Hash_body |
||||||
|
unset ::md5::MD5Hash_body |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
if {[package provide Trf] != {}} { |
||||||
|
interp alias {} ::md5::Hex {} ::hex -mode encode -- |
||||||
|
} else { |
||||||
|
proc ::md5::Hex {data} { |
||||||
|
binary scan $data H* result |
||||||
|
return [string toupper $result] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# 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 ::md5::LoadAccelerator {name} { |
||||||
|
variable accel |
||||||
|
set r 0 |
||||||
|
switch -exact -- $name { |
||||||
|
critcl { |
||||||
|
if {![catch {package require tcllibc}] |
||||||
|
|| ![catch {package require md5c}]} { |
||||||
|
set r [expr {[info commands ::md5::md5c] != {}}] |
||||||
|
} |
||||||
|
} |
||||||
|
cryptkit { |
||||||
|
if {![catch {package require cryptkit}]} { |
||||||
|
set r [expr {![catch {cryptkit::cryptInit}]}] |
||||||
|
} |
||||||
|
} |
||||||
|
trf { |
||||||
|
if {![catch {package require Trf}]} { |
||||||
|
set r [expr {![catch {::md5 aa} msg]}] |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "invalid accelerator package:\ |
||||||
|
must be one of [join [array names accel] {, }]" |
||||||
|
} |
||||||
|
} |
||||||
|
set accel($name) $r |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# Description: |
||||||
|
# Pop the nth element off a list. Used in options processing. |
||||||
|
# |
||||||
|
proc ::md5::Pop {varname {nth 0}} { |
||||||
|
upvar $varname args |
||||||
|
set r [lindex $args $nth] |
||||||
|
set args [lreplace $args $nth $nth] |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# fileevent handler for chunked file hashing. |
||||||
|
# |
||||||
|
proc ::md5::Chunk {token channel {chunksize 4096}} { |
||||||
|
upvar #0 $token state |
||||||
|
|
||||||
|
if {[eof $channel]} { |
||||||
|
fileevent $channel readable {} |
||||||
|
set state(reading) 0 |
||||||
|
} |
||||||
|
|
||||||
|
MD5Update $token [read $channel $chunksize] |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
proc ::md5::md5 {args} { |
||||||
|
array set opts {-hex 0 -filename {} -channel {} -chunksize 4096} |
||||||
|
while {[string match -* [set option [lindex $args 0]]]} { |
||||||
|
switch -glob -- $option { |
||||||
|
-hex { set opts(-hex) 1 } |
||||||
|
-file* { set opts(-filename) [Pop args 1] } |
||||||
|
-channel { set opts(-channel) [Pop args 1] } |
||||||
|
-chunksize { set opts(-chunksize) [Pop args 1] } |
||||||
|
default { |
||||||
|
if {[llength $args] == 1} { break } |
||||||
|
if {[string compare $option "--"] == 0} { Pop args; break } |
||||||
|
set err [join [lsort [array names opts]] ", "] |
||||||
|
return -code error "bad option $option:\ |
||||||
|
must be one of $err\nlen: [llength $args]" |
||||||
|
} |
||||||
|
} |
||||||
|
Pop args |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-filename) != {}} { |
||||||
|
set opts(-channel) [open $opts(-filename) r] |
||||||
|
fconfigure $opts(-channel) -translation binary |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-channel) == {}} { |
||||||
|
|
||||||
|
if {[llength $args] != 1} { |
||||||
|
return -code error "wrong # args:\ |
||||||
|
should be \"md5 ?-hex? -filename file | string\"" |
||||||
|
} |
||||||
|
set tok [MD5Init] |
||||||
|
|
||||||
|
#puts md5_______________________________________________ |
||||||
|
#parray ::${tok} |
||||||
|
|
||||||
|
#puts IN=(([lindex $args 0])) |
||||||
|
MD5Update $tok [lindex $args 0] |
||||||
|
|
||||||
|
#puts md5-final_________________________________________ |
||||||
|
#parray ::${tok} |
||||||
|
|
||||||
|
set r [MD5Final $tok] |
||||||
|
|
||||||
|
} else { |
||||||
|
|
||||||
|
set tok [MD5Init] |
||||||
|
# FRINK: nocheck |
||||||
|
set [subst $tok](reading) 1 |
||||||
|
fileevent $opts(-channel) readable \ |
||||||
|
[list [namespace origin Chunk] \ |
||||||
|
$tok $opts(-channel) $opts(-chunksize)] |
||||||
|
vwait [subst $tok](reading) |
||||||
|
set r [MD5Final $tok] |
||||||
|
|
||||||
|
# If we opened the channel - we should close it too. |
||||||
|
if {$opts(-filename) != {}} { |
||||||
|
close $opts(-channel) |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-hex)} { |
||||||
|
set r [Hex $r] |
||||||
|
} |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
proc ::md5::hmac {args} { |
||||||
|
array set opts {-hex 0 -filename {} -channel {} -chunksize 4096} |
||||||
|
while {[string match -* [set option [lindex $args 0]]]} { |
||||||
|
switch -glob -- $option { |
||||||
|
-key { set opts(-key) [Pop args 1] } |
||||||
|
-hex { set opts(-hex) 1 } |
||||||
|
-file* { set opts(-filename) [Pop args 1] } |
||||||
|
-channel { set opts(-channel) [Pop args 1] } |
||||||
|
-chunksize { set opts(-chunksize) [Pop args 1] } |
||||||
|
default { |
||||||
|
if {[llength $args] == 1} { break } |
||||||
|
if {[string compare $option "--"] == 0} { Pop args; break } |
||||||
|
set err [join [lsort [array names opts]] ", "] |
||||||
|
return -code error "bad option $option:\ |
||||||
|
must be one of $err" |
||||||
|
} |
||||||
|
} |
||||||
|
Pop args |
||||||
|
} |
||||||
|
|
||||||
|
if {![info exists opts(-key)]} { |
||||||
|
return -code error "wrong # args:\ |
||||||
|
should be \"hmac ?-hex? -key key -filename file | string\"" |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-filename) != {}} { |
||||||
|
set opts(-channel) [open $opts(-filename) r] |
||||||
|
fconfigure $opts(-channel) -translation binary |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-channel) == {}} { |
||||||
|
|
||||||
|
if {[llength $args] != 1} { |
||||||
|
return -code error "wrong # args:\ |
||||||
|
should be \"hmac ?-hex? -key key -filename file | string\"" |
||||||
|
} |
||||||
|
set tok [HMACInit $opts(-key)] |
||||||
|
HMACUpdate $tok [lindex $args 0] |
||||||
|
set r [HMACFinal $tok] |
||||||
|
|
||||||
|
} else { |
||||||
|
|
||||||
|
set tok [HMACInit $opts(-key)] |
||||||
|
# FRINK: nocheck |
||||||
|
set [subst $tok](reading) 1 |
||||||
|
fileevent $opts(-channel) readable \ |
||||||
|
[list [namespace origin Chunk] \ |
||||||
|
$tok $opts(-channel) $opts(-chunksize)] |
||||||
|
vwait [subst $tok](reading) |
||||||
|
set r [HMACFinal $tok] |
||||||
|
|
||||||
|
# If we opened the channel - we should close it too. |
||||||
|
if {$opts(-filename) != {}} { |
||||||
|
close $opts(-channel) |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-hex)} { |
||||||
|
set r [Hex $r] |
||||||
|
} |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# Try and load a compiled extension to help. |
||||||
|
namespace eval ::md5 { |
||||||
|
variable e |
||||||
|
foreach e {critcl cryptkit trf} { if {[LoadAccelerator $e]} { break } } |
||||||
|
unset e |
||||||
|
} |
||||||
|
|
||||||
|
package provide md5 2.0.8 |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# Local Variables: |
||||||
|
# mode: tcl |
||||||
|
# indent-tabs-mode: nil |
||||||
|
# End: |
||||||
|
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,200 @@ |
|||||||
|
#JMN - api should be kept in sync with package patternlib where possible |
||||||
|
# |
||||||
|
package provide oolib [namespace eval oolib { |
||||||
|
variable version |
||||||
|
set version 0.1.1 |
||||||
|
}] |
||||||
|
|
||||||
|
namespace eval oolib { |
||||||
|
oo::class create collection { |
||||||
|
variable o_data ;#dict |
||||||
|
variable o_alias |
||||||
|
constructor {} { |
||||||
|
set o_data [dict create] |
||||||
|
} |
||||||
|
method info {} { |
||||||
|
return [dict info $o_data] |
||||||
|
} |
||||||
|
method count {} { |
||||||
|
return [dict size $o_data] |
||||||
|
} |
||||||
|
method isEmpty {} { |
||||||
|
expr {[dict size $o_data] == 0} |
||||||
|
} |
||||||
|
method names {{globOrIdx {}}} { |
||||||
|
if {[llength $globOrIdx]} { |
||||||
|
if {[string is integer -strict $globOrIdx]} { |
||||||
|
set idx $globOrIdx |
||||||
|
if {$idx < 0} { |
||||||
|
set idx "end-[expr {abs($idx + 1)}]" |
||||||
|
} |
||||||
|
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||||
|
error "[self object] no such index : '$idx'" |
||||||
|
} else { |
||||||
|
return $result |
||||||
|
} |
||||||
|
} else { |
||||||
|
#glob |
||||||
|
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||||
|
} |
||||||
|
} else { |
||||||
|
return [dict keys $o_data] |
||||||
|
} |
||||||
|
} |
||||||
|
#like names but without globbing |
||||||
|
method keys {} { |
||||||
|
dict keys $o_data |
||||||
|
} |
||||||
|
method key {{posn 0}} { |
||||||
|
if {$posn < 0} { |
||||||
|
set posn "end-[expr {abs($posn + 1)}]" |
||||||
|
} |
||||||
|
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||||
|
error "[self object] no such index : '$posn'" |
||||||
|
} else { |
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
method hasKey {key} { |
||||||
|
dict exists $o_data $key |
||||||
|
} |
||||||
|
method get {} { |
||||||
|
return $o_data |
||||||
|
} |
||||||
|
method items {} { |
||||||
|
return [dict values $o_data] |
||||||
|
} |
||||||
|
method item {key} { |
||||||
|
if {[string is integer -strict $key]} { |
||||||
|
if {$key >= 0} { |
||||||
|
set valposn [expr {(2*$key) +1}] |
||||||
|
return [lindex $o_data $valposn] |
||||||
|
} else { |
||||||
|
set key "end-[expr {abs($key + 1)}]" |
||||||
|
return [lindex $o_data $key] |
||||||
|
#return [lindex [dict keys $o_data] $key] |
||||||
|
} |
||||||
|
} |
||||||
|
if {[dict exists $o_data $key]} { |
||||||
|
return [dict get $o_data $key] |
||||||
|
} |
||||||
|
} |
||||||
|
#inverse lookup |
||||||
|
method itemKeys {value} { |
||||||
|
set value_indices [lsearch -all [dict values $o_data] $value] |
||||||
|
set keylist [list] |
||||||
|
foreach i $value_indices { |
||||||
|
set idx [expr {(($i + 1) *2) -2}] |
||||||
|
lappend keylist [lindex $o_data $idx] |
||||||
|
} |
||||||
|
return $keylist |
||||||
|
} |
||||||
|
method search {value args} { |
||||||
|
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||||
|
if {"-inline" in $args} { |
||||||
|
return $matches |
||||||
|
} else { |
||||||
|
set keylist [list] |
||||||
|
foreach i $matches { |
||||||
|
set idx [expr {(($i + 1) *2) -2}] |
||||||
|
lappend keylist [lindex $o_data $idx] |
||||||
|
} |
||||||
|
return $keylist |
||||||
|
} |
||||||
|
} |
||||||
|
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||||
|
method alias {newAlias existingKeyOrAlias} { |
||||||
|
if {[string is integer -strict $newAlias]} { |
||||||
|
error "[self object] collection key alias cannot be integer" |
||||||
|
} |
||||||
|
if {[string length $existingKeyOrAlias]} { |
||||||
|
set o_alias($newAlias) $existingKeyOrAlias |
||||||
|
} else { |
||||||
|
unset o_alias($newAlias) |
||||||
|
} |
||||||
|
} |
||||||
|
method aliases {{key ""}} { |
||||||
|
if {[string length $key]} { |
||||||
|
set result [list] |
||||||
|
foreach {n v} [array get o_alias] { |
||||||
|
if {$v eq $key} { |
||||||
|
lappend result $n $v |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} else { |
||||||
|
return [array get o_alias] |
||||||
|
} |
||||||
|
} |
||||||
|
#if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||||
|
method realKey {idx} { |
||||||
|
if {[catch {set o_alias($idx)} key]} { |
||||||
|
return $idx |
||||||
|
} else { |
||||||
|
return $key |
||||||
|
} |
||||||
|
} |
||||||
|
method add {value key} { |
||||||
|
if {[string is integer -strict $key]} { |
||||||
|
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||||
|
} |
||||||
|
if {[dict exists $o_data $key]} { |
||||||
|
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||||
|
} |
||||||
|
dict set o_data $key $value |
||||||
|
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||||
|
} |
||||||
|
method remove {idx {endRange ""}} { |
||||||
|
if {[string length $endRange]} { |
||||||
|
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||||
|
} |
||||||
|
if {[string is integer -strict $idx]} { |
||||||
|
if {$idx < 0} { |
||||||
|
set idx "end-[expr {abs($idx+1)}]" |
||||||
|
} |
||||||
|
set key [lindex [dict keys $o_data] $idx] |
||||||
|
set posn $idx |
||||||
|
} else { |
||||||
|
set key $idx |
||||||
|
set posn [lsearch -exact [dict keys $o_data] $key] |
||||||
|
if {$posn < 0} { |
||||||
|
error "[self object] no such index: '$idx' in this collection" |
||||||
|
} |
||||||
|
} |
||||||
|
dict unset o_data $key |
||||||
|
return |
||||||
|
} |
||||||
|
method clear {} { |
||||||
|
set o_data [dict create] |
||||||
|
return |
||||||
|
} |
||||||
|
method reverse_the_collection {} { |
||||||
|
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs |
||||||
|
#the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. |
||||||
|
#todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. |
||||||
|
set dictnew [dict create] |
||||||
|
foreach k [lreverse [dict keys $o_data]] { |
||||||
|
dict set dictnew $k [dict get $o_data $k] |
||||||
|
} |
||||||
|
set o_data $dictnew |
||||||
|
return |
||||||
|
} |
||||||
|
#review - cmd as list vs cmd as script? |
||||||
|
method map {cmd} { |
||||||
|
set seed [list] |
||||||
|
dict for {k v} $o_data { |
||||||
|
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||||
|
} |
||||||
|
return $seed |
||||||
|
} |
||||||
|
method objectmap {cmd} { |
||||||
|
set seed [list] |
||||||
|
dict for {k v} $o_data { |
||||||
|
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||||
|
} |
||||||
|
return $seed |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
@ -0,0 +1,201 @@ |
|||||||
|
#JMN - api should be kept in sync with package patternlib where possible |
||||||
|
# |
||||||
|
package provide oolib [namespace eval oolib { |
||||||
|
variable version |
||||||
|
set version 0.1.2 |
||||||
|
}] |
||||||
|
|
||||||
|
namespace eval oolib { |
||||||
|
oo::class create collection { |
||||||
|
variable o_data ;#dict |
||||||
|
#variable o_alias |
||||||
|
constructor {} { |
||||||
|
set o_data [dict create] |
||||||
|
} |
||||||
|
method info {} { |
||||||
|
return [dict info $o_data] |
||||||
|
} |
||||||
|
method count {} { |
||||||
|
return [dict size $o_data] |
||||||
|
} |
||||||
|
method isEmpty {} { |
||||||
|
expr {[dict size $o_data] == 0} |
||||||
|
} |
||||||
|
method names {{globOrIdx {}}} { |
||||||
|
if {[llength $globOrIdx]} { |
||||||
|
if {[string is integer -strict $globOrIdx]} { |
||||||
|
set idx $globOrIdx |
||||||
|
if {$idx < 0} { |
||||||
|
set idx "end-[expr {abs($idx + 1)}]" |
||||||
|
} |
||||||
|
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||||
|
error "[self object] no such index : '$idx'" |
||||||
|
} else { |
||||||
|
return $result |
||||||
|
} |
||||||
|
} else { |
||||||
|
#glob |
||||||
|
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||||
|
} |
||||||
|
} else { |
||||||
|
return [dict keys $o_data] |
||||||
|
} |
||||||
|
} |
||||||
|
#like names but without globbing |
||||||
|
method keys {} { |
||||||
|
dict keys $o_data |
||||||
|
} |
||||||
|
method key {{posn 0}} { |
||||||
|
if {$posn < 0} { |
||||||
|
set posn "end-[expr {abs($posn + 1)}]" |
||||||
|
} |
||||||
|
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||||
|
error "[self object] no such index : '$posn'" |
||||||
|
} else { |
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
method hasKey {key} { |
||||||
|
dict exists $o_data $key |
||||||
|
} |
||||||
|
method get {} { |
||||||
|
return $o_data |
||||||
|
} |
||||||
|
method items {} { |
||||||
|
return [dict values $o_data] |
||||||
|
} |
||||||
|
method item {key} { |
||||||
|
if {[string is integer -strict $key]} { |
||||||
|
if {$key >= 0} { |
||||||
|
set valposn [expr {(2*$key) +1}] |
||||||
|
return [lindex $o_data $valposn] |
||||||
|
} else { |
||||||
|
set key "end-[expr {abs($key + 1)}]" |
||||||
|
return [lindex $o_data $key] |
||||||
|
#return [lindex [dict keys $o_data] $key] |
||||||
|
} |
||||||
|
} |
||||||
|
if {[dict exists $o_data $key]} { |
||||||
|
return [dict get $o_data $key] |
||||||
|
} |
||||||
|
} |
||||||
|
#inverse lookup |
||||||
|
method itemKeys {value} { |
||||||
|
set value_indices [lsearch -all [dict values $o_data] $value] |
||||||
|
set keylist [list] |
||||||
|
foreach i $value_indices { |
||||||
|
set idx [expr {(($i + 1) *2) -2}] |
||||||
|
lappend keylist [lindex $o_data $idx] |
||||||
|
} |
||||||
|
return $keylist |
||||||
|
} |
||||||
|
method search {value args} { |
||||||
|
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||||
|
if {"-inline" in $args} { |
||||||
|
return $matches |
||||||
|
} else { |
||||||
|
set keylist [list] |
||||||
|
foreach i $matches { |
||||||
|
set idx [expr {(($i + 1) *2) -2}] |
||||||
|
lappend keylist [lindex $o_data $idx] |
||||||
|
} |
||||||
|
return $keylist |
||||||
|
} |
||||||
|
} |
||||||
|
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||||
|
#review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? |
||||||
|
#method alias {newAlias existingKeyOrAlias} { |
||||||
|
# if {[string is integer -strict $newAlias]} { |
||||||
|
# error "[self object] collection key alias cannot be integer" |
||||||
|
# } |
||||||
|
# if {[string length $existingKeyOrAlias]} { |
||||||
|
# set o_alias($newAlias) $existingKeyOrAlias |
||||||
|
# } else { |
||||||
|
# unset o_alias($newAlias) |
||||||
|
# } |
||||||
|
#} |
||||||
|
#method aliases {{key ""}} { |
||||||
|
# if {[string length $key]} { |
||||||
|
# set result [list] |
||||||
|
# foreach {n v} [array get o_alias] { |
||||||
|
# if {$v eq $key} { |
||||||
|
# lappend result $n $v |
||||||
|
# } |
||||||
|
# } |
||||||
|
# return $result |
||||||
|
# } else { |
||||||
|
# return [array get o_alias] |
||||||
|
# } |
||||||
|
#} |
||||||
|
##if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||||
|
#method realKey {idx} { |
||||||
|
# if {[catch {set o_alias($idx)} key]} { |
||||||
|
# return $idx |
||||||
|
# } else { |
||||||
|
# return $key |
||||||
|
# } |
||||||
|
#} |
||||||
|
method add {value key} { |
||||||
|
if {[string is integer -strict $key]} { |
||||||
|
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||||
|
} |
||||||
|
if {[dict exists $o_data $key]} { |
||||||
|
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||||
|
} |
||||||
|
dict set o_data $key $value |
||||||
|
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||||
|
} |
||||||
|
method remove {idx {endRange ""}} { |
||||||
|
if {[string length $endRange]} { |
||||||
|
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||||
|
} |
||||||
|
if {[string is integer -strict $idx]} { |
||||||
|
if {$idx < 0} { |
||||||
|
set idx "end-[expr {abs($idx+1)}]" |
||||||
|
} |
||||||
|
set key [lindex [dict keys $o_data] $idx] |
||||||
|
set posn $idx |
||||||
|
} else { |
||||||
|
set key $idx |
||||||
|
set posn [lsearch -exact [dict keys $o_data] $key] |
||||||
|
if {$posn < 0} { |
||||||
|
error "[self object] no such index: '$idx' in this collection" |
||||||
|
} |
||||||
|
} |
||||||
|
dict unset o_data $key |
||||||
|
return |
||||||
|
} |
||||||
|
method clear {} { |
||||||
|
set o_data [dict create] |
||||||
|
return |
||||||
|
} |
||||||
|
method reverse_the_collection {} { |
||||||
|
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs |
||||||
|
#the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. |
||||||
|
#todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. |
||||||
|
set dictnew [dict create] |
||||||
|
foreach k [lreverse [dict keys $o_data]] { |
||||||
|
dict set dictnew $k [dict get $o_data $k] |
||||||
|
} |
||||||
|
set o_data $dictnew |
||||||
|
return |
||||||
|
} |
||||||
|
#review - cmd as list vs cmd as script? |
||||||
|
method map {cmd} { |
||||||
|
set seed [list] |
||||||
|
dict for {k v} $o_data { |
||||||
|
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||||
|
} |
||||||
|
return $seed |
||||||
|
} |
||||||
|
method objectmap {cmd} { |
||||||
|
set seed [list] |
||||||
|
dict for {k v} $o_data { |
||||||
|
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||||
|
} |
||||||
|
return $seed |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
@ -0,0 +1,195 @@ |
|||||||
|
#JMN - api should be kept in sync with package patternlib where possible |
||||||
|
# |
||||||
|
package provide oolib [namespace eval oolib { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
}] |
||||||
|
|
||||||
|
namespace eval oolib { |
||||||
|
oo::class create collection { |
||||||
|
variable o_data ;#dict |
||||||
|
variable o_alias |
||||||
|
constructor {} { |
||||||
|
set o_data [dict create] |
||||||
|
} |
||||||
|
method info {} { |
||||||
|
return [dict info $o_data] |
||||||
|
} |
||||||
|
method count {} { |
||||||
|
return [dict size $o_data] |
||||||
|
} |
||||||
|
method isEmpty {} { |
||||||
|
expr {[dict size $o_data] == 0} |
||||||
|
} |
||||||
|
method names {{globOrIdx {}}} { |
||||||
|
if {[llength $globOrIdx]} { |
||||||
|
if {[string is integer -strict $globOrIdx]} { |
||||||
|
if {$idx < 0} { |
||||||
|
set idx "end-[expr {abs($idx + 1)}]" |
||||||
|
} |
||||||
|
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||||
|
error "[self object] no such index : '$idx'" |
||||||
|
} else { |
||||||
|
return $result |
||||||
|
} |
||||||
|
} else { |
||||||
|
#glob |
||||||
|
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||||
|
} |
||||||
|
} else { |
||||||
|
return [dict keys $o_data] |
||||||
|
} |
||||||
|
} |
||||||
|
#like names but without globbing |
||||||
|
method keys {} { |
||||||
|
dict keys $o_data |
||||||
|
} |
||||||
|
method key {{posn 0}} { |
||||||
|
if {$posn < 0} { |
||||||
|
set posn "end-[expr {abs($posn + 1)}]" |
||||||
|
} |
||||||
|
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||||
|
error "[self object] no such index : '$posn'" |
||||||
|
} else { |
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
method hasKey {key} { |
||||||
|
dict exists $o_data $key |
||||||
|
} |
||||||
|
method get {} { |
||||||
|
return $o_data |
||||||
|
} |
||||||
|
method items {} { |
||||||
|
return [dict values $o_data] |
||||||
|
} |
||||||
|
method item {key} { |
||||||
|
if {[string is integer -strict $key]} { |
||||||
|
if {$key > 0} { |
||||||
|
set valposn [expr {(2*$key) +1}] |
||||||
|
return [lindex $o_data $valposn] |
||||||
|
} else { |
||||||
|
set key "end-[expr {abs($key + 1)}]" |
||||||
|
return [lindex [dict keys $o_data] $key] |
||||||
|
} |
||||||
|
} |
||||||
|
if {[dict exists $o_data $key]} { |
||||||
|
return [dict get $o_data $key] |
||||||
|
} |
||||||
|
} |
||||||
|
#inverse lookup |
||||||
|
method itemKeys {value} { |
||||||
|
set value_indices [lsearch -all [dict values $o_data] $value] |
||||||
|
set keylist [list] |
||||||
|
foreach i $value_indices { |
||||||
|
set idx [expr {(($i + 1) *2) -2}] |
||||||
|
lappend keylist [lindex $o_data $idx] |
||||||
|
} |
||||||
|
return $keylist |
||||||
|
} |
||||||
|
method search {value args} { |
||||||
|
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||||
|
if {"-inline" in $args} { |
||||||
|
return $matches |
||||||
|
} else { |
||||||
|
set keylist [list] |
||||||
|
foreach i $matches { |
||||||
|
set idx [expr {(($i + 1) *2) -2}] |
||||||
|
lappend keylist [lindex $o_data $idx] |
||||||
|
} |
||||||
|
return $keylist |
||||||
|
} |
||||||
|
} |
||||||
|
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||||
|
method alias {newAlias existingKeyOrAlias} { |
||||||
|
if {[string is integer -strict $newAlias]} { |
||||||
|
error "[self object] collection key alias cannot be integer" |
||||||
|
} |
||||||
|
if {[string length $existingKeyOrAlias]} { |
||||||
|
set o_alias($newAlias) $existingKeyOrAlias |
||||||
|
} else { |
||||||
|
unset o_alias($newAlias) |
||||||
|
} |
||||||
|
} |
||||||
|
method aliases {{key ""}} { |
||||||
|
if {[string length $key]} { |
||||||
|
set result [list] |
||||||
|
foreach {n v} [array get o_alias] { |
||||||
|
if {$v eq $key} { |
||||||
|
lappend result $n $v |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} else { |
||||||
|
return [array get o_alias] |
||||||
|
} |
||||||
|
} |
||||||
|
#if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||||
|
method realKey {idx} { |
||||||
|
if {[catch {set o_alias($idx)} key]} { |
||||||
|
return $idx |
||||||
|
} else { |
||||||
|
return $key |
||||||
|
} |
||||||
|
} |
||||||
|
method add {value key} { |
||||||
|
if {[string is integer -strict $key]} { |
||||||
|
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||||
|
} |
||||||
|
if {[dict exists $o_data $key]} { |
||||||
|
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||||
|
} |
||||||
|
dict set o_data $key $value |
||||||
|
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||||
|
} |
||||||
|
method remove {idx {endRange ""}} { |
||||||
|
if {[string length $endRange]} { |
||||||
|
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||||
|
} |
||||||
|
if {[string is integer -strict $idx]} { |
||||||
|
if {$idx < 0} { |
||||||
|
set idx "end-[expr {abs($idx+1)}]" |
||||||
|
} |
||||||
|
set key [lindex [dict keys $o_data] $idx] |
||||||
|
set posn $idx |
||||||
|
} else { |
||||||
|
set key $idx |
||||||
|
set posn [lsearch -exact [dict keys $o_data] $key] |
||||||
|
if {$posn < 0} { |
||||||
|
error "[self object] no such index: '$idx' in this collection" |
||||||
|
} |
||||||
|
} |
||||||
|
dict unset o_data $key |
||||||
|
return |
||||||
|
} |
||||||
|
method clear {} { |
||||||
|
set o_data [dict create] |
||||||
|
return |
||||||
|
} |
||||||
|
method reverse {} { |
||||||
|
set dictnew [dict create] |
||||||
|
foreach k [lreverse [dict keys $o_data]] { |
||||||
|
dict set dictnew $k [dict get $o_data $k] |
||||||
|
} |
||||||
|
set o_data $dictnew |
||||||
|
return |
||||||
|
} |
||||||
|
#review - cmd as list vs cmd as script? |
||||||
|
method map {cmd} { |
||||||
|
set seed [list] |
||||||
|
dict for {k v} $o_data { |
||||||
|
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||||
|
} |
||||||
|
return $seed |
||||||
|
} |
||||||
|
method objectmap {cmd} { |
||||||
|
set seed [list] |
||||||
|
dict for {k v} $o_data { |
||||||
|
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||||
|
} |
||||||
|
return $seed |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,424 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::assertion 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::assertion 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {assertion alternative to control::assert}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {per-namespace assertions with }] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::assertion] |
||||||
|
#[keywords module assertion assert debug] |
||||||
|
#[description] |
||||||
|
#[para] The punk::assertion library has the same semantics as Tcllib's control::assert library for the assert command itself. |
||||||
|
#[para] The main difference is the way in which assert is enabled/disabled in namespaces. |
||||||
|
#[para] Due to commands such as 'namespace path' - the assert command could be available in arbitrary namespaces unrelated by tree structure to namespaces where assert has been directly imported. |
||||||
|
#[para] punk::assertion::active 0|1 allows activating and deactivating assertions in any namespace where the assert command is available - but only affecting the activations state of the namespace in which it is called. |
||||||
|
#[para] If such a non-primary assertion namespace never had active set to 0 or 1 - then it will activate/deactivate when the namespace corresponding to the found assert command (primary) is activated/deactivated. |
||||||
|
#[para] Once marked active or inactive - such a non-primary namespace will no longer follow the primary |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::assertion |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::assertion |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::assertion::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::assertion::class}] |
||||||
|
#[para] class definitions |
||||||
|
if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
} |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#keep 2 namespaces for assertActive and assertInactive so there is introspection available via namespace origin |
||||||
|
tcl::namespace::eval punk::assertion::primary { |
||||||
|
#tcl::namespace::export {[a-z]*} |
||||||
|
tcl::namespace::export assertActive assertInactive |
||||||
|
proc assertActive {expr args} { |
||||||
|
|
||||||
|
set code [catch {uplevel 1 [list expr $expr]} res] |
||||||
|
if {$code} { |
||||||
|
return -code $code $res |
||||||
|
} |
||||||
|
if {![tcl::string::is boolean -strict $res]} { |
||||||
|
return -code error "invalid boolean expression: $expr" |
||||||
|
} |
||||||
|
|
||||||
|
if {$res} {return} |
||||||
|
|
||||||
|
if {[llength $args]} { |
||||||
|
#set msg "[join $args]" |
||||||
|
set msg "$args punk::assertion failed expr $expr" |
||||||
|
} else { |
||||||
|
set msg "punk::assertion failed expr $expr" ;#give a clue in the default msg about which assert lib is in use |
||||||
|
} |
||||||
|
|
||||||
|
upvar ::punk::assertion::CallbackCmd CallbackCmd |
||||||
|
# Might want to catch this |
||||||
|
tcl::namespace::eval :: $CallbackCmd [list $msg] |
||||||
|
} |
||||||
|
proc assertInactive args {} |
||||||
|
|
||||||
|
} |
||||||
|
tcl::namespace::eval punk::assertion::secondary { |
||||||
|
tcl::namespace::export * |
||||||
|
#we need to actually define these procs here, (not import then re-export) - or namespace origin will report the original source namespace - which isn't what we want. |
||||||
|
proc assertActive {expr args} [tcl::info::body ::punk::assertion::primary::assertActive] |
||||||
|
proc assertInactive args {} |
||||||
|
} |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::assertion { |
||||||
|
variable CallbackCmd [list return -code error] |
||||||
|
|
||||||
|
#puts --------AAA |
||||||
|
#*very* slow in safe interp - why? |
||||||
|
#tcl::namespace::import ::punk::assertion::primary::assertActive |
||||||
|
|
||||||
|
proc do_ns_import {} { |
||||||
|
uplevel 1 [list tcl::namespace::import ::punk::assertion::primary::assertActive] |
||||||
|
} |
||||||
|
do_ns_import |
||||||
|
#puts --------BBB |
||||||
|
rename assertActive assert |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
tcl::namespace::eval punk::assertion { |
||||||
|
tcl::namespace::export * |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::assertion}] |
||||||
|
#[para] Core API functions for punk::assertion |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
#proc sample1 {p1 n args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# #[para] Arguments: |
||||||
|
# # [list_begin arguments] |
||||||
|
# # [arg_def tring p1] A description of string argument p1. |
||||||
|
# # [arg_def integer n] A description of integer argument n. |
||||||
|
# # [list_end] |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
#like tcllib's control::assert - we are limited to the same callback for all namespaces. |
||||||
|
#review - a per namespace - or per assert command callback may be tricky to do performantly. |
||||||
|
#Would probably involve rewriting the proc body - otherwise we have a runtime penalty in the assert of looking it up. |
||||||
|
proc callback {args} { |
||||||
|
#set nscaller [uplevel 1 [list namespace current]] |
||||||
|
#set which_assert [namespace eval $nscaller {namespace which assert}] |
||||||
|
|
||||||
|
upvar ::punk::assertion::CallbackCmd cb |
||||||
|
set n [llength $args] |
||||||
|
if {$n > 1} { |
||||||
|
return -code error "wrong # args: should be\ |
||||||
|
\"[lindex [tcl::info::level 0] 0] ?command?\"" |
||||||
|
} |
||||||
|
if {$n} { |
||||||
|
set cb [lindex $args 0] |
||||||
|
return |
||||||
|
} |
||||||
|
return $cb |
||||||
|
} |
||||||
|
|
||||||
|
proc active {{on_off ""}} { |
||||||
|
set nscaller [uplevel 1 [list tcl::namespace::current]] |
||||||
|
set which_assert [tcl::namespace::eval $nscaller {tcl::namespace::which assert}] |
||||||
|
#puts "nscaller:'$nscaller'" |
||||||
|
#puts "which_assert: $which_assert" |
||||||
|
|
||||||
|
if {$on_off eq ""} { |
||||||
|
if {$which_assert eq ""} {return 0} |
||||||
|
set assertorigin [tcl::namespace::origin $which_assert] |
||||||
|
#puts "ns which assert: $which_assert" |
||||||
|
#puts "ns origin assert: $assertorigin" |
||||||
|
return [expr {"assertActive" eq [tcl::namespace::tail $assertorigin]}] |
||||||
|
} |
||||||
|
if {![tcl::string::is boolean -strict $on_off]} { |
||||||
|
error "invalid boolean value : $on_off" |
||||||
|
} else { |
||||||
|
set info_command [tcl::namespace::eval $nscaller {tcl::info::commands assert}] |
||||||
|
if {$on_off} { |
||||||
|
#Enable it in calling namespace |
||||||
|
if {"assert" eq $info_command} { |
||||||
|
#There is an assert command reachable - due to namespace path etc, it could be in another namespace entirely - (not necessarily in an ancestor namespace of the namespace's tree structure) |
||||||
|
if {$which_assert eq [punk::assertion::system::nsjoin ${nscaller} assert]} { |
||||||
|
tcl::namespace::eval $nscaller { |
||||||
|
set assertorigin [tcl::namespace::origin assert] |
||||||
|
set assertorigin_ns [punk::assertion::system::nsprefix $assertorigin] |
||||||
|
switch -- $assertorigin_ns { |
||||||
|
::punk::assertion { |
||||||
|
#original import - switch to primary origin |
||||||
|
rename assert {} |
||||||
|
tcl::namespace::import ::punk::assertion::primary::assertActive |
||||||
|
rename assertActive assert |
||||||
|
} |
||||||
|
::punk::assertion::primary - ::punk::assertion::secondary { |
||||||
|
#keep using from same origin ns |
||||||
|
rename assert {} |
||||||
|
tcl::namespace::import ${assertorigin_ns}::assertActive |
||||||
|
rename assertActive assert |
||||||
|
} |
||||||
|
default { |
||||||
|
error "The assert command in this namespace is not from punk::assertion package. Use the enable mechanism from the package associated with $assertorigin or remove the existing assert command and namespace import punk::assertion::assert" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
#assert is available, but isn't in the calling namespace - we should enable it in a way that is distinguishable from case where assert was explicitly imported to this namespace |
||||||
|
tcl::namespace::eval $nscaller { |
||||||
|
set assertorigin [tcl::namespace::origin assert] |
||||||
|
if {[tcl::string::match ::punk::assertion::* $assertorigin]} { |
||||||
|
tcl::namespace::import ::punk::assertion::secondary::assertActive |
||||||
|
rename assertActive assert |
||||||
|
} else { |
||||||
|
error "The reachable assert command at '$which_assert' is not from punk::assertion package. Import punk::assertion::assert - or use the enable mechanism from the package associated with $assertorigin" |
||||||
|
} |
||||||
|
} |
||||||
|
return 1 |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
#no assert command reachable |
||||||
|
puts stderr "no assert command visible from namespace '$nscaller' - use: namespace import ::punk::assertion::assert" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} else { |
||||||
|
#Disable |
||||||
|
if {"assert" eq $info_command} { |
||||||
|
if {$which_assert eq [punk::assertion::system::nsjoin ${nscaller} assert]} { |
||||||
|
#assert is present in callers NS |
||||||
|
tcl::namespace::eval $nscaller { |
||||||
|
set assertorigin [tcl::namespace::origin assert] |
||||||
|
set assertorigin_ns [punk::assertion::system::nsprefix $assertorigin] |
||||||
|
switch -glob -- $assertorigin_ns { |
||||||
|
::punk::assertion { |
||||||
|
#original import |
||||||
|
rename assert {} |
||||||
|
tcl::namespace::import punk::assertion::primary::assertInactive |
||||||
|
rename assertInactive assert |
||||||
|
} |
||||||
|
::punk::assertion::primary - ::punk::assertion::secondary { |
||||||
|
#keep using from same origin ns |
||||||
|
rename assert {} |
||||||
|
tcl::namespace::import ${assertorigin_ns}::assertInactive |
||||||
|
rename assertInactive assert |
||||||
|
} |
||||||
|
default { |
||||||
|
error "The assert command in this namespace is not from punk::assertion package. Use the disable mechanism from the package associated with $assertorigin or remove the existing assert command and namespace import punk::assertion::assert" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return 0 |
||||||
|
} else { |
||||||
|
#assert not present in callers NS - first install of secondary (if assert is from punk::assertion::*) |
||||||
|
tcl::namespace::eval $nscaller { |
||||||
|
set assertorigin [tcl::namespace::origin assert] |
||||||
|
set assertorigin_ns [punk::assertion::system::nsprefix $assertorigin] |
||||||
|
if {[tcl::string::match ::punk::assertion::* $assertorigin]} { |
||||||
|
tcl::namespace::import ::punk::assertion::secondary::assertInactive |
||||||
|
rename assertInactive assert |
||||||
|
} else { |
||||||
|
error "The reachable assert command at '$which_assert' is not from punk::assertion package. Import punk::assertion::assert - or use the enable mechanism from the package associated with $assertorigin" |
||||||
|
} |
||||||
|
} |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} else { |
||||||
|
#no assert command reachable |
||||||
|
#If caller is using assert in this namespace - they should have imported it, or ensured it was reachable via namespace path |
||||||
|
puts stderr "no assert command visible from namespace '$nscaller' - use: namespace import ::punk::assertion::assert" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::assertion ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::assertion::lib { |
||||||
|
tcl::namespace::export * |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::assertion::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::assertion::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
tcl::namespace::eval punk::assertion::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::assertion::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
#Maintenance - snarfed from punk::ns to reduce dependencies - punk::ns::nsprefix is the master version |
||||||
|
#nsprefix/nstail are string functions - they do not concern themselves with what namespaces are present in the system |
||||||
|
proc nsprefix {{nspath {}}} { |
||||||
|
#normalize the common case of :::: |
||||||
|
set nspath [tcl::string::map [list :::: ::] $nspath] |
||||||
|
set rawprefix [tcl::string::range $nspath 0 end-[tcl::string::length [nstail $nspath]]] |
||||||
|
if {$rawprefix eq "::"} { |
||||||
|
return $rawprefix |
||||||
|
} else { |
||||||
|
if {[tcl::string::match *:: $rawprefix]} { |
||||||
|
return [tcl::string::range $rawprefix 0 end-2] |
||||||
|
} else { |
||||||
|
return $rawprefix |
||||||
|
} |
||||||
|
#return [tcl::string::trimright $rawprefix :] |
||||||
|
} |
||||||
|
} |
||||||
|
#see also punk::ns - keep in sync |
||||||
|
proc nstail {nspath args} { |
||||||
|
#normalize the common case of :::: |
||||||
|
set nspath [tcl::string::map [list :::: ::] $nspath] |
||||||
|
set mapped [tcl::string::map [list :: \u0FFF] $nspath] |
||||||
|
set parts [split $mapped \u0FFF] |
||||||
|
|
||||||
|
set defaults [list -strict 0] |
||||||
|
set opts [tcl::dict::merge $defaults $args] |
||||||
|
set strict [tcl::dict::get $opts -strict] |
||||||
|
|
||||||
|
if {$strict} { |
||||||
|
foreach p $parts { |
||||||
|
if {[tcl::string::match :* $p]} { |
||||||
|
error "nstail unpaired colon ':' in $nspath" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
#e.g ::x::y:::z should return ":z" despite it being a bad idea for a command name. |
||||||
|
return [lindex $parts end] |
||||||
|
} |
||||||
|
proc nsjoin {prefix name} { |
||||||
|
if {[tcl::string::match ::* $name]} { |
||||||
|
if {"$prefix" ne ""} { |
||||||
|
error "nsjoin: won't join non-empty prefix to absolute namespace path '$name'" |
||||||
|
} |
||||||
|
return $name |
||||||
|
} |
||||||
|
if {"$prefix" eq "::"} { |
||||||
|
return ::$name |
||||||
|
} |
||||||
|
#if {"$name" eq ""} { |
||||||
|
# return $prefix |
||||||
|
#} |
||||||
|
#nsjoin ::x::y "" should return ::x::y:: - this is the correct fully qualified form used to call a command that is the empty string |
||||||
|
return ${prefix}::$name |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::assertion [tcl::namespace::eval punk::assertion { |
||||||
|
variable pkg punk::assertion |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,696 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::cap 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta description pkg capability register |
||||||
|
# Meta license BSD |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin punkshell_module_punk::cap 0 0.1.0] |
||||||
|
#[copyright "2023 JMNoble - BSD licensed"] |
||||||
|
#[titledesc {capability provider and handler plugin system}] |
||||||
|
#[moddesc {punk capabilities plugin system}] |
||||||
|
#[require punk::cap] |
||||||
|
#[description] |
||||||
|
#[keywords module capability plugin] |
||||||
|
#[section Overview] |
||||||
|
#[para]punk::cap provides management of named capabilities and the provider packages and handler packages that implement a pluggable capability. |
||||||
|
#[para]see also [uri https://core.tcl-lang.org/tcllib/doc/trunk/embedded/md/tcllib/files/modules/pluginmgr/pluginmgr.md {tcllib pluginmgr}] for an alternative which uses safe interpreters |
||||||
|
#[subsection Concepts] |
||||||
|
#[para]A [term capability] may be something like providing a folder of files, or just a data dictionary, and/or an API |
||||||
|
# |
||||||
|
#[para][term {capability handler}] - a package/namespace which may provide validation and standardised ways of looking up provider data |
||||||
|
# registered (or not) using register_capabilityname <capname> <capnamespace> |
||||||
|
# |
||||||
|
#[para][term {capability provider}] - a package which registers as providing one or more capablities. |
||||||
|
#[para]registered using register_package <pkg> <capabilitylist> |
||||||
|
#the capabilitylist is a list of 2-element lists where the first element is the capabilityname and the second element is a (possibly empty) dict of data relevant to that capability |
||||||
|
#A capabilityname may appear multiple times. ie a package may register that it provides the capability with multiple datasets. |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
package require oolib |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::cap { |
||||||
|
variable pkgcapsdeclared [tcl::dict::create] |
||||||
|
variable pkgcapsaccepted [tcl::dict::create] |
||||||
|
variable caps [tcl::dict::create] |
||||||
|
namespace eval class { |
||||||
|
if {[tcl::info::commands ::punk::cap::class::interface_caphandler.registry] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::cap::class}] |
||||||
|
#[para] class definitions |
||||||
|
#[list_begin itemized] [comment {- punk::cap::class groupings -}] |
||||||
|
# [item] |
||||||
|
# [para] [emph {handler_classes}] |
||||||
|
# [list_begin enumerated] |
||||||
|
|
||||||
|
oo::class create ::punk::cap::class::interface_caphandler.registry { |
||||||
|
#*** !doctools |
||||||
|
#[enum] CLASS [class interface_caphandler.registry] |
||||||
|
#[list_begin definitions] |
||||||
|
# [para] [emph METHODS] |
||||||
|
method pkg_register {pkg capname capdict fullcapabilitylist} { |
||||||
|
#*** !doctools |
||||||
|
#[call class::interface_caphandler.registry [method pkg_register] [arg pkg] [arg capname] [arg capdict] [arg fullcapabilitylist]] |
||||||
|
#handler may override and return 0 (indicating don't register)e.g if pkg capdict data wasn't valid |
||||||
|
#overridden handler must be able to handle multiple calls for same pkg - but it may return 1 or 0 as it wishes. |
||||||
|
return 1 ;#default to permit |
||||||
|
} |
||||||
|
method pkg_unregister {pkg} { |
||||||
|
#*** !doctools |
||||||
|
#[call class::interface_caphandler.registry [method pkg_unregister] [arg pkg]] |
||||||
|
return ;#unregistration return is ignored - review |
||||||
|
} |
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
} |
||||||
|
|
||||||
|
oo::class create ::punk::cap::class::interface_caphandler.sysapi { |
||||||
|
#*** !doctools |
||||||
|
#[enum] CLASS [class interface_caphandler.sysapi] |
||||||
|
#[list_begin definitions] |
||||||
|
# [para] [emph METHODS] |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
# [list_end] [comment {- end enumeration handler classes -}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
# [item] |
||||||
|
# [para] [emph {provider_classes}] |
||||||
|
# [list_begin enumerated] |
||||||
|
|
||||||
|
#Provider classes |
||||||
|
oo::class create ::punk::cap::class::interface_capprovider.registration { |
||||||
|
#*** !doctools |
||||||
|
# [enum] CLASS [class interface_cappprovider.registration] |
||||||
|
# [para]Your provider package will need to instantiate this object under a sub-namespace called [namespace capsystem] within your package namespace. |
||||||
|
# [para]If your package namespace is mypackages::providerpkg then the object command would be at mypackages::providerpkg::capsystem::capprovider.registration |
||||||
|
# [para]Example code for your provider package to evaluate within its namespace: |
||||||
|
# [example { |
||||||
|
#namespace eval capsystem { |
||||||
|
# if {[info commands capprovider.registration] eq ""} { |
||||||
|
# punk::cap::class::interface_capprovider.registration create capprovider.registration |
||||||
|
# oo::objdefine capprovider.registration { |
||||||
|
# method get_declarations {} { |
||||||
|
# set decls [list] |
||||||
|
# lappend decls [list punk.templates {relpath ../templates}] |
||||||
|
# lappend decls [list another_capability_name {somekey blah key2 etc}] |
||||||
|
# return $decls |
||||||
|
# } |
||||||
|
# } |
||||||
|
# } |
||||||
|
#} |
||||||
|
#}] |
||||||
|
#[para] The above example declares that your package can be registered as a provider for the capabilities named 'punk.templates' and 'another_capability_name' |
||||||
|
# [list_begin definitions] |
||||||
|
# [para] [emph METHODS] |
||||||
|
method get_declarations {} { |
||||||
|
#*** |
||||||
|
#[call class::interface_capprovider.registration [method get_declarations]] |
||||||
|
#[para] This method must be overridden by your provider using oo::objdefine cappprovider.registration as in the example above. |
||||||
|
# There must be at least one 2-element list in the result for the provider to be registerable. |
||||||
|
#[para]The first element of the list is the capabilityname - which can be custom to your provider/handler packages - or a well-known name that other authors may use/implement. |
||||||
|
#[para]The second element is a dictionary of keys specific to the capability being implemented. It may be empty if the any potential capability handlers for the named capability don't require registration data. |
||||||
|
error "interface_capprovider.registration not implemented by provider" |
||||||
|
} |
||||||
|
#*** !doctools |
||||||
|
# [list_end] |
||||||
|
} |
||||||
|
|
||||||
|
oo::class create ::punk::cap::class::interface_capprovider.provider { |
||||||
|
#*** !doctools |
||||||
|
# [enum] CLASS [class interface_capprovider.provider] |
||||||
|
# [para] Your provider package will need to instantiate this directly under it's own namespace with the command name of [emph {provider}] |
||||||
|
# [example { |
||||||
|
# namespace eval mypackages::providerpkg { |
||||||
|
# punk::cap::class::interface_capprovider.provider create provider mypackages::providerpkg |
||||||
|
# } |
||||||
|
# }] |
||||||
|
# [list_begin definitions] |
||||||
|
# [para] [emph METHODS] |
||||||
|
variable provider_pkg |
||||||
|
variable registrationobj |
||||||
|
constructor {providerpkg} { |
||||||
|
#*** !doctools |
||||||
|
#[call class::interface_capprovider.provider [method constructor] [arg providerpkg]] |
||||||
|
variable provider_pkg |
||||||
|
if {$providerpkg in {"" "::"}} { |
||||||
|
error "interface_capprovider.provider constructor error. Invalid provider '$providerpkg'" |
||||||
|
} |
||||||
|
if {![namespace exists ::$providerpkg]} { |
||||||
|
error "interface_capprovider.provider constructor error. Invalid provider '$providerpkg' - matching namespace not found" |
||||||
|
} |
||||||
|
|
||||||
|
set registrationobj ::${providerpkg}::capsystem::capprovider.registration |
||||||
|
if {[tcl::info::commands $registrationobj] eq ""} { |
||||||
|
error "capprovider.provider constructor error. Missing capprovider.registration interface at '$obj' (command not found) interface_capprovider.regstration instantiation must precede interface_capprovider.provider" |
||||||
|
} |
||||||
|
|
||||||
|
#review - what are we trying to achieve here? |
||||||
|
set provider_pkg [tcl::string::trim $providerpkg ""] |
||||||
|
} |
||||||
|
method register {{capabilityname_glob *}} { |
||||||
|
#*** !doctools |
||||||
|
#[comment {- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---}] |
||||||
|
#[call class::interface_capprovider.provider [method register] [opt capabilityname_glob]] |
||||||
|
# |
||||||
|
#[para]This is the mechanism by which a user of your provider package will register your package as a provider of the capability named. |
||||||
|
# |
||||||
|
#[para]A user of your provider may elect to register all your declared capabilities: |
||||||
|
#[example { |
||||||
|
# package require mypackages::providerpkg |
||||||
|
# mypackages::providerpkg::provider register * |
||||||
|
#}] |
||||||
|
#[para] Or a specific capability may be registered: |
||||||
|
#[example { |
||||||
|
# package require mypackages::providerpkg |
||||||
|
# mypackages::providerpkg::provider register another_capability_name |
||||||
|
#}] |
||||||
|
# |
||||||
|
variable provider_pkg |
||||||
|
set all_decls [$registrationobj get_declarations] |
||||||
|
set register_decls [lsearch -all -inline -index 0 $all_decls $capabilityname_glob] |
||||||
|
punk::cap::register_package $provider_pkg $register_decls |
||||||
|
} |
||||||
|
method capabilities {} { |
||||||
|
#*** !doctools |
||||||
|
#[comment {- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---}] |
||||||
|
#[call class::interface_capprovider.provider [method capabilities]] |
||||||
|
#[para] return a list of capabilities supported by this provider package |
||||||
|
variable provider_pkg |
||||||
|
variable registrationobj |
||||||
|
|
||||||
|
set capabilities [list] |
||||||
|
set decls [$registrationobj get_declarations] |
||||||
|
foreach decl $decls { |
||||||
|
lassign $decl capname capdict |
||||||
|
if {$capname ni $capabilities} { |
||||||
|
lappend capabilities $capname |
||||||
|
} |
||||||
|
} |
||||||
|
return $capabilities |
||||||
|
} |
||||||
|
#*** !doctools |
||||||
|
# [list_end] [comment {- end class definitions -}] |
||||||
|
} |
||||||
|
#*** !doctools |
||||||
|
# [list_end] [comment {- end enumeration provider_classes }] |
||||||
|
#[list_end] [comment {- end itemized list punk::cap::class groupings -}] |
||||||
|
} |
||||||
|
} ;# end namespace class |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::cap}] |
||||||
|
#[para] Main punk::cap API for client programs interested in using capability handler packages and associated (registered) provider packages |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#Not all capability names have to be registered. |
||||||
|
#A package registering as a provider using register_package can include capabilitynames in it's capabilitylist which have no associated handler. |
||||||
|
#such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname. |
||||||
|
#we allow registering a capability with an empty handler (capnamespace) - but this means another handler could be registered later. |
||||||
|
proc register_capabilityname {capname capnamespace} { |
||||||
|
#puts stderr "REGISTER_CAPABILITYNAME $capname $capnamespace" |
||||||
|
variable caps |
||||||
|
variable pkgcapsdeclared |
||||||
|
variable pkgcapsaccepted |
||||||
|
if {$capnamespace ne ""} { |
||||||
|
#normalize with leading :: in case caller passed in package name rather than fully qualified namespace |
||||||
|
if {![tcl::string::match ::* $capnamespace]} { |
||||||
|
set capnamespace ::$capnamespace |
||||||
|
} |
||||||
|
} |
||||||
|
#allow register of existing capname iff there is no current handler |
||||||
|
#as handlers can be used to validate during provider registration - ideally handlers should be registered before any pkgs call register_package |
||||||
|
#we allow loading a handler later though - but will need to validate existing data from pkgs that have already registered as providers |
||||||
|
if {[set hdlr [capability_get_handler $capname]] ne ""} { |
||||||
|
puts stderr "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" |
||||||
|
return |
||||||
|
} |
||||||
|
#assertion: capnamespace may or may not be empty string, capname may or may not already exist in caps dict, caps $capname providers may have existing entries. |
||||||
|
tcl::dict::set caps $capname handler $capnamespace |
||||||
|
if {![tcl::dict::exists $caps $capname providers]} { |
||||||
|
tcl::dict::set caps $capname providers [list] |
||||||
|
} |
||||||
|
if {[llength [set providers [tcl::dict::get $caps $capname providers]]]} { |
||||||
|
#some provider(s) were in place before the handler was registered |
||||||
|
if {[set capreg [punk::cap::capsystem::get_caphandler_registry $capname]] ne ""} { |
||||||
|
foreach pkg $providers { |
||||||
|
set fullcapabilitylist [tcl::dict::get $pkgcapsdeclared $pkg] |
||||||
|
set capname_capabilitylist [lsearch -all -inline -index 0 $fullcapabilitylist $capname] |
||||||
|
foreach capspec $capname_capabilitylist { |
||||||
|
lassign $capspec cn capdict |
||||||
|
#if {$cn ne $capname} { |
||||||
|
# continue |
||||||
|
#} |
||||||
|
if {[catch {$capreg pkg_register $pkg $capdict $fullcapabilitylist} do_register]} { |
||||||
|
puts stderr "punk::cap::register_capabilityname '$capname' '$capnamespace' failed to register provider package '$pkg' - possible error in handler or provider" |
||||||
|
puts stderr "error message:" |
||||||
|
puts stderr $do_register |
||||||
|
set do_register 0 |
||||||
|
} |
||||||
|
|
||||||
|
set list_accepted [tcl::dict::get $pkgcapsaccepted $pkg] |
||||||
|
if {$do_register} { |
||||||
|
if {$capspec ni $list_accepted} { |
||||||
|
tcl::dict::lappend pkgcapsaccepted $pkg $capspec |
||||||
|
} |
||||||
|
} else { |
||||||
|
set posn [lsearch $list_accepted $capspec] |
||||||
|
if {$posn >=0} { |
||||||
|
set list_accepted [lreplace $list_accepted $posn $posn] |
||||||
|
tcl::dict::set pkgcapsaccepted $pkg $list_accepted |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
#check if any accepted for this cap and remove from caps as necessary |
||||||
|
set count 0 |
||||||
|
foreach accepted_capspec [tcl::dict::get $pkgcapsaccepted $pkg] { |
||||||
|
if {[lindex $accepted_capspec 0] eq $capname} { |
||||||
|
incr count |
||||||
|
} |
||||||
|
} |
||||||
|
if {$count == 0} { |
||||||
|
set pkgposn [lsearch $providers $pkg] |
||||||
|
if {$pkgposn >= 0} { |
||||||
|
set updated_providers [lreplace $providers $posn $posn] |
||||||
|
tcl::dict::set caps $capname providers $updated_providers |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
proc capability_exists {capname} { |
||||||
|
#*** !doctools |
||||||
|
# [call [fun capability_exists] [arg capname]] |
||||||
|
# Return a boolean indicating if the named capability exists (0|1) |
||||||
|
variable caps |
||||||
|
return [tcl::dict::exists $caps $capname] |
||||||
|
} |
||||||
|
proc capability_has_handler {capname} { |
||||||
|
#*** !doctools |
||||||
|
# [call [fun capability_has_handler] [arg capname]] |
||||||
|
#Return a boolean indicating if the named capability has a handler package installed (0|1) |
||||||
|
variable caps |
||||||
|
return [expr {[tcl::dict::exists $caps $capname handler] && [tcl::dict::get $caps $capname handler] ne ""}] |
||||||
|
} |
||||||
|
proc capability_get_handler {capname} { |
||||||
|
#*** !doctools |
||||||
|
# [call [fun capability_get_handler] [arg capname]] |
||||||
|
#Return the base namespace of the active handler package for the named capability. |
||||||
|
#[para] The base namespace for a handler will always be the package name, but prefixed with :: |
||||||
|
variable caps |
||||||
|
if {[tcl::dict::exists $caps $capname]} { |
||||||
|
return [tcl::dict::get $caps $capname handler] |
||||||
|
} |
||||||
|
return "" |
||||||
|
} |
||||||
|
proc call_handler {capname args} { |
||||||
|
if {[set handler [capability_get_handler $capname]] eq ""} { |
||||||
|
error "punk::cap::call_handler $capname $args - no handler registered for capability $capname" |
||||||
|
} |
||||||
|
set obj ${handler}::api_$capname |
||||||
|
$obj [lindex $args 0] {*}[lrange $args 1 end] |
||||||
|
} |
||||||
|
proc get_providers {capname} { |
||||||
|
variable caps |
||||||
|
if {[tcl::dict::exists $caps $capname]} { |
||||||
|
return [tcl::dict::get $caps $capname providers] |
||||||
|
} |
||||||
|
return [list] |
||||||
|
} |
||||||
|
|
||||||
|
#register package with arbitrary capnames from capabilitylist |
||||||
|
#The registered pkg is a module that provides some service to that capname. Possibly just data members or possibly an implementation of an API, that the capability will use. |
||||||
|
proc register_package {pkg capabilitylist args} { |
||||||
|
variable pkgcapsdeclared |
||||||
|
variable pkgcapsaccepted |
||||||
|
variable caps |
||||||
|
set opts [dict create\ |
||||||
|
-nowarnings false |
||||||
|
] |
||||||
|
foreach {k v} $args { |
||||||
|
switch -- $k { |
||||||
|
-nowarnings { |
||||||
|
tcl::dict::set opts $k $v |
||||||
|
} |
||||||
|
default { |
||||||
|
error "Unrecognized option $k. Known options [tcl::dict::keys $opts]" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set warnings [expr {! [tcl::dict::get $opts -nowarnings]}] |
||||||
|
|
||||||
|
if {[tcl::string::match ::* $pkg]} { |
||||||
|
set pkg [tcl::string::range $pkg 2 end] |
||||||
|
} |
||||||
|
if {[tcl::dict::exists $pkgcapsaccepted $pkg]} { |
||||||
|
set pkg_already_accepted [tcl::dict::get $pkgcapsaccepted $pkg] |
||||||
|
} else { |
||||||
|
set pkg_already_accepted [list] |
||||||
|
} |
||||||
|
package require $pkg |
||||||
|
set providerapi ::${pkg}::provider |
||||||
|
if {[tcl::info::commands $providerapi] eq ""} { |
||||||
|
error "register_package error. pkg '$pkg' doesn't seem to be a punk::cap capability provider (no object found at $providerapi)" |
||||||
|
} |
||||||
|
set defined_caps [$providerapi capabilities] |
||||||
|
#for each capability |
||||||
|
# - ensure 1st element is a single word |
||||||
|
# - ensure that if 2nd element (capdict) is present - it is dict shaped |
||||||
|
set capabilitylist_count [llength $capabilitylist] |
||||||
|
set accepted_count 0 |
||||||
|
set errorlist [list];# list of dicts |
||||||
|
set warninglist [list] |
||||||
|
foreach capspec $capabilitylist { |
||||||
|
lassign $capspec capname capdict |
||||||
|
|
||||||
|
if {$warnings} { |
||||||
|
if {$capname ni $defined_caps} { |
||||||
|
puts stderr "WARNING: pkg '$pkg' doesn't declare support for capability '$capname'." |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $capname] !=1} { |
||||||
|
puts stderr "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$capspec'" |
||||||
|
set reason "First element of capspec not a single-word name" |
||||||
|
lappend errorlist [tcl::dict::create msg $reason capspec $capspec] |
||||||
|
continue |
||||||
|
} |
||||||
|
if {[expr {[llength $capdict] %2 != 0}]} { |
||||||
|
puts stderr "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$capspec'" |
||||||
|
set reason "The second element of the capspec isn't a valid dict" |
||||||
|
lappend errorlist [tcl::dict::create msg $reason capspec $capspec] |
||||||
|
continue |
||||||
|
} |
||||||
|
if {$capspec in $pkg_already_accepted} { |
||||||
|
#review - multiple handlers? if so - will need to record which handler(s) accepted the capspec |
||||||
|
if {$warnings} { |
||||||
|
puts stderr "WARNING: register_package pkg $pkg already has capspec marked as accepted: $capspec" |
||||||
|
} |
||||||
|
lappend warninglist [tcl::dict::create msg "pkg $pkg already has this capspec marked as accepted" capspec $capspec] |
||||||
|
continue |
||||||
|
} |
||||||
|
if {[tcl::dict::exists $caps $capname]} { |
||||||
|
set cap_pkgs [tcl::dict::get $caps $capname providers] |
||||||
|
} else { |
||||||
|
dict set caps $capname [tcl::dict::create handler "" providers [list]] |
||||||
|
set cap_pkgs [list] |
||||||
|
} |
||||||
|
#todo - if there's a caphandler - call it's init/validation callback for the pkg |
||||||
|
set do_register 1 ;#default assumption unless vetoed by handler |
||||||
|
if {[set capreg [punk::cap::capsystem::get_caphandler_registry $capname]] ne ""} { |
||||||
|
#Note that the interface_caphandler.registry instance must be able to handle multiple calls for same pkg |
||||||
|
set do_register [$capreg pkg_register $pkg $capname $capdict $capabilitylist] |
||||||
|
} |
||||||
|
if {$do_register} { |
||||||
|
if {$pkg ni $cap_pkgs} { |
||||||
|
lappend cap_pkgs $pkg |
||||||
|
tcl::dict::set caps $capname providers $cap_pkgs |
||||||
|
} |
||||||
|
tcl::dict::lappend pkgcapsaccepted $pkg $capspec ;#if pkg is being registered prior to handler-registration - the handler may undo this entry |
||||||
|
} |
||||||
|
} |
||||||
|
#another call to register_pkg with same pkg may have been made (most likely with different capname) so we must append - but check not already present |
||||||
|
#dict lappend pkgcapsdeclared $pkg $capabilitylist |
||||||
|
if {[tcl::dict::exists $pkgcapsdeclared $pkg]} { |
||||||
|
#review - untested |
||||||
|
set mergecapspecs [tcl::dict::get $pkgcapsdeclared $pkg] |
||||||
|
foreach spec $capabilitylist { |
||||||
|
if {$spec ni $mergecapspecs} { |
||||||
|
lappend mergecapspecs $spec |
||||||
|
} |
||||||
|
} |
||||||
|
tcl::dict::set pkgcapsdeclared $pkg $mergecapspecs |
||||||
|
} else { |
||||||
|
tcl::dict::set pkgcapsdeclared $pkg $capabilitylist |
||||||
|
} |
||||||
|
set resultdict [list num_capabilities $capabilitylist_count num_accepted $accepted_count] |
||||||
|
if {[llength $errorlist]} { |
||||||
|
tcl::dict::set resultdict errors $errorlist |
||||||
|
} |
||||||
|
if {[llength $warninglist]} { |
||||||
|
tcl::dict::set resultdict warnings $warninglist |
||||||
|
} |
||||||
|
return $resultdict |
||||||
|
} |
||||||
|
|
||||||
|
#todo! |
||||||
|
proc unregister_package {pkg {capname *}} { |
||||||
|
variable pkgcapsdeclared |
||||||
|
variable caps |
||||||
|
if {[string match ::* $pkg]} { |
||||||
|
set pkg [string range $pkg 2 end] |
||||||
|
} |
||||||
|
if {[dict exists $pkgcapsdeclared $pkg]} { |
||||||
|
#remove corresponding entries in caps |
||||||
|
set capabilitylist [dict get $pkgcapsdeclared $pkg] |
||||||
|
foreach c $capabilitylist { |
||||||
|
set do_unregister 1 |
||||||
|
lassign $c capname _capdict |
||||||
|
set cap_info [dict get $caps $capname] |
||||||
|
set pkglist [dict get $cap_info providers] |
||||||
|
set posn [lsearch $pkglist $pkg] |
||||||
|
if {$posn >= 0} { |
||||||
|
if {[set capreg [punk::cap::capsystem::get_caphandler_registry $capname]] ne ""} { |
||||||
|
#review |
||||||
|
# it seems not useful to allow the callback to block this unregister action |
||||||
|
#the pkg may have multiple datasets for each capname so callback will only be called for first dataset we encounter |
||||||
|
#vetoing unregister would make this more complex for no particular advantage |
||||||
|
#if per dataset deregistration required this should probably be a separate thing |
||||||
|
$capreg pkg_unregister $pkg $capname |
||||||
|
} |
||||||
|
set pkglist [lreplace $pkglist $posn $posn] |
||||||
|
dict set caps $capname providers $pkglist |
||||||
|
} |
||||||
|
} |
||||||
|
#delete the main registration record |
||||||
|
dict unset pkgcapsdeclared $pkg |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc pkgcap {pkg {capsearch}} { |
||||||
|
variable pkgcapsdeclared |
||||||
|
variable pkgcapsaccepted |
||||||
|
if {[string match ::* $pkg]} { |
||||||
|
set pkg [string range $pkg 2 end] |
||||||
|
} |
||||||
|
if {[dict exists $pkgcapsdeclared $pkg]} { |
||||||
|
set accepted "" |
||||||
|
if {[dict exists $pkgcapsaccepted $pkg]} { |
||||||
|
set accepted [lsearch -all -inline -glob -index 0 [dict get $pkgcapsaccepted $pkg] $capsearch] |
||||||
|
} |
||||||
|
return [dict create declared [lsearch -all -inline -glob -index 0 [dict get $pkgcapsdeclared $pkg] $capsearch] accepted $accepted] |
||||||
|
} else { |
||||||
|
return |
||||||
|
} |
||||||
|
} |
||||||
|
proc pkgcaps {} { |
||||||
|
variable pkgcapsdeclared |
||||||
|
variable pkgcapsaccepted |
||||||
|
set result [dict create] |
||||||
|
foreach {pkg capsdeclared} $pkgcapsdeclared { |
||||||
|
set accepted "" |
||||||
|
if {[dict exists $pkgcapsaccepted $pkg]} { |
||||||
|
set accepted [dict get $pkgcapsaccepted $pkg] |
||||||
|
} |
||||||
|
dict set result $pkg declared $capsdeclared |
||||||
|
dict set result $pkg accepted $accepted |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
proc capability {capname} { |
||||||
|
variable caps |
||||||
|
if {[dict exists $caps $capname]} { |
||||||
|
return [dict get $caps $capname] |
||||||
|
} |
||||||
|
return "" |
||||||
|
} |
||||||
|
proc capabilities {{glob *}} { |
||||||
|
variable caps |
||||||
|
set capnames [lsort [dict keys $caps $glob]] |
||||||
|
set cap_list [list] |
||||||
|
foreach capname $capnames { |
||||||
|
lappend cap_list [list $capname [dict get $caps $capname]] |
||||||
|
} |
||||||
|
return $cap_list |
||||||
|
} |
||||||
|
|
||||||
|
proc capabilitynames {{glob *}} { |
||||||
|
variable caps |
||||||
|
return [lsort [dict keys $caps $glob]] |
||||||
|
} |
||||||
|
#return only those capnames which have at least one provider |
||||||
|
proc capabilitynames_provided {{glob *}} { |
||||||
|
variable caps |
||||||
|
set keys [lsort [dict keys $caps $glob]] |
||||||
|
set cap_list [list] |
||||||
|
foreach k $keys { |
||||||
|
if {[llength [dict get $caps $k providers]] > 0} { |
||||||
|
lappend cap_list $k |
||||||
|
} |
||||||
|
} |
||||||
|
return $cap_list |
||||||
|
} |
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {- end definitions for namespace punk::cap -}] |
||||||
|
|
||||||
|
namespace eval advanced { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::cap::advanced}] |
||||||
|
#[para] punk::cap::advanced API. Functions here are generally not the preferred way to interact with punk::cap. |
||||||
|
#[para] In some cases they may allow interaction in less safe ways or may allow use of features that are unavailable in the base namespace. |
||||||
|
#[para] Some functions are here because they are only marginally or rarely useful, and they are here to keep the base API simple. |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
proc promote_provider {pkg} { |
||||||
|
#*** !doctools |
||||||
|
# [call advanced::[fun promote_provider] [arg pkg]] |
||||||
|
#[para]Move the named provider package to the preferred end of the list (tail). |
||||||
|
#[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. |
||||||
|
#[para] |
||||||
|
#[para] promote/demote doesn't always make a lot of sense .. should preferably be configurable per capapbility for multicap provider pkgs |
||||||
|
#[para]The idea is to provide a crude way to preference/depreference packages independently of order the packages were loaded |
||||||
|
#e.g a caller or cap-handler can ascribe some meaning to the order of the 'providers' key returned from punk::cap::capabilities <capname> |
||||||
|
#[para]The order of providers will be the order the packages were loaded & registered |
||||||
|
#[para]the naming: "promote vs demote" operates on a latest-package-in-list has higher preference assumption (matching last pkg loaded) |
||||||
|
#[para]Each capability handler could and should implement specific preferencing methods within its own API if finer control needed. |
||||||
|
#In some cases the preference/loading order may be inapplicable/irrelevant to a particular capability anyway. |
||||||
|
#[para]As this is just a basic mechanism, which can't support independent per-cap preferencing for multi-cap packages - |
||||||
|
# it only allows putting the pkgs to the head or tail of the lists. |
||||||
|
#[para]Whether particular caps or users of caps do anything with this ordering is dependent on the cap-handler and/or calling code. |
||||||
|
variable pkgcapsdeclared |
||||||
|
variable caps |
||||||
|
if {[string match ::* $pkg]} { |
||||||
|
set pkg [string range $pkg 2 end] |
||||||
|
} |
||||||
|
if {![dict exists $pkgcapsdeclared $pkg]} { |
||||||
|
error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" |
||||||
|
} |
||||||
|
if {[dict size $pkgcapsdeclared] > 1} { |
||||||
|
set pkginfo [dict get $pkgcapsdeclared $pkg] |
||||||
|
#remove and re-add at end of dict |
||||||
|
dict unset pkgcapsdeclared $pkg |
||||||
|
dict set pkgcapsdeclared $pkg $pkginfo |
||||||
|
dict for {cap cap_info} $caps { |
||||||
|
set cap_pkgs [dict get $cap_info providers] |
||||||
|
if {$pkg in $cap_pkgs} { |
||||||
|
set posn [lsearch $cap_pkgs $pkg] |
||||||
|
if {$posn >=0} { |
||||||
|
#rewrite package list with pkg at tail of list for this capability |
||||||
|
set cap_pkgs [lreplace $cap_pkgs $posn $posn] |
||||||
|
lappend cap_pkgs $pkg |
||||||
|
dict set caps $cap providers $cap_pkgs |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
proc demote_provider {pkg} { |
||||||
|
#*** !doctools |
||||||
|
# [call advanced::[fun demote_provider] [arg pkg]] |
||||||
|
#[para]Move the named provider package to the preferred end of the list (tail). |
||||||
|
#[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. |
||||||
|
variable pkgcapsdeclared |
||||||
|
variable caps |
||||||
|
if {[string match ::* $pkg]} { |
||||||
|
set pkg [string range $pkg 2 end] |
||||||
|
} |
||||||
|
if {![dict exists $pkgcapsdeclared $pkg]} { |
||||||
|
error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" |
||||||
|
} |
||||||
|
if {[dict size $pkgcapsdeclared] > 1} { |
||||||
|
set pkginfo [dict get $pkgcapsdeclared $pkg] |
||||||
|
#remove and re-add at start of dict |
||||||
|
dict unset pkgcapsdeclared $pkg |
||||||
|
dict set pkgcapsdeclared $pkg $pkginfo |
||||||
|
set pkgcapsdeclared [dict merge [dict create $pkg $pkginfo] $pkgcapsdeclared] |
||||||
|
dict for {cap cap_info} $caps { |
||||||
|
set cap_pkgs [dict get $cap_info providers] |
||||||
|
if {$pkg in $cap_pkgs} { |
||||||
|
set posn [lsearch $cap_pkgs $pkg] |
||||||
|
if {$posn >=0} { |
||||||
|
#rewrite package list with pkg at head of list for this capability |
||||||
|
set cap_pkgs [lreplace $cap_pkgs $posn $posn] |
||||||
|
set cap_pkgs [list $pkg {*}$cap_pkgs] |
||||||
|
dict set caps $cap providers $cap_pkgs |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
|
||||||
|
namespace eval capsystem { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::cap::capsystem}] |
||||||
|
#[para] Internal functions used to communicate between punk::cap and capability handlers |
||||||
|
#[list_begin definitions] |
||||||
|
proc get_caphandler_registry {capname} { |
||||||
|
set ns [::punk::cap::capability_get_handler $capname]::capsystem |
||||||
|
if {[namespace exists ${ns}]} { |
||||||
|
if {[info command ${ns}::caphandler.registry] ne ""} { |
||||||
|
if {[info object isa object ${ns}::caphandler.registry]} { |
||||||
|
return ${ns}::caphandler.registry |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return "" |
||||||
|
} |
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::cap [namespace eval punk::cap { |
||||||
|
variable version |
||||||
|
variable pkg punk::cap |
||||||
|
set version 0.1.0 |
||||||
|
variable README.md [string map [list %pkg% $pkg %ver% $version] { |
||||||
|
# punk capabilities system |
||||||
|
## pkg: %pkg% version: %ver% |
||||||
|
|
||||||
|
punk::cap base namespace |
||||||
|
}] |
||||||
|
return $version |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
@ -0,0 +1,52 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::cap::handlers::caphandler 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::cap::handlers::caphandler { |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::cap::handlers::caphandler [namespace eval punk::cap::handlers::caphandler { |
||||||
|
variable pkg punk::cap::handlers::caphandler |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
@ -0,0 +1,52 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::cap::handlers::scriptlibs 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::cap::handlers::scriptlibs { |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::cap::handlers::scriptlibs [namespace eval punk::cap::handlers::scriptlibs { |
||||||
|
variable pkg punk::cap::handlers::scriptlibs |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
@ -0,0 +1,766 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::cap::handlers::templates 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
package require punk::repo |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#register using: |
||||||
|
# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates |
||||||
|
|
||||||
|
#By convention and for consistency, we don't register here during package loading - but require the calling app to do it. |
||||||
|
# (even if it tends to be done immediately after package require anyway) |
||||||
|
# registering capability handlers can involve validating existing provider data and is best done explicitly as required. |
||||||
|
# It is also possible for a capability handler to be registered to handle more than one capabilityname |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::cap::handlers::templates { |
||||||
|
namespace eval capsystem { |
||||||
|
#interfaces for punk::cap to call into |
||||||
|
if {[info commands caphandler.registry] eq ""} { |
||||||
|
punk::cap::class::interface_caphandler.registry create caphandler.registry |
||||||
|
oo::objdefine caphandler.registry { |
||||||
|
method pkg_register {pkg capname capdict caplist} { |
||||||
|
#caplist may not be complete set - which somewhat reduces its utility here regarding any decisions based on the context of this capname/capdict (review - remove this arg?) |
||||||
|
|
||||||
|
# -- --- --- --- --- --- --- ---- --- |
||||||
|
# validation of capdict |
||||||
|
# -- --- --- --- --- --- --- ---- --- |
||||||
|
if {![dict exists $capdict vendor]} { |
||||||
|
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing the 'vendor' key" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
if {![dict exists $capdict path] || ![dict exists $capdict pathtype]} { |
||||||
|
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing the 'path' or 'pathtype' key" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
set pathtype [dict get $capdict pathtype] |
||||||
|
set vendor [dict get $capdict vendor] |
||||||
|
set known_pathtypes [list adhoc currentproject_multivendor currentproject shellproject_multivendor shellproject module absolute] |
||||||
|
if {$pathtype ni $known_pathtypes} { |
||||||
|
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but 'pathtype' value '$pathtype' is not recognised. Known type: $known_pathtypes" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
|
||||||
|
set path [dict get $capdict path] |
||||||
|
|
||||||
|
set cname [string map {. _} $capname] |
||||||
|
|
||||||
|
set multivendor_package_whitelist [list punk::mix::templates] |
||||||
|
|
||||||
|
|
||||||
|
#for template pathtype module & shellproject* we can resolve whether it's within a project at registration time and store the projectbase rather than rechecking it each time the templates handler api is called |
||||||
|
#for template pathtype absolute - we can do the same. |
||||||
|
#There is a small chance for a long-running shell that a project is later created which makes the absolute path within a project - but it seems an unlikely case, and probably won't surprise the user that they need to relaunch the shell or reload the capsystem to see the change. |
||||||
|
|
||||||
|
#adhoc and currentproject* paths are relative to cwd - so no projectbase information can be stored at registration time. |
||||||
|
#not all template item types will need projectbase information - as the item data may be self-contained within the template structure - |
||||||
|
#but project_layout will need it - or at least need to know if there is no project - because project_layout data is never stored in the template folder structure directly. |
||||||
|
switch -- $pathtype { |
||||||
|
adhoc { |
||||||
|
if {[file pathtype $path] ne "relative"} { |
||||||
|
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
set extended_capdict $capdict |
||||||
|
dict set extended_capdict vendor $vendor |
||||||
|
} |
||||||
|
module { |
||||||
|
set provide_statement [package ifneeded $pkg [package require $pkg]] |
||||||
|
set tmfile [lindex $provide_statement end] |
||||||
|
if {[interp issafe]} { |
||||||
|
#default safe interp can't use file exists/normalize etc.. but safe interp may have a policy/alias set allowing file access to certain paths - so test if file exists is usable |
||||||
|
if {[catch {file exists $tmfile} tm_exists]} { |
||||||
|
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING (expected in most safe interps) - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" |
||||||
|
flush stderr |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} else { |
||||||
|
set tm_exists [file exists $tmfile] |
||||||
|
} |
||||||
|
if {![file exists $tmfile]} { |
||||||
|
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" |
||||||
|
flush stderr |
||||||
|
return 0 |
||||||
|
} |
||||||
|
|
||||||
|
if {[file pathtype $path] ne "relative"} { |
||||||
|
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path" |
||||||
|
} |
||||||
|
set tmfolder [file dirname $tmfile] |
||||||
|
#todo - handle wrapped or unwrapped tarjar files - in which case we have to adjust tmfolder appropriately |
||||||
|
#set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder |
||||||
|
|
||||||
|
set projectinfo [punk::repo::find_repos $tmfolder] |
||||||
|
set projectbase [dict get $projectinfo closest] |
||||||
|
#store the projectbase even if it's empty string |
||||||
|
set extended_capdict $capdict |
||||||
|
set resolved_path [file join $tmfolder $path] |
||||||
|
dict set extended_capdict resolved_path $resolved_path |
||||||
|
dict set extended_capdict projectbase $projectbase |
||||||
|
} |
||||||
|
currentproject_multivendor { |
||||||
|
#currently only intended for punk::mix::templates - review if 3rd party _multivendor trees even make sense |
||||||
|
if {$pkg ni $multivendor_package_whitelist} { |
||||||
|
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but package is not in whitelist $multivendor_package_whitelist - 3rd party _multivendor tree not supported" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
if {[file pathtype $path] ne "relative"} { |
||||||
|
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
|
||||||
|
set extended_capdict $capdict |
||||||
|
dict set extended_capdict vendor $vendor ;#vendor key still required.. controlling vendor? |
||||||
|
} |
||||||
|
currentproject { |
||||||
|
if {[file pathtype $path] ne "relative"} { |
||||||
|
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
#verify that the relative path is within the relative path of a currentproject_multivendor tree |
||||||
|
#todo - api for the _multivendor tree controlling package to validate |
||||||
|
|
||||||
|
|
||||||
|
set extended_capdict $capdict |
||||||
|
dict set extended_capdict vendor $vendor |
||||||
|
} |
||||||
|
shellproject { |
||||||
|
if {[file pathtype $path] ne "relative"} { |
||||||
|
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review |
||||||
|
set projectinfo [punk::repo::find_repos $shellbase] |
||||||
|
set projectbase [dict get $projectinfo closest] |
||||||
|
|
||||||
|
set extended_capdict $capdict |
||||||
|
dict set extended_capdict vendor $vendor |
||||||
|
dict set extended_capdict projectbase $projectbase |
||||||
|
} |
||||||
|
shellproject_multivendor { |
||||||
|
#currently only intended for punk::templates - review if 3rd party _multivendor trees even make sense |
||||||
|
if {$pkg ni $multivendor_package_whitelist} { |
||||||
|
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but package is not in whitelist $multivendor_package_whitelist - 3rd party _multivendor tree not supported" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
if {[file pathtype $path] ne "relative"} { |
||||||
|
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be a relative path" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review |
||||||
|
set projectinfo [punk::repo::find_repos $shellbase] |
||||||
|
set projectbase [dict get $projectinfo closest] |
||||||
|
|
||||||
|
set extended_capdict $capdict |
||||||
|
dict set extended_capdict vendor $vendor |
||||||
|
dict set extended_capdict projectbase $projectbase |
||||||
|
} |
||||||
|
absolute { |
||||||
|
if {[file pathtype $path] ne "absolute"} { |
||||||
|
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' of type $pathtype which doesn't seem to be absolute" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
set normpath [file normalize $path] |
||||||
|
if {!file exists $normpath} { |
||||||
|
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' which doesn't seem to exist" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
set projectinfo [punk::repo::find_repos $normpath] |
||||||
|
set projectbase [dict get $projectinfo closest] |
||||||
|
|
||||||
|
#todo - verify no other provider has registered same absolute path - if sharing a project-external location is needed - they need their own subfolder |
||||||
|
set extended_capdict $capdict |
||||||
|
dict set extended_capdict resolved_path $normpath |
||||||
|
dict set extended_capdict vendor $vendor |
||||||
|
dict set extended_capdict projectbase $projectbase |
||||||
|
} |
||||||
|
default { |
||||||
|
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability but provided a path '$path' with unrecognised type $pathtype" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# -- --- --- --- --- --- --- ---- --- |
||||||
|
# update package internal data |
||||||
|
# -- --- --- --- --- --- --- ---- --- |
||||||
|
upvar ::punk::cap::handlers::templates::provider_info_$cname provider_info |
||||||
|
|
||||||
|
if {$capname ni $::punk::cap::handlers::templates::handled_caps} { |
||||||
|
lappend ::punk::cap::handlers::templates::handled_caps $capname |
||||||
|
} |
||||||
|
if {![info exists provider_info] || $extended_capdict ni [dict get $provider_info $pkg]} { |
||||||
|
#this checks for duplicates from the same provider - but not if other providers already added the path |
||||||
|
#review - |
||||||
|
dict lappend provider_info $pkg $extended_capdict |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# -- --- --- --- --- --- --- ---- --- |
||||||
|
# instantiation of api at punk::cap::handlers::templates::api_$capname |
||||||
|
# -- --- --- --- --- --- --- ---- --- |
||||||
|
set apicmd "::punk::cap::handlers::templates::api_$capname" |
||||||
|
if {[info commands $apicmd] eq ""} { |
||||||
|
punk::cap::handlers::templates::class::api create $apicmd $capname |
||||||
|
} |
||||||
|
|
||||||
|
return 1 |
||||||
|
} |
||||||
|
method pkg_unregister {pkg} { |
||||||
|
upvar ::punk::cap::handlers::templates::handled_caps hcaps |
||||||
|
foreach capname $hcaps { |
||||||
|
set cname [string map {. _} $capname] |
||||||
|
upvar ::punk::cap::handlers::templates::provider_info_$cname my_provider_info |
||||||
|
dict unset my_provider_info $pkg |
||||||
|
#destroy api objects? |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
variable handled_caps [list] |
||||||
|
#variable pkg_folders [dict create] |
||||||
|
|
||||||
|
# -- --- --- --- --- --- --- |
||||||
|
#handler api for clients of this capability - called via punk::cap::call_handler <capname> <method> ?args? |
||||||
|
# -- --- --- --- --- --- --- |
||||||
|
namespace export * |
||||||
|
namespace eval class { |
||||||
|
oo::class create api { |
||||||
|
#return a dict keyed on folder with source pkg as value |
||||||
|
constructor {capname} { |
||||||
|
variable capabilityname |
||||||
|
variable cname |
||||||
|
set cname [string map {. _} $capname] |
||||||
|
set capabilityname $capname |
||||||
|
} |
||||||
|
method folders {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
-startdir -default "" |
||||||
|
*values -max 0 |
||||||
|
} $args] |
||||||
|
set opts [dict get $argd opts] |
||||||
|
|
||||||
|
set opt_startdir [dict get $opts -startdir] |
||||||
|
if {$opt_startdir eq ""} { |
||||||
|
set startdir [pwd] |
||||||
|
} else { |
||||||
|
if {[file pathtype $opt_startdir] eq "relative"} { |
||||||
|
set startdir [file join [pwd] $opt_startdir] |
||||||
|
} else { |
||||||
|
set startdir $opt_startdir |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
variable capabilityname |
||||||
|
variable cname |
||||||
|
upvar ::punk::cap::handlers::templates::provider_info_$cname my_provider_info |
||||||
|
package require punk::cap |
||||||
|
set capinfo [punk::cap::capability $capabilityname] |
||||||
|
# e.g {punk.templates {handler punk::mix::templates providers ::somepkg}} |
||||||
|
|
||||||
|
#use the order of pkgs as registered with punk::cap - may have been modified with punk::cap::promote_package/demote_package |
||||||
|
set providerpkg [dict get $capinfo providers] |
||||||
|
set folderdict [dict create] |
||||||
|
|
||||||
|
#maintain separate paths for different override levels - all keyed on vendor (or pseudo-vendor '_project') |
||||||
|
set found_paths_adhoc [dict create] |
||||||
|
set found_paths_module [dict create] |
||||||
|
set found_paths_currentproject_multivendor [dict create] |
||||||
|
set found_paths_currentproject [dict create] |
||||||
|
set found_paths_shellproject_multivendor [dict create] |
||||||
|
set found_paths_shellproject [dict create] |
||||||
|
set found_paths_absolute [list] |
||||||
|
|
||||||
|
|
||||||
|
foreach pkg $providerpkg { |
||||||
|
set found_paths [list] |
||||||
|
#set acceptedlist [dict get [punk::cap::pkgcap $pkg $capabilityname] accepted] |
||||||
|
|
||||||
|
foreach capdecl_extended [dict get $my_provider_info $pkg] { |
||||||
|
#basic validation and extension was done when accepted - so we can trust the capdecl_extended dictionary has the right entries |
||||||
|
|
||||||
|
set path [dict get $capdecl_extended path] |
||||||
|
set pathtype [dict get $capdecl_extended pathtype] |
||||||
|
set vendor [dict get $capdecl_extended vendor] |
||||||
|
# projectbase not present in capdecl_extended for all template pathtypes |
||||||
|
if {$pathtype eq "adhoc"} { |
||||||
|
#e.g (cwd)/templates |
||||||
|
set targetpath [file join $startdir [dict get $capdecl_extended path]] |
||||||
|
if {[file isdirectory $targetpath]} { |
||||||
|
dict lappend found_paths_adhoc $vendor [list pkg $pkg path $targetpath pathtype $pathtype] |
||||||
|
} |
||||||
|
} elseif {$pathtype eq "module"} { |
||||||
|
set module_projectroot [dict get $capdecl_extended projectbase] |
||||||
|
dict lappend found_paths_module $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $module_projectroot] |
||||||
|
} elseif {$pathtype eq "currentproject_multivendor"} { |
||||||
|
set searchbase $startdir |
||||||
|
set pathinfo [punk::repo::find_repos $searchbase] |
||||||
|
set pwd_projectroot [dict get $pathinfo closest] |
||||||
|
if {$pwd_projectroot ne ""} { |
||||||
|
set deckbase [file join $pwd_projectroot $path] |
||||||
|
if {![file exists $deckbase]} { |
||||||
|
continue |
||||||
|
} |
||||||
|
#add vendor/x folders first - earlier in list is lower priority |
||||||
|
set vendorbase [file join $deckbase vendor] |
||||||
|
if {[file isdirectory $vendorbase]} { |
||||||
|
set vendorfolders [glob -nocomplain -dir $vendorbase -type d -tails *] |
||||||
|
foreach vf $vendorfolders { |
||||||
|
if {$vf ne "_project"} { |
||||||
|
dict lappend found_paths_currentproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype] |
||||||
|
} |
||||||
|
} |
||||||
|
if {[file isdirectory [file join $vendorbase _project]]} { |
||||||
|
dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype] |
||||||
|
} |
||||||
|
} |
||||||
|
set custombase [file join $deckbase custom] |
||||||
|
if {[file isdirectory $custombase]} { |
||||||
|
set customfolders [glob -nocomplain -dir $custombase -type d -tails *] |
||||||
|
foreach cf $customfolders { |
||||||
|
if {$cf ne "_project"} { |
||||||
|
dict lappend found_paths_currentproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype] |
||||||
|
} |
||||||
|
} |
||||||
|
if {[file isdirectory [file join $custombase _project]]} { |
||||||
|
dict lappend found_paths_currentproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} elseif {$pathtype eq "currentproject"} { |
||||||
|
set searchbase $startdir |
||||||
|
set pathinfo [punk::repo::find_repos $searchbase] |
||||||
|
set pwd_projectroot [dict get $pathinfo closest] |
||||||
|
if {$pwd_projectroot ne ""} { |
||||||
|
#path relative to projectroot already validated by handler as being within a currentproject_multivendor tree |
||||||
|
set targetfolder [file join $pwd_projectroot $path] |
||||||
|
if {[file isdirectory $targetfolder]} { |
||||||
|
dict lappend found_paths_currentproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype] |
||||||
|
} |
||||||
|
} |
||||||
|
} elseif {$pathtype eq "shellproject_multivendor"} { |
||||||
|
#review - consider also [info script] - but it can be empty if we just start a tclsh, load packages and start a repl |
||||||
|
#set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review |
||||||
|
#set pathinfo [punk::repo::find_repos $shellbase] |
||||||
|
#set pwd_projectroot [dict get $pathinfo closest] |
||||||
|
|
||||||
|
set shell_projectroot [dict get $capdecl_extended projectbase] |
||||||
|
if {$shell_projectroot ne ""} { |
||||||
|
set deckbase [file join $shell_projectroot $path] |
||||||
|
if {![file exists $deckbase]} { |
||||||
|
continue |
||||||
|
} |
||||||
|
#add vendor/x folders first - earlier in list is lower priority |
||||||
|
set vendorbase [file join $deckbase vendor] |
||||||
|
if {[file isdirectory $vendorbase]} { |
||||||
|
set vendorfolders [glob -nocomplain -dir $vendorbase -type d -tails *] |
||||||
|
foreach vf $vendorfolders { |
||||||
|
if {$vf ne "_project"} { |
||||||
|
dict lappend found_paths_shellproject_multivendor $vf [list pkg $pkg path [file join $vendorbase $vf] pathtype $pathtype projectbase $shell_projectroot] |
||||||
|
} |
||||||
|
} |
||||||
|
if {[file isdirectory [file join $vendorbase _project]]} { |
||||||
|
dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $vendorbase _project] pathtype $pathtype projectbase $shell_projectroot] |
||||||
|
} |
||||||
|
} |
||||||
|
set custombase [file join $deckbase custom] |
||||||
|
if {[file isdirectory $custombase]} { |
||||||
|
set customfolders [glob -nocomplain -dir $custombase -type d -tails *] |
||||||
|
foreach cf $customfolders { |
||||||
|
if {$cf ne "_project"} { |
||||||
|
dict lappend found_paths_shellproject_multivendor $cf [list pkg $pkg path [file join $custombase $cf] pathtype $pathtype projectbase $shell_projectroot] |
||||||
|
} |
||||||
|
} |
||||||
|
if {[file isdirectory [file join $custombase _project]]} { |
||||||
|
dict lappend found_paths_shellproject_multivendor _project [list pkg $pkg path [file join $custombase _project] pathtype $pathtype projectbase $shell_projectroot] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
} elseif {$pathtype eq "shellproject"} { |
||||||
|
#review - consider also [info script] - but it can be empty if we just start a tclsh, load packages and start a repl |
||||||
|
#set shellbase [file dirname [file dirname [file normalize [set ::argv0]/__]]] ;#review |
||||||
|
#set pathinfo [punk::repo::find_repos $shellbase] |
||||||
|
#set pwd_projectroot [dict get $pathinfo closest] |
||||||
|
|
||||||
|
set shell_projectroot [dict get $capdecl_extended projectbase] |
||||||
|
if {$shell_projectroot ne ""} { |
||||||
|
set targetfolder [file join $shell_projectroot $path] |
||||||
|
if {[file isdirectory $targetfolder]} { |
||||||
|
dict lappend found_paths_shellproject $vendor [list pkg $pkg path $targetfolder pathtype $pathtype projectbase $shell_projectroot] |
||||||
|
} |
||||||
|
} |
||||||
|
} elseif {$pathtype eq "absolute"} { |
||||||
|
#lappend found_paths [dict get $capdecl_extended resolved_path] |
||||||
|
set abs_projectroot [dict get $capdecl_extended projectbase] |
||||||
|
dict lappend found_paths_absolute $vendor [list pkg $pkg path [dict get $capdecl_extended resolved_path] pathtype $pathtype projectbase $abs_projectroot] |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#todo - ensure vendor pkg capdict elements such source and allowupdates override any existing entry from a _multivendor pkg? |
||||||
|
#currently relying on order in which loaded? review |
||||||
|
#foreach pfolder $found_paths { |
||||||
|
# dict set folderdict $pfolder [list source $pkg sourcetype package] |
||||||
|
#} |
||||||
|
} |
||||||
|
|
||||||
|
#add in order of preference low priority to high |
||||||
|
|
||||||
|
dict for {vendor pathinfolist} $found_paths_module { |
||||||
|
foreach pathinfo $pathinfolist { |
||||||
|
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#Templates within project of shell we launched with has lower priority than 'currentproject' (which depends on our CWD) |
||||||
|
dict for {vendor pathinfolist} $found_paths_shellproject_multivendor { |
||||||
|
foreach pathinfo $pathinfolist { |
||||||
|
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor] |
||||||
|
} |
||||||
|
} |
||||||
|
dict for {vendor pathinfolist} $found_paths_shellproject { |
||||||
|
foreach pathinfo $pathinfolist { |
||||||
|
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
dict for {vendor pathinfolist} $found_paths_currentproject_multivendor { |
||||||
|
foreach pathinfo $pathinfolist { |
||||||
|
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] vendor $vendor] |
||||||
|
} |
||||||
|
} |
||||||
|
dict for {vendor pathinfolist} $found_paths_currentproject { |
||||||
|
foreach pathinfo $pathinfolist { |
||||||
|
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] vendor $vendor] |
||||||
|
} |
||||||
|
} |
||||||
|
dict for {vendor pathinfolist} $found_paths_absolute { |
||||||
|
foreach pathinfo $pathinfolist { |
||||||
|
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] projectbase [dict get $pathinfo projectbase] vendor $vendor] |
||||||
|
} |
||||||
|
} |
||||||
|
#adhoc paths relative to cwd (or specified -startdir) can override any |
||||||
|
dict for {vendor pathinfolist} $found_paths_adhoc { |
||||||
|
foreach pathinfo $pathinfolist { |
||||||
|
dict set folderdict [dict get $pathinfo path] [list source [dict get $pathinfo pkg] sourcetype package pathtype [dict get $pathinfo pathtype] vendor $vendor] |
||||||
|
} |
||||||
|
} |
||||||
|
return $folderdict |
||||||
|
} |
||||||
|
method get_itemdict_projectlayouts {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
*opts -anyopts 1 |
||||||
|
#peek -startdir while allowing all other opts/vals to be verified down-the-line instead of here |
||||||
|
-startdir -default "" |
||||||
|
*values -maxvalues -1 |
||||||
|
} $args] |
||||||
|
set opt_startdir [dict get $argd opts -startdir] |
||||||
|
|
||||||
|
if {$opt_startdir eq ""} { |
||||||
|
set searchbase [pwd] |
||||||
|
} else { |
||||||
|
set searchbase $opt_startdir |
||||||
|
} |
||||||
|
|
||||||
|
set refdict [my get_itemdict_projectlayoutrefs {*}$args] |
||||||
|
set layoutdict [dict create] |
||||||
|
|
||||||
|
set projectinfo [punk::repo::find_repos $searchbase] |
||||||
|
set projectroot [dict get $projectinfo closest] |
||||||
|
|
||||||
|
dict for {layoutname refinfo} $refdict { |
||||||
|
set templatepathtype [dict get $refinfo sourceinfo pathtype] |
||||||
|
set sourceinfo [dict get $refinfo sourceinfo] |
||||||
|
set path [dict get $refinfo path] |
||||||
|
set reftail [file tail $path] |
||||||
|
set atparts [split [file rootname $reftail] @] |
||||||
|
#may be two @s if referencing a renamed layout override? |
||||||
|
# e.g ref may be @vendor+punks+othersample@sample-0.1 or layoutalias-1.1@vendor+punk+othersample@sample-0.1 |
||||||
|
#there must always be an @ before vendor or custom . There is either a template-name alias or empty string before this first @ |
||||||
|
#trim off first @ part |
||||||
|
set tailats [join [lrange $atparts 1 end] @] |
||||||
|
# @ parts after the first are part of the path within the project_layouts structure |
||||||
|
set subpathlist [split $tailats +] |
||||||
|
if {[dict exists $refinfo sourceinfo projectbase]} { |
||||||
|
#some template pathtypes refer to the projectroot from the template - not the cwd |
||||||
|
set projectroot [dict get $refinfo sourceinfo projectbase] |
||||||
|
} |
||||||
|
|
||||||
|
if {$projectroot ne ""} { |
||||||
|
set layoutroot [file join $projectroot src/project_layouts] |
||||||
|
set layoutfolder [file join $layoutroot {*}$subpathlist] |
||||||
|
if {[file isdirectory $layoutfolder]} { |
||||||
|
#todo - check if layoutname already in layoutdict append .ref path to list of refs that linked to this layout? |
||||||
|
set layoutinfo [list path $layoutfolder basefolder $layoutroot sourceinfo $sourceinfo] |
||||||
|
dict set layoutdict $layoutname $layoutinfo |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $layoutdict |
||||||
|
} |
||||||
|
method get_itemdict_projectlayoutrefs {args} { |
||||||
|
set config { |
||||||
|
-templatefolder_subdir "layout_refs"\ |
||||||
|
-command_get_items_from_base {apply {{base} { |
||||||
|
set matched_files [glob -nocomplain -dir $base -type f *@*.ref] |
||||||
|
set items [list] |
||||||
|
foreach rf $matched_files { |
||||||
|
#puts stderr "--> $rf" |
||||||
|
if {[string match ignore* $rf]} { |
||||||
|
continue |
||||||
|
} |
||||||
|
#we silently skip .ref files that don't match - todo - more verification - and warn of invalid .refs? |
||||||
|
if {[string match *@vendor+* $rf] || [string match *@custom+* $rf]} { |
||||||
|
lappend items $rf |
||||||
|
} |
||||||
|
} |
||||||
|
return $items |
||||||
|
}}}\ |
||||||
|
-command_get_item_name {apply {{vendor basefolder itempath} { |
||||||
|
set itemtail [file rootname [file tail $itempath]] |
||||||
|
set alias [lindex [split $itemtail @] 0] |
||||||
|
if {$alias eq ""} { |
||||||
|
set itemname [lindex [split $itemtail +] end] |
||||||
|
} else { |
||||||
|
set itemname $alias |
||||||
|
} |
||||||
|
if {$vendor ne "_project"} { |
||||||
|
set itemname $vendor.$itemname |
||||||
|
} |
||||||
|
return $itemname |
||||||
|
}}} |
||||||
|
} |
||||||
|
set arglist [concat $config $args] |
||||||
|
my _get_itemdict {*}$arglist |
||||||
|
} |
||||||
|
method get_itemdict_scriptappwrappers {args} { |
||||||
|
set config { |
||||||
|
-templatefolder_subdir "utility/scriptappwrappers"\ |
||||||
|
-command_get_items_from_base {apply {{base} { |
||||||
|
|
||||||
|
set matched_files [punk::path::treefilenames -dir $base *] |
||||||
|
set wrappers [list] |
||||||
|
foreach tf $matched_files { |
||||||
|
if {[string match ignore* $tf]} { |
||||||
|
continue |
||||||
|
} |
||||||
|
set ext [file extension $tf] |
||||||
|
if {[string tolower $ext] in [list "" ".bat" ".cmd" ".sh" ".bash" ".pl" ".ps1" ".tcl"]} { |
||||||
|
lappend wrappers $tf |
||||||
|
} |
||||||
|
} |
||||||
|
return $wrappers |
||||||
|
}}}\ |
||||||
|
-command_get_item_name {apply {{vendor basefolder itempath} { |
||||||
|
|
||||||
|
set relativepath [punk::path::relative $basefolder $itempath] |
||||||
|
set ftail [file tail $itempath] |
||||||
|
set tname $relativepath |
||||||
|
if {$vendor ne "_project"} { |
||||||
|
set tname ${vendor}.$tname |
||||||
|
} |
||||||
|
return $tname |
||||||
|
}}} |
||||||
|
} |
||||||
|
set arglist [concat $config $args] |
||||||
|
my _get_itemdict {*}$arglist |
||||||
|
} |
||||||
|
method get_itemdict_moduletemplates {args} { |
||||||
|
set config { |
||||||
|
-templatefolder_subdir "modules"\ |
||||||
|
-command_get_items_from_base {apply {{base} { |
||||||
|
|
||||||
|
set matched_files [punk::path::treefilenames -dir $base template_*.tm] |
||||||
|
set tfiles [list] |
||||||
|
foreach tf $matched_files { |
||||||
|
if {[string match ignore* $tf]} { |
||||||
|
continue |
||||||
|
} |
||||||
|
set ext [file extension $tf] |
||||||
|
if {[string tolower $ext] in [list ".tm"]} { |
||||||
|
#we will ignore any .tm files that don't have versions that tcl understands - but warn |
||||||
|
#this reduces the cases we have to test later |
||||||
|
set fname [file tail $tf] |
||||||
|
lassign [split [punk::mix::cli::lib::split_modulename_version $fname]] mname ver |
||||||
|
if {[catch {punk::mix::cli::lib::validate_modulename $mname} errM]} { |
||||||
|
puts stderr "Invalid module name/version $tf - please rename with standard Tcl .tm module name and version (or leave out version)" |
||||||
|
if {[string match *-* $mname]} { |
||||||
|
puts stderr "Tcl module name cannot contain dash character - except between name and version" |
||||||
|
} |
||||||
|
} else { |
||||||
|
lappend tfiles $tf |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $tfiles |
||||||
|
|
||||||
|
}}}\ |
||||||
|
-command_get_item_name {apply {{vendor basefolder itempath} { |
||||||
|
|
||||||
|
set relativepath [punk::path::relative $basefolder $itempath] |
||||||
|
set dirs [file dirname $relativepath] |
||||||
|
if {$dirs eq "."} { |
||||||
|
set dirs "" |
||||||
|
} |
||||||
|
set moduleprefix [join $dirs ::] |
||||||
|
set ftail [file rootname [file tail $itempath]] |
||||||
|
set tname [string range $ftail [string length template_] end] |
||||||
|
if {$moduleprefix ne ""} { |
||||||
|
set tname ${moduleprefix}::$tname |
||||||
|
} |
||||||
|
if {$vendor ne "_project"} { |
||||||
|
set tname ${vendor}.$tname |
||||||
|
} |
||||||
|
return $tname |
||||||
|
}}} |
||||||
|
} |
||||||
|
set arglist [concat $config $args] |
||||||
|
my _get_itemdict {*}$arglist |
||||||
|
} |
||||||
|
|
||||||
|
#shared algorithm for get_itemdict_* methods |
||||||
|
#requires a -templatefolder_subdir indicating a directory within each template base folder in which to search |
||||||
|
#and a file selection mechanism command -command_get_items_from_base |
||||||
|
#and a name determining command -command_get_item_name |
||||||
|
method _get_itemdict {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
*proc -name _get_itemdict |
||||||
|
*opts -anyopts 0 |
||||||
|
-startdir -default "" |
||||||
|
-templatefolder_subdir -optional 0 |
||||||
|
-command_get_items_from_base -optional 0 |
||||||
|
-command_get_item_name -optional 0 |
||||||
|
-not -default "" -multiple 1 |
||||||
|
*values -maxvalues -1 |
||||||
|
globsearches -default * -multiple 1 |
||||||
|
} $args] |
||||||
|
set opts [dict get $argd opts] |
||||||
|
set globsearches [dict get $argd values globsearches]; #note that in this case our globsearch won't reduce the machine's effort in scannning the filesystem - as we need to search on the renamed results |
||||||
|
#puts stderr "=-=============>globsearches:$globsearches" |
||||||
|
# -- --- --- --- --- --- --- --- --- |
||||||
|
set opt_startdir [dict get $opts -startdir] |
||||||
|
set opt_templatefolder_subdir [dict get $opts -templatefolder_subdir] |
||||||
|
if {[file pathtype $opt_templatefolder_subdir] ne "relative"} { |
||||||
|
error templates::_get_itemdict |
||||||
|
} |
||||||
|
# -- --- --- --- --- --- --- --- --- |
||||||
|
set opt_command_get_items_from_base [dict get $opts -command_get_items_from_base] |
||||||
|
set opt_command_get_item_name [dict get $opts -command_get_item_name] |
||||||
|
set opt_not [dict get $opts -not] |
||||||
|
# -- --- --- --- --- --- --- --- --- |
||||||
|
set itembases [list] |
||||||
|
#set tbasedict [punk::mix::base::lib::get_template_basefolders $opt_startdir] |
||||||
|
set tbasedict [my folders -startdir $opt_startdir ] |
||||||
|
#turn the dict into a list we can temporarily reverse sort while we expand the items from within each path |
||||||
|
dict for {tbase folderinfo} $tbasedict { |
||||||
|
lappend itembases [list basefolder [file join $tbase $opt_templatefolder_subdir] sourceinfo $folderinfo] |
||||||
|
} |
||||||
|
|
||||||
|
set items [list] |
||||||
|
set itemdict [dict create] |
||||||
|
set seen_dict [dict create] |
||||||
|
|
||||||
|
#flip the priority order for layout folders encountered so we can set the trailing #<int> dup/overridden indicators |
||||||
|
foreach baseinfo [lreverse $itembases] { |
||||||
|
set basefolder [dict get $baseinfo basefolder] |
||||||
|
set sourceinfo [dict get $baseinfo sourceinfo] |
||||||
|
set vendor [dict get $sourceinfo vendor] |
||||||
|
#call the custom script from our caller which determines resultset of files we are interested in |
||||||
|
set matches [{*}$opt_command_get_items_from_base $basefolder] |
||||||
|
set items_here [dict create] ;#maintain a list keyed on name for sorting within this base only |
||||||
|
foreach itempath $matches { |
||||||
|
set itemname [{*}$opt_command_get_item_name $vendor $basefolder $itempath] |
||||||
|
dict set items_here $itemname [list item $itempath baseinfo $baseinfo] |
||||||
|
#lappend items [list item $itempath baseinfo $baseinfo] |
||||||
|
} |
||||||
|
set ordered_names [lsort [dict keys $items_here]] |
||||||
|
#add to the outer items list |
||||||
|
foreach nm $ordered_names { |
||||||
|
set iteminfo [dict get $items_here $nm] |
||||||
|
lappend items [list originalname $nm iteminfo $iteminfo] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#append #n instance/duplicate name indicators based on cyling through entire list of found items |
||||||
|
foreach itemrecord $items { |
||||||
|
set oname [dict get $itemrecord originalname] |
||||||
|
set iteminfo [dict get $itemrecord iteminfo] |
||||||
|
set itempath [dict get $iteminfo item] |
||||||
|
set baseinfo [dict get $iteminfo baseinfo] |
||||||
|
if {![dict exists $seen_dict $oname]} { |
||||||
|
dict set seen_dict $oname 1 |
||||||
|
dict set itemdict $oname [list path $itempath {*}$baseinfo] ; #first seen of oname gets no number |
||||||
|
} else { |
||||||
|
set n [dict get $seen_dict $oname] |
||||||
|
incr n |
||||||
|
dict incr seen_dict $oname |
||||||
|
dict set itemdict ${oname}#$n [list path $itempath {*}$baseinfo] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#assertion path is first key of itemdict {callers are allowed to rely on it being first} |
||||||
|
#assertion itemdict has keys path,basefolder,sourceinfo |
||||||
|
set result [dict create] |
||||||
|
set keys [lreverse [dict keys $itemdict]] |
||||||
|
foreach k $keys { |
||||||
|
set maybe "" |
||||||
|
foreach g $globsearches { |
||||||
|
if {[string match $g $k]} { |
||||||
|
set maybe $k |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
set not "" |
||||||
|
if {$maybe ne ""} { |
||||||
|
foreach n $opt_not { |
||||||
|
if {[string match $n $k]} { |
||||||
|
set not $k |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {$maybe ne "" && $not eq ""} { |
||||||
|
dict set result $k [dict get $itemdict $k] |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::cap::handlers::templates [namespace eval punk::cap::handlers::templates { |
||||||
|
variable pkg punk::cap::handlers::templates |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,71 @@ |
|||||||
|
|
||||||
|
# -*- tcl -* |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::docgen 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license BSD |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
package require punk::repo |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::docgen { |
||||||
|
proc get_doctools_comments {fname} { |
||||||
|
#does no validation of doctools commands |
||||||
|
#existence of string match #\**!doctools is taken as evidence enough that the file has inline doctools - review |
||||||
|
if {![file exists $fname]} { |
||||||
|
error "get_doctools_comments file '$fname' not found" |
||||||
|
} |
||||||
|
set fd [open $fname r] |
||||||
|
set data [read $fd] |
||||||
|
close $fd |
||||||
|
if {![string match "*#\**!doctools*" $data]} { |
||||||
|
return |
||||||
|
} |
||||||
|
set data [string map [list \r\n \n] $data] |
||||||
|
set in_doctools 0 |
||||||
|
set doctools "" |
||||||
|
foreach ln [split $data \n] { |
||||||
|
set ln [string trim $ln] |
||||||
|
if {$in_doctools && [string index $ln 0] != "#"} { |
||||||
|
set in_doctools 0 |
||||||
|
} elseif {[string range $ln 0 1] == "#*"} { |
||||||
|
#todo - process doctools ordering hints in tail of line |
||||||
|
set in_doctools 1 |
||||||
|
} elseif {$in_doctools} { |
||||||
|
append doctools [string range $ln 1 end] \n |
||||||
|
} |
||||||
|
} |
||||||
|
return $doctools |
||||||
|
} |
||||||
|
#todo - proc autogen_doctools_comments {fname} {} |
||||||
|
# - will probably need to use something like parsetcl - as we won't be able to reliably source in an interp without side-effects and use info body etc. |
||||||
|
# - mechanism will be to autodocument namespaces, procs, methods where no #*** doctools indication present - but use existing doctools comments for that particular item if it is present. |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::docgen [namespace eval punk::docgen { |
||||||
|
variable pkg punk::docgen |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,437 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::encmime 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin punkshell_module_punk::encmime 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {mime encodings related subset of tcllib mime}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {mime encoding names and aliases}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::encmime] |
||||||
|
#[keywords module encodings] |
||||||
|
#[description] |
||||||
|
#[para] This is a workaround package to provide the mime encoding names used in tcllib's mime package - without additional dependencies |
||||||
|
#[para]tcllib mime loads either Trf or tcl::memchan functions. punk::encmime needs to work in a context where tcllib may not yet be loaded/available, and even these few dependencies are too much. |
||||||
|
#[para]MAINTENANCE NOTE: The data in this module needs to be checked against the latest tcllib mime package |
||||||
|
#[para]taken from tcllib mime version: 1.7.2 in 2024 |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::encmime |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] Where practical - the actual tcllib mime package should be used instead. |
||||||
|
#[para]This set of encoding related functions is a snapshot of the data from the mime package - and may not be up to date. |
||||||
|
#[para]This pseudo-package was created to minimize dependencies for punk::char and punk::overtype |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::encmime |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6-}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::encmime::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::encmime::class}] |
||||||
|
#[para] class definitions |
||||||
|
if {[info commands [namespace current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
} |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::encmime { |
||||||
|
namespace export * |
||||||
|
|
||||||
|
variable encList { |
||||||
|
ascii US-ASCII |
||||||
|
big5 Big5 |
||||||
|
cp1250 Windows-1250 |
||||||
|
cp1251 Windows-1251 |
||||||
|
cp1252 Windows-1252 |
||||||
|
cp1253 Windows-1253 |
||||||
|
cp1254 Windows-1254 |
||||||
|
cp1255 Windows-1255 |
||||||
|
cp1256 Windows-1256 |
||||||
|
cp1257 Windows-1257 |
||||||
|
cp1258 Windows-1258 |
||||||
|
cp437 IBM437 |
||||||
|
cp737 {} |
||||||
|
cp775 IBM775 |
||||||
|
cp850 IBM850 |
||||||
|
cp852 IBM852 |
||||||
|
cp855 IBM855 |
||||||
|
cp857 IBM857 |
||||||
|
cp860 IBM860 |
||||||
|
cp861 IBM861 |
||||||
|
cp862 IBM862 |
||||||
|
cp863 IBM863 |
||||||
|
cp864 IBM864 |
||||||
|
cp865 IBM865 |
||||||
|
cp866 IBM866 |
||||||
|
cp869 IBM869 |
||||||
|
cp874 {} |
||||||
|
cp932 {} |
||||||
|
cp936 GBK |
||||||
|
cp949 {} |
||||||
|
cp950 {} |
||||||
|
dingbats {} |
||||||
|
ebcdic {} |
||||||
|
euc-cn EUC-CN |
||||||
|
euc-jp EUC-JP |
||||||
|
euc-kr EUC-KR |
||||||
|
gb12345 GB12345 |
||||||
|
gb1988 GB1988 |
||||||
|
gb2312 GB2312 |
||||||
|
iso2022 ISO-2022 |
||||||
|
iso2022-jp ISO-2022-JP |
||||||
|
iso2022-kr ISO-2022-KR |
||||||
|
iso8859-1 ISO-8859-1 |
||||||
|
iso8859-2 ISO-8859-2 |
||||||
|
iso8859-3 ISO-8859-3 |
||||||
|
iso8859-4 ISO-8859-4 |
||||||
|
iso8859-5 ISO-8859-5 |
||||||
|
iso8859-6 ISO-8859-6 |
||||||
|
iso8859-7 ISO-8859-7 |
||||||
|
iso8859-8 ISO-8859-8 |
||||||
|
iso8859-9 ISO-8859-9 |
||||||
|
iso8859-10 ISO-8859-10 |
||||||
|
iso8859-13 ISO-8859-13 |
||||||
|
iso8859-14 ISO-8859-14 |
||||||
|
iso8859-15 ISO-8859-15 |
||||||
|
iso8859-16 ISO-8859-16 |
||||||
|
jis0201 JIS_X0201 |
||||||
|
jis0208 JIS_C6226-1983 |
||||||
|
jis0212 JIS_X0212-1990 |
||||||
|
koi8-r KOI8-R |
||||||
|
koi8-u KOI8-U |
||||||
|
ksc5601 KS_C_5601-1987 |
||||||
|
macCentEuro {} |
||||||
|
macCroatian {} |
||||||
|
macCyrillic {} |
||||||
|
macDingbats {} |
||||||
|
macGreek {} |
||||||
|
macIceland {} |
||||||
|
macJapan {} |
||||||
|
macRoman {} |
||||||
|
macRomania {} |
||||||
|
macThai {} |
||||||
|
macTurkish {} |
||||||
|
macUkraine {} |
||||||
|
shiftjis Shift_JIS |
||||||
|
symbol {} |
||||||
|
tis-620 TIS-620 |
||||||
|
unicode {} |
||||||
|
utf-8 UTF-8 |
||||||
|
} |
||||||
|
variable encodings |
||||||
|
array set encodings $encList |
||||||
|
variable reversemap |
||||||
|
variable encAliasList { |
||||||
|
ascii ANSI_X3.4-1968 |
||||||
|
ascii iso-ir-6 |
||||||
|
ascii ANSI_X3.4-1986 |
||||||
|
ascii ISO_646.irv:1991 |
||||||
|
ascii ASCII |
||||||
|
ascii ISO646-US |
||||||
|
ascii us |
||||||
|
ascii IBM367 |
||||||
|
ascii cp367 |
||||||
|
cp437 cp437 |
||||||
|
cp437 437 |
||||||
|
cp775 cp775 |
||||||
|
cp850 cp850 |
||||||
|
cp850 850 |
||||||
|
cp852 cp852 |
||||||
|
cp852 852 |
||||||
|
cp855 cp855 |
||||||
|
cp855 855 |
||||||
|
cp857 cp857 |
||||||
|
cp857 857 |
||||||
|
cp860 cp860 |
||||||
|
cp860 860 |
||||||
|
cp861 cp861 |
||||||
|
cp861 861 |
||||||
|
cp861 cp-is |
||||||
|
cp862 cp862 |
||||||
|
cp862 862 |
||||||
|
cp863 cp863 |
||||||
|
cp863 863 |
||||||
|
cp864 cp864 |
||||||
|
cp865 cp865 |
||||||
|
cp865 865 |
||||||
|
cp866 cp866 |
||||||
|
cp866 866 |
||||||
|
cp869 cp869 |
||||||
|
cp869 869 |
||||||
|
cp869 cp-gr |
||||||
|
cp936 CP936 |
||||||
|
cp936 MS936 |
||||||
|
cp936 Windows-936 |
||||||
|
iso8859-1 ISO_8859-1:1987 |
||||||
|
iso8859-1 iso-ir-100 |
||||||
|
iso8859-1 ISO_8859-1 |
||||||
|
iso8859-1 latin1 |
||||||
|
iso8859-1 l1 |
||||||
|
iso8859-1 IBM819 |
||||||
|
iso8859-1 CP819 |
||||||
|
iso8859-2 ISO_8859-2:1987 |
||||||
|
iso8859-2 iso-ir-101 |
||||||
|
iso8859-2 ISO_8859-2 |
||||||
|
iso8859-2 latin2 |
||||||
|
iso8859-2 l2 |
||||||
|
iso8859-3 ISO_8859-3:1988 |
||||||
|
iso8859-3 iso-ir-109 |
||||||
|
iso8859-3 ISO_8859-3 |
||||||
|
iso8859-3 latin3 |
||||||
|
iso8859-3 l3 |
||||||
|
iso8859-4 ISO_8859-4:1988 |
||||||
|
iso8859-4 iso-ir-110 |
||||||
|
iso8859-4 ISO_8859-4 |
||||||
|
iso8859-4 latin4 |
||||||
|
iso8859-4 l4 |
||||||
|
iso8859-5 ISO_8859-5:1988 |
||||||
|
iso8859-5 iso-ir-144 |
||||||
|
iso8859-5 ISO_8859-5 |
||||||
|
iso8859-5 cyrillic |
||||||
|
iso8859-6 ISO_8859-6:1987 |
||||||
|
iso8859-6 iso-ir-127 |
||||||
|
iso8859-6 ISO_8859-6 |
||||||
|
iso8859-6 ECMA-114 |
||||||
|
iso8859-6 ASMO-708 |
||||||
|
iso8859-6 arabic |
||||||
|
iso8859-7 ISO_8859-7:1987 |
||||||
|
iso8859-7 iso-ir-126 |
||||||
|
iso8859-7 ISO_8859-7 |
||||||
|
iso8859-7 ELOT_928 |
||||||
|
iso8859-7 ECMA-118 |
||||||
|
iso8859-7 greek |
||||||
|
iso8859-7 greek8 |
||||||
|
iso8859-8 ISO_8859-8:1988 |
||||||
|
iso8859-8 iso-ir-138 |
||||||
|
iso8859-8 ISO_8859-8 |
||||||
|
iso8859-8 hebrew |
||||||
|
iso8859-9 ISO_8859-9:1989 |
||||||
|
iso8859-9 iso-ir-148 |
||||||
|
iso8859-9 ISO_8859-9 |
||||||
|
iso8859-9 latin5 |
||||||
|
iso8859-9 l5 |
||||||
|
iso8859-10 iso-ir-157 |
||||||
|
iso8859-10 l6 |
||||||
|
iso8859-10 ISO_8859-10:1992 |
||||||
|
iso8859-10 latin6 |
||||||
|
iso8859-14 iso-ir-199 |
||||||
|
iso8859-14 ISO_8859-14:1998 |
||||||
|
iso8859-14 ISO_8859-14 |
||||||
|
iso8859-14 latin8 |
||||||
|
iso8859-14 iso-celtic |
||||||
|
iso8859-14 l8 |
||||||
|
iso8859-15 ISO_8859-15 |
||||||
|
iso8859-15 Latin-9 |
||||||
|
iso8859-16 iso-ir-226 |
||||||
|
iso8859-16 ISO_8859-16:2001 |
||||||
|
iso8859-16 ISO_8859-16 |
||||||
|
iso8859-16 latin10 |
||||||
|
iso8859-16 l10 |
||||||
|
jis0201 X0201 |
||||||
|
jis0208 iso-ir-87 |
||||||
|
jis0208 x0208 |
||||||
|
jis0208 JIS_X0208-1983 |
||||||
|
jis0212 x0212 |
||||||
|
jis0212 iso-ir-159 |
||||||
|
ksc5601 iso-ir-149 |
||||||
|
ksc5601 KS_C_5601-1989 |
||||||
|
ksc5601 KSC5601 |
||||||
|
ksc5601 korean |
||||||
|
shiftjis MS_Kanji |
||||||
|
utf-8 UTF8 |
||||||
|
} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::encmime}] |
||||||
|
#[para] Core API functions for punk::encmime |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
# ::mime::mapencoding -- |
||||||
|
# |
||||||
|
# mime::mapencodings maps tcl encodings onto the proper names for their |
||||||
|
# MIME charset type. This is only done for encodings whose charset types |
||||||
|
# were known. The remaining encodings return {} for now. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# enc The tcl encoding to map. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# Returns the MIME charset type for the specified tcl encoding, or {} |
||||||
|
# if none is known. |
||||||
|
proc mapencoding {enc} { |
||||||
|
#*** !doctools |
||||||
|
#[call mapencoding [arg enc]] |
||||||
|
#[para]maps tcl encodings onto the proper names for their MIME charset type. |
||||||
|
#[para]This is only done for encodings whose charset types were known. |
||||||
|
#[para]The remaining encodings return {} for now. |
||||||
|
#[para]NOTE: consider using tcllib's mime::mapencoding instead if mime package available |
||||||
|
|
||||||
|
variable encodings |
||||||
|
if {[info exists encodings($enc)]} { |
||||||
|
return $encodings($enc) |
||||||
|
} |
||||||
|
return {} |
||||||
|
} |
||||||
|
|
||||||
|
proc reversemapencoding {mimeType} { |
||||||
|
#*** !doctools |
||||||
|
#[call reversemapencoding [arg mimeType]] |
||||||
|
#[para]mime::reversemapencodings maps MIME charset types onto tcl encoding names. |
||||||
|
#[para]Returns the tcl encoding name for the specified mime charset, or {} if none is known |
||||||
|
#[para] Arguments: |
||||||
|
# [list_begin arguments] |
||||||
|
# [arg_def string mimeType] The MIME charset to convert into a tcl encoding type. |
||||||
|
# [list_end] |
||||||
|
#[para]NOTE: consider using tcllib's mime::reversemapencoding instead if mime package available |
||||||
|
|
||||||
|
variable reversemap |
||||||
|
|
||||||
|
set lmimeType [string tolower $mimeType] |
||||||
|
if {[info exists reversemap($lmimeType)]} { |
||||||
|
return $reversemap($lmimeType) |
||||||
|
} |
||||||
|
return {} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::encmime ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
::apply {{} { |
||||||
|
variable encList |
||||||
|
variable encAliasList |
||||||
|
variable reversemap |
||||||
|
foreach {enc mimeType} $encList { |
||||||
|
if {$mimeType eq {}} continue |
||||||
|
set reversemap([string tolower $mimeType]) $enc |
||||||
|
} |
||||||
|
foreach {enc mimeType} $encAliasList { |
||||||
|
set reversemap([string tolower $mimeType]) $enc |
||||||
|
} |
||||||
|
# Drop the helper variables |
||||||
|
unset encList encAliasList |
||||||
|
|
||||||
|
} ::punk::encmime} |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::encmime::lib { |
||||||
|
namespace export * |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::encmime::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::encmime::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval punk::encmime::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::encmime::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::encmime [namespace eval punk::encmime { |
||||||
|
variable pkg punk::encmime |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,32 @@ |
|||||||
|
|
||||||
|
package require punk::cap |
||||||
|
|
||||||
|
|
||||||
|
tcl::namespace::eval punk::mix { |
||||||
|
proc init {} { |
||||||
|
package require punk::cap::handlers::templates ;#handler for templates cap |
||||||
|
punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates ;#time taken should generally be sub 200us |
||||||
|
|
||||||
|
package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap |
||||||
|
set t [time { |
||||||
|
if {[catch {punk::mix::templates::provider register *} errM]} { |
||||||
|
puts stderr "punk::mix failure during punk::mix::templates::provider register *" |
||||||
|
puts stderr $errM |
||||||
|
puts stderr "-----" |
||||||
|
puts stderr $::errorInfo |
||||||
|
} |
||||||
|
}] |
||||||
|
puts stderr "->punk::mix::templates::provider register * t=$t" |
||||||
|
} |
||||||
|
init |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
package require punk::mix::base |
||||||
|
package require punk::mix::cli |
||||||
|
|
||||||
|
package provide punk::mix [tcl::namespace::eval punk::mix { |
||||||
|
variable version |
||||||
|
set version 0.2 |
||||||
|
|
||||||
|
}] |
||||||
@ -0,0 +1,931 @@ |
|||||||
|
package provide punk::mix::base [namespace eval punk::mix::base { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
}] |
||||||
|
|
||||||
|
package require punk::path |
||||||
|
|
||||||
|
#base internal plumbing functions |
||||||
|
namespace eval punk::mix::base { |
||||||
|
proc set_alias {cmdname args} { |
||||||
|
#--------- |
||||||
|
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||||
|
lassign [_split_args $args] _opts opts _args args |
||||||
|
if {[dict exists $opts -extension]} { |
||||||
|
set extension [dict get $opts -extension] |
||||||
|
} else { |
||||||
|
set extension "" |
||||||
|
} |
||||||
|
#--------- |
||||||
|
|
||||||
|
uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] |
||||||
|
} |
||||||
|
proc _cli {args} { |
||||||
|
#--------- |
||||||
|
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||||
|
lassign [_split_args $args] _opts opts _args args |
||||||
|
if {[dict exists $opts -extension]} { |
||||||
|
set extension [dict get $opts -extension] |
||||||
|
} else { |
||||||
|
set extension "" |
||||||
|
} |
||||||
|
#--------- |
||||||
|
if {![string length $extension]} { |
||||||
|
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||||
|
} |
||||||
|
#puts stderr "punk::mix::base extension: [string trimleft $extension :]" |
||||||
|
if {![string length $extension]} { |
||||||
|
#if still no extension - must have been called dirctly as punk::mix::base::_cli |
||||||
|
if {![llength $args]} { |
||||||
|
set args "help" |
||||||
|
} |
||||||
|
set extension [namespace current] |
||||||
|
} |
||||||
|
if {![llength $args]} { |
||||||
|
if {[info exists ${extension}::default_command]} { |
||||||
|
tailcall $extension [set ${extension}::default_command] |
||||||
|
} |
||||||
|
tailcall $extension |
||||||
|
} else { |
||||||
|
tailcall $extension {*}$args |
||||||
|
} |
||||||
|
} |
||||||
|
proc _unknown {ns args} { |
||||||
|
#--------- |
||||||
|
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||||
|
lassign [_split_args $args] _opts opts _args args |
||||||
|
if {[dict exists $opts -extension]} { |
||||||
|
set extension [dict get $opts -extension] |
||||||
|
} else { |
||||||
|
set extension "" |
||||||
|
} |
||||||
|
#--------- |
||||||
|
|
||||||
|
if {![string length $extension]} { |
||||||
|
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||||
|
} |
||||||
|
#puts stderr "arglen:[llength $args]" |
||||||
|
#puts stdout "_unknown '$ns' '$args'" |
||||||
|
|
||||||
|
set d_commands [get_commands -extension $extension] |
||||||
|
set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] |
||||||
|
|
||||||
|
|
||||||
|
error "Unknown subcommand \"[lindex $args 0]\": must be one of: $all_commands" "punk::mix::base _unknown $ns $args" [list unknown_ensemble_subcommand ensemble punk::mix::base] |
||||||
|
} |
||||||
|
proc _redirected {from_ns subcommand args} { |
||||||
|
#puts stderr "_redirected from_ns: $from_ns subcommand:$subcommand args:$args" |
||||||
|
set pname [namespace current]::$subcommand |
||||||
|
if {$pname in [info procs $pname]} { |
||||||
|
set argnames [info args $pname] |
||||||
|
#puts stderr "_redirected $subcommand argnames: $argnames" |
||||||
|
if {[lindex $argnames end] eq "args"} { |
||||||
|
set pos_argnames [lrange $argnames 0 end-1] |
||||||
|
} else { |
||||||
|
set pos_argnames $argnames |
||||||
|
} |
||||||
|
set argvals [list] |
||||||
|
set numargs [llength $pos_argnames] |
||||||
|
if {$numargs > 0} { |
||||||
|
set argvals [lrange $args 0 $numargs-1] |
||||||
|
set args [lrange $args $numargs end] |
||||||
|
} |
||||||
|
if {[llength $argvals] < $numargs} { |
||||||
|
error "wrong # args: $from_ns $subcommand requires args: $pos_argnames" |
||||||
|
} |
||||||
|
tailcall [namespace current] $subcommand {*}$argvals {*}$args -extension $from_ns |
||||||
|
} else { |
||||||
|
if {[regexp {.*[*?].*} $subcommand]} { |
||||||
|
set d_commands [get_commands -extension $from_ns] |
||||||
|
set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] |
||||||
|
set matched_commands [lsearch -all -inline $all_commands $subcommand] |
||||||
|
set commands "" |
||||||
|
foreach m $matched_commands { |
||||||
|
append commands $m \n |
||||||
|
} |
||||||
|
return $commands |
||||||
|
} |
||||||
|
tailcall [namespace current] $subcommand {*}$args -extension $from_ns |
||||||
|
} |
||||||
|
} |
||||||
|
proc _split_args {arglist} { |
||||||
|
#don't assume arglist is fully paired. |
||||||
|
set posn [lsearch $arglist -extension] |
||||||
|
set opts [list] |
||||||
|
if {$posn >= 0} { |
||||||
|
if {$posn+2 <= [llength $arglist]} { |
||||||
|
set opts [list -extension [lindex $arglist $posn+1]] |
||||||
|
set argsremaining [lreplace $arglist $posn $posn+1] |
||||||
|
} else { |
||||||
|
#no value supplied to -extension |
||||||
|
error "punk::mix::base::_split_args - no value found for option '-extension'. Supply a value or omit the option." |
||||||
|
} |
||||||
|
} else { |
||||||
|
set argsremaining $arglist |
||||||
|
} |
||||||
|
|
||||||
|
return [list opts $opts args $argsremaining] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#base API (potentially overridden functions - may also be called from overriding namespace) |
||||||
|
#commands should either handle or silently ignore -extension <namespace/ensemble> |
||||||
|
namespace eval punk::mix::base { |
||||||
|
namespace ensemble create |
||||||
|
namespace export help dostuff get_commands set_alias |
||||||
|
namespace ensemble configure [namespace current] -unknown punk::mix::base::_unknown |
||||||
|
proc get_commands {args} { |
||||||
|
#--------- |
||||||
|
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||||
|
lassign [_split_args $args] _opts opts _args args |
||||||
|
if {[dict exists $opts -extension]} { |
||||||
|
set extension [dict get $opts -extension] |
||||||
|
} else { |
||||||
|
set extension "" |
||||||
|
} |
||||||
|
#--------- |
||||||
|
if {![string length $extension]} { |
||||||
|
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||||
|
} |
||||||
|
|
||||||
|
set maincommands [list] |
||||||
|
#extension may still be blank e.g if punk::mix::base::get_commands called directly |
||||||
|
if {[string length $extension]} { |
||||||
|
set nsmain $extension |
||||||
|
#puts stdout "get_commands nsmain: $nsmain" |
||||||
|
set parentpatterns [namespace eval $nsmain [list namespace export]] |
||||||
|
set nscommands [list] |
||||||
|
foreach p $parentpatterns { |
||||||
|
lappend nscommands {*}[info commands ${nsmain}::$p] |
||||||
|
} |
||||||
|
foreach c $nscommands { |
||||||
|
set cmd [namespace tail $c] |
||||||
|
lappend maincommands $cmd |
||||||
|
} |
||||||
|
set maincommands [lsort $maincommands] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
set nsbase [namespace current] |
||||||
|
set basepatterns [namespace export] |
||||||
|
#puts stdout "basepatterns:$basepatterns" |
||||||
|
set nscommands [list] |
||||||
|
foreach p $basepatterns { |
||||||
|
lappend nscommands {*}[info commands ${nsbase}::$p] |
||||||
|
} |
||||||
|
|
||||||
|
set basecommands [list] |
||||||
|
foreach c $nscommands { |
||||||
|
set cmd [namespace tail $c] |
||||||
|
if {$cmd ni $maincommands} { |
||||||
|
lappend basecommands $cmd |
||||||
|
} |
||||||
|
} |
||||||
|
set basecommands [lsort $basecommands] |
||||||
|
|
||||||
|
|
||||||
|
return [list main $maincommands base $basecommands] |
||||||
|
} |
||||||
|
proc help {args} { |
||||||
|
#' **%ensemblecommand% help** *args* |
||||||
|
#' |
||||||
|
#' Help for ensemble commands in the command line interface |
||||||
|
#' |
||||||
|
#' |
||||||
|
#' Arguments: |
||||||
|
#' |
||||||
|
#' * args - first word of args is the helptopic requested - usually a command name |
||||||
|
#' - calling help with no arguments will list available commands |
||||||
|
#' |
||||||
|
#' Returns: help text (text) |
||||||
|
#' |
||||||
|
#' Examples: |
||||||
|
#' |
||||||
|
#' ``` |
||||||
|
#' %ensemblecommand% help <commandname> |
||||||
|
#' ``` |
||||||
|
#' |
||||||
|
#' |
||||||
|
|
||||||
|
|
||||||
|
#extension.= @@opts/@?@-extension,args@@args=>. [_split_args $args] {| |
||||||
|
# >} inspect -label a {| |
||||||
|
# >} .=e>end,data>end pipeswitch { |
||||||
|
# pipecase ,0/1/#= $switchargs {| |
||||||
|
# e/0 |
||||||
|
# >} .=>. {set e} |
||||||
|
# pipecase /1,1/1/#= $switchargs |
||||||
|
#} |@@ok/result> <e/0| [namespace qualifiers [lindex [info level -1] 0]] |
||||||
|
|
||||||
|
|
||||||
|
#--------- |
||||||
|
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||||
|
lassign [_split_args $args] _opts opts _args args |
||||||
|
if {[dict exists $opts -extension]} { |
||||||
|
set extension [dict get $opts -extension] |
||||||
|
} else { |
||||||
|
set extension "" |
||||||
|
} |
||||||
|
#--------- |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
if {![string length $extension]} { |
||||||
|
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||||
|
} |
||||||
|
#puts stderr "-1:[info level -1]" |
||||||
|
|
||||||
|
set command_info [punk::mix::base::get_commands -extension $extension] |
||||||
|
set subhelp1 [lindex $args 0] |
||||||
|
if {[string length $subhelp1]} { |
||||||
|
if {[regexp {[*?]} $subhelp1]} { |
||||||
|
set helpstr "" |
||||||
|
append helpstr "matched commands:\n" |
||||||
|
dict for {source cmdlist} $command_info { |
||||||
|
set matches [lsearch -all -inline -glob $cmdlist $subhelp1] |
||||||
|
if {[llength $matches]} { |
||||||
|
append helpstr \n " $source" |
||||||
|
foreach cmd $matches { |
||||||
|
append helpstr \n " - $cmd" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $helpstr |
||||||
|
} else { |
||||||
|
dict for {source cmdlist} $command_info { |
||||||
|
if {$subhelp1 in $cmdlist} { |
||||||
|
if {$source eq "base"} { |
||||||
|
set ns [namespace current] |
||||||
|
} else { |
||||||
|
set ns $extension |
||||||
|
} |
||||||
|
set procname ${ns}::$subhelp1 |
||||||
|
if {$procname in [info procs $procname]} { |
||||||
|
return "proc: $subhelp1 arguments: [info args $procname]" |
||||||
|
} else { |
||||||
|
set a [interp alias {} ${ns}::$subhelp1] |
||||||
|
if {[string length $a]} { |
||||||
|
return "alias: $subhelp1 target: $a" |
||||||
|
} else { |
||||||
|
return "command: $subhelp1 (No info available)" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return "No info found" |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
#result for just 'pmix help' |
||||||
|
puts stderr "-->$args" |
||||||
|
set helpstr "" |
||||||
|
append helpstr "limit commandlist with a glob search such as *word*" |
||||||
|
append helpstr "commands:\n" |
||||||
|
|
||||||
|
foreach {source cmdlist} $command_info { |
||||||
|
append helpstr \n " $source" |
||||||
|
foreach cmd $cmdlist { |
||||||
|
append helpstr \n " - $cmd" |
||||||
|
} |
||||||
|
} |
||||||
|
return $helpstr |
||||||
|
} |
||||||
|
#proc dostuff {args} { |
||||||
|
# extension@@opts/@?@-extension,args@@args= [_split_args $args] |
||||||
|
# puts stdout "base doingstuff-with-args:'$args'-in-namespace:'[namespace current]'" |
||||||
|
#} |
||||||
|
namespace eval lib { |
||||||
|
variable sha3_implementation "" ;#set by cksum_algorithms (which is called by cksum_path) It looks for fossil or sqlite3. Todo - add proper Tcl implementation. |
||||||
|
namespace export * |
||||||
|
|
||||||
|
#----------------------------------------------------- |
||||||
|
#literate-programming style naming for some path tests |
||||||
|
#Note the naming of the operator portion of a_op_b is consistent in that it is the higher side of the filesystem tree first. |
||||||
|
#hence aboveorat vs atorbelow |
||||||
|
#These names also sort in the logical order of higher to lower in the filesystem (when considering the root as 'higher' in the filesystem) |
||||||
|
proc path_a_above_b {path_a path_b} { |
||||||
|
#stripPath prefix path |
||||||
|
return [expr {[fileutil::stripPath $path_a $path_b] ni [list . $path_b]}] |
||||||
|
} |
||||||
|
proc path_a_aboveorat_b {path_a path_b} { |
||||||
|
return [expr {[fileutil::stripPath $path_a $path_b] ne $path_b}] |
||||||
|
} |
||||||
|
proc path_a_at_b {path_a path_b} { |
||||||
|
return [expr {[fileutil::stripPath $path_a $path_b] eq "." }] |
||||||
|
} |
||||||
|
proc path_a_atorbelow_b {path_a path_b} { |
||||||
|
return [expr {[fileutil::stripPath $path_b $path_a] ne $path_a}] |
||||||
|
} |
||||||
|
proc path_a_below_b {path_a path_b} { |
||||||
|
return [expr {[fileutil::stripPath $path_b $path_a] ni [list . $path_a]}] |
||||||
|
} |
||||||
|
proc path_a_inlinewith_b {path_a path_b} { |
||||||
|
return [expr {[path_a_aboveorat_b $path_a $path_b] || [path_a_below_b $path_a $path_b]}] |
||||||
|
} |
||||||
|
#----------------------------------------------------- |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#find src/something folders which are not certain known folders with other purposes, (such as: bootsupport .vfs folders or vendor folders etc) and contain .tm file(s) |
||||||
|
proc find_source_module_paths {{path {}}} { |
||||||
|
if {![string length [set candidate [punk::repo::find_candidate $path]]]} { |
||||||
|
error "find_source_module_paths cannot determine a suitable project root at or above path '$path' - path supplied should be within a project" |
||||||
|
} |
||||||
|
#we can return module paths even if the project isn't yet under revision control |
||||||
|
set src_subs [glob -nocomplain -dir [file join $candidate src] -type d -tail *] |
||||||
|
set antipatterns [list *.vfs vendor* lib _build doc embedded runtime bootsupport] |
||||||
|
set tm_folders [list] |
||||||
|
foreach sub $src_subs { |
||||||
|
set is_ok 1 |
||||||
|
foreach anti $antipatterns { |
||||||
|
if {[string match $anti $sub]} { |
||||||
|
set is_ok 0 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {!$is_ok} { |
||||||
|
continue |
||||||
|
} |
||||||
|
set testfolder [file join $candidate src $sub] |
||||||
|
#ensure that if src/modules exists - it is always included even if empty |
||||||
|
if {[string tolower $sub] eq "modules"} { |
||||||
|
lappend tm_folders $testfolder |
||||||
|
continue |
||||||
|
} |
||||||
|
#set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm] |
||||||
|
#set podfolders [glob -nocomplain -dir $testfolder -type d -tail #modpod-*] |
||||||
|
if {[llength [glob -nocomplain -dir $testfolder -type f -tail *.tm]] || [llength [glob -nocomplain -dir $testfolder -type d -tail #modpod-*]]} { |
||||||
|
lappend tm_folders $testfolder |
||||||
|
} |
||||||
|
} |
||||||
|
return $tm_folders |
||||||
|
} |
||||||
|
|
||||||
|
proc mix_templates_dir {} { |
||||||
|
puts stderr "mix_templates_dir WARNING: deprecated - use get_template_basefolders instead" |
||||||
|
set provide_statement [package ifneeded punk::mix [package require punk::mix]] |
||||||
|
set tmdir [file dirname [lindex $provide_statement end]] |
||||||
|
set tpldir $tmdir/mix/templates |
||||||
|
if {![file exists $tpldir]} { |
||||||
|
error "punk::mix::lib::mix_templates_dir unable to locate mix templates folder at '$tpldir'" |
||||||
|
} |
||||||
|
return $tpldir |
||||||
|
} |
||||||
|
|
||||||
|
#get_template_basefolders |
||||||
|
# startpath - file or folder |
||||||
|
# It represents the base point from which to search for templates folders either directly related to the scriptpath (../) or in the containing project if any |
||||||
|
# The cwd will also be searched for project root - but with lower precedence in the resultset (later in list) |
||||||
|
proc get_template_basefolders {{startpath ""}} { |
||||||
|
# templates from punk.templates provider packages (ordered by order in which packages registered with punk::cap) |
||||||
|
if {[file isfile $startpath]} { |
||||||
|
set startpath [file dirname $startpath] |
||||||
|
} |
||||||
|
|
||||||
|
package require punk::cap |
||||||
|
if {[punk::cap::capability_has_handler punk.templates]} { |
||||||
|
set template_folder_dict [punk::cap::call_handler punk.templates folders -startdir $startpath] |
||||||
|
} else { |
||||||
|
put stderr "get_template_basefolders WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide template locations" |
||||||
|
} |
||||||
|
|
||||||
|
#don't sort - order in which encountered defines the precedence - with later overriding earlier |
||||||
|
return $template_folder_dict |
||||||
|
} |
||||||
|
|
||||||
|
proc module_subpath {modulename} { |
||||||
|
set modulename [string trim $modulename :] |
||||||
|
set nsq [namespace qualifiers $modulename] |
||||||
|
return [string map {:: /} $nsq] |
||||||
|
} |
||||||
|
|
||||||
|
proc get_build_workdir {path} { |
||||||
|
set repo_info [punk::repo::find_repos $path] |
||||||
|
set base [lindex [dict get $repo_info project] 0] |
||||||
|
if {![string length $base]} { |
||||||
|
error "get_build_workdir unable to determine project base for path '$path'" |
||||||
|
} |
||||||
|
if {![file exists $base/src] || ![file writable $base/src]} { |
||||||
|
error "get_build_workdir unable to access $base/src" |
||||||
|
} |
||||||
|
file mkdir $base/src/_build |
||||||
|
return $base/src/_build |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#todo - move cksum stuff to punkcheck - more logical home |
||||||
|
proc cksum_path_content {path args} { |
||||||
|
dict set args -cksum_content 1 |
||||||
|
dict set args -cksum_meta 0 |
||||||
|
tailcall cksum_path $path {*}$args |
||||||
|
} |
||||||
|
|
||||||
|
#not just used by cksum_path. used by caller (e.g fill_relativecksums_from_base_and_relativepathdict via cksum_filter_opts) to determine what opt names passed through |
||||||
|
variable cksum_default_opts |
||||||
|
set cksum_default_opts [dict create -cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1] |
||||||
|
proc cksum_default_opts {} { |
||||||
|
variable cksum_default_opts |
||||||
|
return $cksum_default_opts |
||||||
|
} |
||||||
|
|
||||||
|
#crc::cksum is extremely slow in tcllib as at 2023 e.g 20x slower (no c implementation?) |
||||||
|
# - try builtin zlib crc instead? |
||||||
|
#sha1 is performant - and this is not being used in a cryptographic or adversarial context - so performance and practical unlikelihood of accidental collisions should be the main consideration. |
||||||
|
#adler32 is fastest for some larger files of a few MB but slower on small files (possibly due to Tcl-based file load?) |
||||||
|
#sha1 as at 2023 seems a reasonable default |
||||||
|
proc cksum_algorithms {} { |
||||||
|
variable sha3_implementation |
||||||
|
#sha2 is an alias for sha256 |
||||||
|
#2023 - no sha3 available in tcllib - we can exec fossil for now - which will be very slow |
||||||
|
set algs [list md5 sha1 sha2 sha256 cksum adler32] |
||||||
|
set sha3_algs [list sha3 sha3-224 sha3-256 sha3-384 sha3-512] |
||||||
|
if {[auto_execok sqlite3] ne ""} { |
||||||
|
lappend algs {*}$sha3_algs |
||||||
|
set sha3_implementation sqlite3_sha3 |
||||||
|
} else { |
||||||
|
if {[auto_execok fossil] ne ""} { |
||||||
|
lappend algs {*}$sha3_algs |
||||||
|
set sha3_implementation fossil_sha3 |
||||||
|
} |
||||||
|
} |
||||||
|
return $algs |
||||||
|
} |
||||||
|
|
||||||
|
proc sqlite3_sha3 {bits filename} { |
||||||
|
return [exec sqlite3 :memory: "select lower(hex(sha3(readfile('$filename'),$bits)))"] |
||||||
|
} |
||||||
|
proc fossil_sha3 {bits filename} { |
||||||
|
return [lindex [exec fossil sha3sum -$bits $filename] 0] |
||||||
|
} |
||||||
|
|
||||||
|
#adler32 via file-slurp |
||||||
|
proc cksum_adler32_file {filename} { |
||||||
|
package require zlib; #should be builtin anyway |
||||||
|
set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] |
||||||
|
#set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names |
||||||
|
zlib adler32 $data |
||||||
|
} |
||||||
|
#zlib crc vie file-slurp |
||||||
|
proc cksum_crc_file {filename} { |
||||||
|
package require zlib |
||||||
|
set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] |
||||||
|
zlib crc $data |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#required to be able to accept relative paths |
||||||
|
#for full cksum - using tar could reduce number of hashes to be made.. |
||||||
|
#but as it stores metadata such as permission - we don't know if/how the archive will vary based on platform/filesystem |
||||||
|
#-noperms only available on extraction - so that doesn't help |
||||||
|
#Needs to operate on non-existant paths and return empty string in cksum field |
||||||
|
proc cksum_path {path args} { |
||||||
|
variable sha3_implementation |
||||||
|
if {$path eq {}} { set path [pwd] } |
||||||
|
if {[file pathtype $path] eq "relative"} { |
||||||
|
set path [file normalize $path] |
||||||
|
} |
||||||
|
set base [file dirname $path] |
||||||
|
set startdir [pwd] |
||||||
|
|
||||||
|
set defaults [cksum_default_opts] |
||||||
|
set known_opts [dict keys $defaults] |
||||||
|
foreach {k v} $args { |
||||||
|
if {$k ni $known_opts} { |
||||||
|
error "cksum_path unknown option '$k' known_options: $known_opts" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set opts [dict merge $defaults $args] |
||||||
|
set opts_actual $opts ;#default - auto updated to 0 or 1 later |
||||||
|
|
||||||
|
#if {![file exists $path]} { |
||||||
|
# return [list cksum "" opts $opts] |
||||||
|
#} |
||||||
|
|
||||||
|
if {[catch {file type $path} ftype]} { |
||||||
|
return [list cksum "<PATHNOTFOUND>" opts $opts] |
||||||
|
} |
||||||
|
|
||||||
|
#review - links? |
||||||
|
switch -- $ftype { |
||||||
|
file - directory {} |
||||||
|
default { |
||||||
|
error "cksum_path error file type '$ftype' not supported" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set opt_cksum_algorithm [dict get $opts -cksum_algorithm] |
||||||
|
if {$opt_cksum_algorithm ni [cksum_algorithms]} { |
||||||
|
return [list error unsupported_cksum_algorithm cksum "<ERR>" opts $opts] |
||||||
|
} |
||||||
|
set opt_cksum_acls [dict get $opts -cksum_acls] |
||||||
|
if {$opt_cksum_acls} { |
||||||
|
puts stderr "cksum_path is not yet able to cksum ACLs" |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
set opt_cksum_meta [dict get $opts -cksum_meta] |
||||||
|
set opt_use_tar [dict get $opts -cksum_usetar] |
||||||
|
switch -- $ftype { |
||||||
|
file { |
||||||
|
switch -- $opt_use_tar { |
||||||
|
auto { |
||||||
|
if {$opt_cksum_meta eq "1"} { |
||||||
|
set opt_use_tar 1 |
||||||
|
} else { |
||||||
|
#prefer no tar if meta not required - faster/simpler |
||||||
|
#meta == auto or 0 |
||||||
|
set opt_cksum_meta 0 |
||||||
|
set opt_use_tar 0 |
||||||
|
} |
||||||
|
} |
||||||
|
0 { |
||||||
|
if {$opt_cksum_meta eq "1"} { |
||||||
|
puts stderr "cksum_path doesn't yet support a non-tar cksum with metadata for a file" |
||||||
|
return [list error unsupported_meta_without_tar cksum "<ERR>" opts $opts] |
||||||
|
} else { |
||||||
|
#meta == auto or 0 |
||||||
|
set opt_cksum_meta 0 |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
#tar == 1 |
||||||
|
if {$opt_cksum_meta eq "0"} { |
||||||
|
puts stderr "cksum_path doesn't yet support a tar cksum without metadata for a file" |
||||||
|
return [list error unsupported_tar_without_meta cksum "<ERR>" opts $opts] |
||||||
|
} else { |
||||||
|
#meta == auto or 1 |
||||||
|
set opt_cksum_meta 1 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
directory { |
||||||
|
switch -- $opt_use_tar { |
||||||
|
auto { |
||||||
|
if {$opt_cksum_meta in [list "auto" "1"]} { |
||||||
|
set opt_use_tar 1 |
||||||
|
set opt_cksum_meta 1 |
||||||
|
} else { |
||||||
|
puts stderr "cksum_path doesn't yet support a content-only cksum of a folder structure. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto" |
||||||
|
return [list error unsupported_directory_cksum_without_meta cksum "<ERR>" opts $opts] |
||||||
|
} |
||||||
|
} |
||||||
|
0 { |
||||||
|
puts stderr "cksum_path doesn't yet support a cksum of a folder structure without tar. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" |
||||||
|
return [list error unsupported_directory_cksum_without_tar cksum "<ERR>" opts $opts] |
||||||
|
} |
||||||
|
default { |
||||||
|
#tar 1 |
||||||
|
if {$opt_cksum_meta eq "0"} { |
||||||
|
puts stderr "cksum_path doesn't yet support a tar checksum of a folder structure without metadat. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" |
||||||
|
return [list error unsupported_without_meta cksum "<ERR>" opts $opts] |
||||||
|
} else { |
||||||
|
#meta == auto or 1 |
||||||
|
set opt_cksum_meta 1 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
dict set opts_actual -cksum_meta $opt_cksum_meta |
||||||
|
dict set opts_actual -cksum_usetar $opt_use_tar |
||||||
|
|
||||||
|
|
||||||
|
if {$opt_use_tar} { |
||||||
|
package require tar ;#from tcllib |
||||||
|
} |
||||||
|
|
||||||
|
if {$path eq $base} { |
||||||
|
#attempting to cksum at root/volume level of a filesystem.. extra work |
||||||
|
#This needs fixing for general use.. not necessarily just for project repos |
||||||
|
puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" |
||||||
|
return [list error unsupported_path opts $opts] |
||||||
|
} |
||||||
|
switch -- $opt_cksum_algorithm { |
||||||
|
sha1 { |
||||||
|
package require sha1 |
||||||
|
#review - any utf8 issues in tcl9? |
||||||
|
set cksum_command [list sha1::sha1 -hex -file] |
||||||
|
} |
||||||
|
sha2 - sha256 { |
||||||
|
package require sha256 |
||||||
|
set cksum_command [list sha2::sha256 -hex -file] |
||||||
|
} |
||||||
|
md5 { |
||||||
|
package require md5 |
||||||
|
set cksum_command [list md5::md5 -hex -file] |
||||||
|
} |
||||||
|
cksum { |
||||||
|
package require cksum ;#tcllib |
||||||
|
set cksum_command [list crc::cksum -format 0x%X -file] |
||||||
|
} |
||||||
|
crc { |
||||||
|
set cksum_command [list cksum_crc_file] |
||||||
|
} |
||||||
|
adler32 { |
||||||
|
set cksum_command [list cksum_adler32_file] |
||||||
|
} |
||||||
|
sha3 - sha3-256 { |
||||||
|
#todo - replace with something that doesn't call another process |
||||||
|
#set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] |
||||||
|
set cksum_command [list $sha3_implementation 256] |
||||||
|
} |
||||||
|
sha3-224 - sha3-384 - sah3-512 { |
||||||
|
set bits [lindex [split $opt_cksum_algorithm -] 1] |
||||||
|
#set cksum_command [list apply {{bits file} {lindex [exec fossil sha3sum -$bits $file] 0}} $bits] |
||||||
|
set cksum_command [list $sha3_implementation $bits] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set cksum "" |
||||||
|
if {$opt_use_tar != 0} { |
||||||
|
set target [file tail $path] |
||||||
|
set tmplocation [punk::mix::util::tmpdir] |
||||||
|
set archivename $tmplocation/[punk::mix::util::tmpfile].tar |
||||||
|
|
||||||
|
cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) |
||||||
|
|
||||||
|
#temp emission to stdout.. todo - repl telemetry channel |
||||||
|
puts stdout "cksum_path: creating temporary tar archive for $path" |
||||||
|
puts stdout " at: $archivename .." |
||||||
|
tar::create $archivename $target |
||||||
|
if {$ftype eq "file"} { |
||||||
|
set sizeinfo "(size [file size $target])" |
||||||
|
} else { |
||||||
|
set sizeinfo "(file type $ftype - size unknown)" |
||||||
|
} |
||||||
|
puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." |
||||||
|
set cksum [{*}$cksum_command $archivename] |
||||||
|
#puts stdout "cksum_path: cleaning up.. " |
||||||
|
file delete -force $archivename |
||||||
|
cd $startdir |
||||||
|
|
||||||
|
} else { |
||||||
|
#todo |
||||||
|
if {$ftype eq "file"} { |
||||||
|
if {$opt_cksum_meta} { |
||||||
|
return [list error unsupported_opts_combo cksum "<ERR>" opts $opts] |
||||||
|
} else { |
||||||
|
set cksum [{*}$cksum_command $path] |
||||||
|
} |
||||||
|
} else { |
||||||
|
error "cksum_path unsupported $opts for path type [file type $path]" |
||||||
|
} |
||||||
|
} |
||||||
|
set result [dict create] |
||||||
|
dict set result cksum $cksum |
||||||
|
dict set result opts $opts_actual |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
#dict_path_cksum keyed on path - with value as a dict that must contain cksum key - but can contain other keys |
||||||
|
#e.g -cksum_usetar which is one of the keys understood by the punk::mix::base::lib::cksum_path function - or unrelated keys which will also be passed through |
||||||
|
#cksum only calculated for keys in dict where cksum is empty - ie return same dict but with empty cksums filled out. |
||||||
|
#base can be empty string in which case paths must be absolute |
||||||
|
proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { |
||||||
|
if {$base eq ""} { |
||||||
|
set error_paths [list] |
||||||
|
dict for {path pathinfo} $dict_path_cksum { |
||||||
|
if {[file pathtype $path] ne "absolute"} { |
||||||
|
lappend error_paths $path |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $error_paths]} { |
||||||
|
puts stderr "get_relativecksums_from_base_and_relativepathdict has empty base - and non-absolute paths in the supplied checksum dict - aborting" |
||||||
|
puts stderr "error_paths: $error_paths" |
||||||
|
error "fill_relativecksums_from_base_and_relativepathdict error: non-absolute paths when base empty. $error_paths" |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {[file pathtype $base] ne "absolute"} { |
||||||
|
error "fill_relativecksums_from_base_and_relativepathdict error: base supplied but was not absolute path. $base" |
||||||
|
} |
||||||
|
#conversely now we have a base - so we require all paths are relative. |
||||||
|
#We will ignore/disallow volume-relative - as these shouldn't be used here either |
||||||
|
set error_paths [list] |
||||||
|
dict for {path pathinfo} $dict_path_cksum { |
||||||
|
if {[file pathtype $path] ne "relative"} { |
||||||
|
lappend error_paths $path |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $error_paths]} { |
||||||
|
puts stderr "fill_relativecksums_from_base_and_relativepathdict has a supplied absolute base path, but some of the paths in the supplied dict are not relative - aborting" |
||||||
|
error "fill_relativecksums_from_base_and_relativepathdict error: non-relative paths when base supplied. $error_paths" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
dict for {path pathinfo} $dict_path_cksum { |
||||||
|
if {![dict exists $pathinfo cksum]} { |
||||||
|
dict set pathinfo cksum "" |
||||||
|
} else { |
||||||
|
if {[dict get $pathinfo cksum] ne "" && ![cksum_is_tag [dict get $pathinfo cksum]]} { |
||||||
|
continue ;#already filled with non-tag value |
||||||
|
} |
||||||
|
} |
||||||
|
if {$base ne ""} { |
||||||
|
set fullpath [file join $base $path] |
||||||
|
} else { |
||||||
|
set fullpath $path |
||||||
|
} |
||||||
|
|
||||||
|
set ckopts [cksum_filter_opts {*}$pathinfo] |
||||||
|
|
||||||
|
if {![file exists $fullpath]} { |
||||||
|
dict set dict_path_cksum $path cksum "<PATHNOTFOUND>" |
||||||
|
} else { |
||||||
|
set ckinfo [cksum_path $fullpath {*}$ckopts] |
||||||
|
dict set dict_path_cksum $path cksum [dict get $ckinfo cksum] |
||||||
|
dict set dict_path_cksum $path cksum_all_opts [dict get $ckinfo opts] |
||||||
|
if {[dict exists $ckinfo error]} { |
||||||
|
dict set dict_path_cksum $path cksum_error [dict get $ckinfo error] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return $dict_path_cksum |
||||||
|
} |
||||||
|
#whether cksum is <XXX> e.g <ERR> <PATHNOTFOUND> |
||||||
|
proc cksum_is_tag {cksum} { |
||||||
|
expr {[string index $cksum 0] eq "<" && [string index $cksum end] eq ">"} |
||||||
|
} |
||||||
|
proc cksum_filter_opts {args} { |
||||||
|
set ck_opt_names [dict keys [cksum_default_opts]] |
||||||
|
set ck_opts [dict create] |
||||||
|
foreach {k v} $args { |
||||||
|
if {$k in $ck_opt_names} { |
||||||
|
dict set ck_opts $k $v |
||||||
|
} |
||||||
|
} |
||||||
|
return $ck_opts |
||||||
|
} |
||||||
|
|
||||||
|
#convenience so caller doesn't have to pre-calculate the relative path from the base |
||||||
|
#Note semantic difference from fill_relativecksums_from_base_and_relativepathdict (hence get_ vs fill_) |
||||||
|
#Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will ignore valid-looking prefilled cksum values |
||||||
|
#base is the presumed location to store the checksum file. The caller should retain (normalize if relative) |
||||||
|
proc get_relativecksum_from_base {base specifiedpath args} { |
||||||
|
if {$base ne ""} { |
||||||
|
#targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it |
||||||
|
#we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix |
||||||
|
if {[file pathtype $specifiedpath] eq "relative"} { |
||||||
|
if {[file pathtype $base] eq "relative"} { |
||||||
|
set normbase [file normalize $base] |
||||||
|
set normtarg [file normalize [file join $normbase $specifiedpath]] |
||||||
|
set targetpath $normtarg |
||||||
|
set storedpath [punk::path::relative $normbase $normtarg] |
||||||
|
} else { |
||||||
|
set targetpath [file join $base $specifiedpath] |
||||||
|
set storedpath $specifiedpath |
||||||
|
} |
||||||
|
} else { |
||||||
|
#specifed absolute |
||||||
|
if {[file pathtype $base] eq "relative"} { |
||||||
|
#relative to cwd or to specifiedpath? For consistency it should arguably be cwd but a case could be made that when one path is relative it is in reference to the other |
||||||
|
#there is a strong possibility that allowing this combination will cause confusion - better to disallow |
||||||
|
error "get_relativecksum_from_base error: disallowed pathtype combination. Base must be empty or absolute when specified path is absolute" |
||||||
|
} |
||||||
|
#both absolute - compute relative path if they share a common prefix |
||||||
|
set commonprefix [punk::mix::util::path_common_prefix $base $specifiedpath] |
||||||
|
if {$commonprefix eq ""} { |
||||||
|
#absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base |
||||||
|
error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" |
||||||
|
} |
||||||
|
set targetpath $specifiedpath |
||||||
|
set storedpath [punk::path::relative $base $specifiedpath] |
||||||
|
|
||||||
|
} |
||||||
|
} else { |
||||||
|
if {[file type $specifiedpath] eq "relative"} { |
||||||
|
#if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage |
||||||
|
set targetpath [file normalize $specifiedpath] |
||||||
|
set storedpath $targetpath |
||||||
|
} else { |
||||||
|
set targetpath $specifiedpath |
||||||
|
set storedpath $targetpath |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
#NOTE: specifiedpath can be a relative path (to cwd) when base is empty |
||||||
|
#OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc |
||||||
|
#possibly also: base: somewhere targetpath: ../elsewhere/etc |
||||||
|
# |
||||||
|
#todo - write tests |
||||||
|
|
||||||
|
|
||||||
|
if {([llength $args] % 2) != 0} { |
||||||
|
error "get_relativecksum_from_base error. args supplied must be in the form of key-value pairs. received '$args' " |
||||||
|
} |
||||||
|
if {[dict exists $args cksum]} { |
||||||
|
if {[dict get $args cksum] ne "" && ![cksum_is_tag [dict get $args cksum]]} { |
||||||
|
error "get_relativecksum_from_base called with existing cksum value (and is not a tag or empty-value to be replaced) cksum: [dict get $args cksum] Set cksum to be empty, any tag such as <REPLACE> or remove the key and try again." |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set ckopts [cksum_filter_opts {*}$args] |
||||||
|
set ckinfo [cksum_path $targetpath {*}$ckopts] |
||||||
|
|
||||||
|
set keyvals $args |
||||||
|
dict set keyvals cksum [dict get $ckinfo cksum] |
||||||
|
dict set keyvals cksum_all_opts [dict get $ckinfo opts] |
||||||
|
if {[dict exists $ckinfo error]} { |
||||||
|
dict set keyvals cksum_error [dict get $ckinfo error] |
||||||
|
} |
||||||
|
|
||||||
|
#set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop |
||||||
|
#storedpath is relative if possible |
||||||
|
return [dict create $storedpath $keyvals] |
||||||
|
} |
||||||
|
|
||||||
|
#calculate the runtime checksum and vfs checksums |
||||||
|
proc get_all_vfs_build_cksums {path} { |
||||||
|
set buildfolder [get_build_workdir $path] |
||||||
|
set cksum_base_folder [file dirname $buildfolder] ;#this is the <project>/src folder - a reasonable base for our vfs cksums |
||||||
|
set dict_cksums [dict create] |
||||||
|
|
||||||
|
set buildrelpath [punk::repo::path_strip_alreadynormalized_prefixdepth $buildfolder $cksum_base_folder] |
||||||
|
set vfs_tail_list [glob -nocomplain -dir $cksum_base_folder -type d -tails *.vfs] |
||||||
|
|
||||||
|
foreach vfstail $vfs_tail_list { |
||||||
|
set vname [file rootname $vfstail] |
||||||
|
dict set dict_cksums $vfstail [list cksum ""] |
||||||
|
dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] |
||||||
|
} |
||||||
|
|
||||||
|
set fullpath_buildruntime $buildfolder/buildruntime.exe |
||||||
|
|
||||||
|
set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] |
||||||
|
set ck [dict get $ckinfo_buildruntime cksum] |
||||||
|
|
||||||
|
|
||||||
|
set relpath [file join $buildrelpath "buildruntime.exe"] |
||||||
|
dict set dict_cksums $relpath [list cksum $ck] |
||||||
|
|
||||||
|
set dict_cksums [fill_relativecksums_from_base_and_relativepathdict $cksum_base_folder $dict_cksums] |
||||||
|
|
||||||
|
return $dict_cksums |
||||||
|
} |
||||||
|
|
||||||
|
proc get_vfs_build_cksums_stored {vfsfolder} { |
||||||
|
set vfscontainer [file dirname $vfsfolder] |
||||||
|
set buildfolder $vfscontainer/_build |
||||||
|
set vfs [file tail $vfsfolder] |
||||||
|
set vname [file rootname $vfs] |
||||||
|
set dict_vfs [list $vname.vfs "" $vname.exe "" buildruntime.exe ""] |
||||||
|
set ckfile $buildfolder/$vname.cksums |
||||||
|
if {[file exists $ckfile]} { |
||||||
|
set data [punk::mix::util::fcat -translation binary $ckfile] |
||||||
|
foreach ln [split $data \n] { |
||||||
|
if {[string trim $ln] eq ""} {continue} |
||||||
|
lassign $ln path cksum |
||||||
|
dict set dict_vfs $path $cksum |
||||||
|
} |
||||||
|
} |
||||||
|
return $dict_vfs |
||||||
|
} |
||||||
|
proc get_all_build_cksums_stored {path} { |
||||||
|
set buildfolder [get_build_workdir $path] |
||||||
|
|
||||||
|
set vfscontainer [file dirname $buildfolder] |
||||||
|
set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] |
||||||
|
set dict_cksums [dict create] |
||||||
|
foreach vfs $vfslist { |
||||||
|
set vname [file rootname $vfs] |
||||||
|
set dict_vfs [get_vfs_build_cksums_stored $vfscontainer/$vfs] |
||||||
|
|
||||||
|
dict set dict_cksums $vname $dict_vfs |
||||||
|
} |
||||||
|
return $dict_cksums |
||||||
|
} |
||||||
|
|
||||||
|
proc store_vfs_build_cksums {vfsfolder} { |
||||||
|
if {![file isdirectory $vfsfolder]} { |
||||||
|
error "Unable to find supplied vfsfolder: $vfsfolder" |
||||||
|
} |
||||||
|
set vfscontainer [file dirname $vfsfolder] |
||||||
|
set buildfolder $vfscontainer/_build |
||||||
|
set dict_vfs [get_vfs_build_cksums $vfsfolder] |
||||||
|
set data "" |
||||||
|
dict for {path cksum} $dict_vfs { |
||||||
|
append data "$path $cksum" \n |
||||||
|
} |
||||||
|
set fd [open $buildfolder/$vname.cksums w] |
||||||
|
chan configure $fd -translation binary |
||||||
|
puts $fd $data |
||||||
|
close $fd |
||||||
|
return $dict_vfs |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,152 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::mix::commandset::buildsuite 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::mix::commandset::buildsuite { |
||||||
|
namespace export * |
||||||
|
proc projects {suite} { |
||||||
|
set pathinfo [punk::repo::find_repos [pwd]] |
||||||
|
set projectdir [dict get $pathinfo closest] |
||||||
|
set suites_dir [file join $projectdir src buildsuites] |
||||||
|
if {![file isdirectory [file join $suites_dir $suite]]} { |
||||||
|
puts stderr "suite: $suite not found in buildsuites folder: $suites_dir" |
||||||
|
return |
||||||
|
} |
||||||
|
set suite_dir [file join $suites_dir $suite] |
||||||
|
set projects [glob -dir $suite_dir -type d -tails *] |
||||||
|
|
||||||
|
#use internal du which although breadth-first is generally faster |
||||||
|
puts stdout "Examining source folders in $suite_dir." ;#A hint that something is happening in case sources are large |
||||||
|
set du_info [punk::du::du -d 1 -b $suite_dir] |
||||||
|
set du_sizes [dict create] |
||||||
|
set suite_total_size "-" |
||||||
|
foreach du_record $du_info { |
||||||
|
if {[llength $du_record] != 2} { |
||||||
|
#sanity precaution - punk::du::du should always output list of 2 element lists - at least with flags we're using |
||||||
|
continue |
||||||
|
} |
||||||
|
set sz [lindex $du_record 0] |
||||||
|
set path_parts [file split [lindex $du_record 1]] ;#should handle spaced-paths ok. |
||||||
|
set s [lindex $path_parts end-1] |
||||||
|
set p [lindex $path_parts end] |
||||||
|
|
||||||
|
#This handles case where a project folder is same name as suite e.g src/buildsuites/tcl/tcl |
||||||
|
#so we can't just use tail as dict key. We could assume last record is always total - but |
||||||
|
if {![string match -nocase $s $suite]} { |
||||||
|
if {$s eq "buildsuites" && [string match -nocase $p $suite]} { |
||||||
|
set suite_total_size $sz ;#this includes config files in suite base - so we don't really want to use this to report the total source size |
||||||
|
} else { |
||||||
|
#something else - shouldn't happen |
||||||
|
puts stderr "Unexpected output from du in suite_dir: $suite_dir" |
||||||
|
puts stderr "$du_record" |
||||||
|
#try to continue anyway |
||||||
|
} |
||||||
|
} else { |
||||||
|
dict set du_sizes $p $sz |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#build another dict for sizes where we ensure exactly one entry for each project exists and exclude total (don't blindly trust du output e.g in case weird filename/permission issue) |
||||||
|
set psizes [list] |
||||||
|
foreach p $projects { |
||||||
|
if {[dict exists $du_sizes $p]} { |
||||||
|
dict set psizes $p [dict get $du_sizes $p] |
||||||
|
} else { |
||||||
|
dict set psizes $p - |
||||||
|
} |
||||||
|
} |
||||||
|
set total_source_size "-" |
||||||
|
if {[catch { |
||||||
|
set total_source_size [tcl::mathop::+ {*}[dict values $psizes]] |
||||||
|
} errM]} { |
||||||
|
puts stderr "Failed to calculate total source size. Errmsg: $errM" |
||||||
|
} |
||||||
|
package require overtype |
||||||
|
|
||||||
|
set title1 "Projects" |
||||||
|
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $projects] {punk::strlen $v}]] |
||||||
|
set col1 [string repeat " " $widest1] |
||||||
|
|
||||||
|
set size_values [dict values $psizes] |
||||||
|
# Title is probably widest - but go through the process anyway! |
||||||
|
set title2 "Source Bytes" |
||||||
|
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $size_values] {punk::strlen $v}]] |
||||||
|
set col2 [string repeat " " $widest2] |
||||||
|
|
||||||
|
|
||||||
|
set output "" |
||||||
|
append output "[overtype::left $col1 $title1] [overtype::right $col2 $title2]" \n |
||||||
|
foreach p [lsort $projects] { |
||||||
|
#todo - provide some basic info for each - last build time? last time-to-build? |
||||||
|
append output "[overtype::left $col1 $p] [overtype::right $col2 [dict get $psizes $p]]" \n |
||||||
|
} |
||||||
|
append output "Total Source size: $total_source_size bytes" \n |
||||||
|
return $output |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
namespace eval collection { |
||||||
|
namespace export * |
||||||
|
proc _default {{glob {}}} { |
||||||
|
if {![string length $glob]} { |
||||||
|
set glob * |
||||||
|
} |
||||||
|
#todo - review - we want the furthest not the closest if we are potentially inside a buildsuite project |
||||||
|
set pathinfo [punk::repo::find_repos [pwd]] |
||||||
|
set projectdir [dict get $pathinfo closest] |
||||||
|
set suites_dir [file join $projectdir src buildsuites] |
||||||
|
if {![file exists $suites_dir]} { |
||||||
|
puts stderr "No buildsuites folder found at $suites_dir" |
||||||
|
return |
||||||
|
} |
||||||
|
set suites [lsort [glob -dir $suites_dir -type d -tails *]] |
||||||
|
if {$glob ne "*"} { |
||||||
|
set suites [lsearch -all -inline $suites $glob] |
||||||
|
} |
||||||
|
return $suites |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::mix::commandset::buildsuite [namespace eval punk::mix::commandset::buildsuite { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
@ -0,0 +1,92 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::mix::commandset::debug 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::mix::commandset::debug { |
||||||
|
namespace export get paths |
||||||
|
namespace path ::punk::mix::cli |
||||||
|
|
||||||
|
#Except for 'get' - all debug commands should emit to stdout |
||||||
|
proc paths {} { |
||||||
|
set out "" |
||||||
|
puts stdout "find_repos output:" |
||||||
|
set pathinfo [punk::repo::find_repos [pwd]] |
||||||
|
pdict pathinfo |
||||||
|
|
||||||
|
set projectdir [dict get $pathinfo closest] |
||||||
|
set modulefolders [lib::find_source_module_paths $projectdir] |
||||||
|
puts stdout "modulefolders: $modulefolders" |
||||||
|
|
||||||
|
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||||
|
puts stdout "get_template_basefolders output:" |
||||||
|
pdict template_base_dict */* |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
#call other debug command - but capture stdout as return value |
||||||
|
proc get {args} { |
||||||
|
set nm [lindex $args 0] |
||||||
|
if {$nm eq ""} { |
||||||
|
set nscmds [info commands [namespace current]::*] |
||||||
|
set cmds [lmap v $nscmds {namespace tail $v}] |
||||||
|
error "debug.get missing debug command argument. Try one of: $cmds" |
||||||
|
return |
||||||
|
} |
||||||
|
set nextargs [lrange $args 1 end] |
||||||
|
set out "" |
||||||
|
if {[info commands [namespace current]::$nm] ne ""} { |
||||||
|
append out [runout -n -tcl [namespace current]::$nm {*}$nextargs] \n |
||||||
|
} else { |
||||||
|
set nscmds [info commands [namespace current]::*] |
||||||
|
set cmds [lmap v $nscmds {namespace tail $v}] |
||||||
|
error "debug.get invalid debug command '$nm' Try one of: $cmds" |
||||||
|
} |
||||||
|
return $out |
||||||
|
} |
||||||
|
namespace eval lib { |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::mix::commandset::debug [namespace eval punk::mix::commandset::debug { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
@ -0,0 +1,290 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::mix::commandset::doc 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
package require punk::path ;# for treefilenames, relative |
||||||
|
package require punk::repo |
||||||
|
package require punk::docgen ;#inline doctools - generate doctools .man files at src/docgen prior to using kettle to producing .html .md etc |
||||||
|
package require punk::mix::cli ;#punk::mix::cli::lib used for kettle_call |
||||||
|
#package require punk::mix::util ;#for path_relative |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::mix::commandset::doc { |
||||||
|
namespace export * |
||||||
|
|
||||||
|
proc _default {} { |
||||||
|
puts "documentation subsystem" |
||||||
|
puts "commands: doc.build" |
||||||
|
puts " build documentation from src/doc to src/embedded using the kettle build tool" |
||||||
|
puts "commands: doc.status" |
||||||
|
} |
||||||
|
|
||||||
|
proc build {} { |
||||||
|
puts "build docs" |
||||||
|
set projectdir [punk::repo::find_project] |
||||||
|
if {$projectdir eq ""} { |
||||||
|
puts stderr "No current project dir - unable to build docs" |
||||||
|
return |
||||||
|
} |
||||||
|
#user may delete the comment containing "--- punk::docgen::overwrites" and then manually edit, and we won't overwrite |
||||||
|
#we still generate output in src/docgen so user can diff and manually update if thats what they prefer |
||||||
|
set oldfiles [punk::path::treefilenames -dir $projectdir/src/doc _module_*.man] |
||||||
|
foreach maybedoomed $oldfiles { |
||||||
|
set fd [open $maybedoomed r] |
||||||
|
set data [read $fd] |
||||||
|
close $fd |
||||||
|
if {[string match "*--- punk::docgen overwrites *" $data]} { |
||||||
|
file delete -force $maybedoomed |
||||||
|
} |
||||||
|
} |
||||||
|
set generated [lib::do_docgen modules] |
||||||
|
if {[dict get $generated count] > 0} { |
||||||
|
#review |
||||||
|
set doclist [dict get $generated docs] |
||||||
|
set source_base [dict get $generated base] |
||||||
|
set target_base $projectdir/src/doc |
||||||
|
foreach dinfo $doclist { |
||||||
|
lassign $dinfo module fpath |
||||||
|
set relpath [punk::path::relative $source_base $fpath] |
||||||
|
set relfolder [file dirname $relpath] |
||||||
|
if {$relfolder eq "."} { |
||||||
|
set relfolder "" |
||||||
|
} |
||||||
|
file mkdir [file join $target_base $relfolder] |
||||||
|
set target [file join $target_base $relfolder _module_[file tail $fpath]] |
||||||
|
puts stderr "target --> $target" |
||||||
|
if {![file exists $target]} { |
||||||
|
file copy $fpath $target |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[file exists $projectdir/src/doc]} { |
||||||
|
set original_wd [pwd] |
||||||
|
cd $projectdir/src |
||||||
|
#---------- |
||||||
|
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||||
|
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||||
|
set event [$installer start_event {-install_step kettledoc}] |
||||||
|
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||||
|
$event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated |
||||||
|
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||||
|
#---------- |
||||||
|
if {\ |
||||||
|
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||||
|
} { |
||||||
|
$event targetset_started |
||||||
|
# -- --- --- --- --- --- |
||||||
|
puts stdout "BUILDING DOCS at $projectdir/src/embedded from src/doc" |
||||||
|
if {[catch { |
||||||
|
if {"::meta" eq [info commands ::meta]} { |
||||||
|
puts stderr "There appears to be a leftover ::meta command which is presumed to be from doctools. Destroying object" |
||||||
|
::meta destroy |
||||||
|
} |
||||||
|
punk::mix::cli::lib::kettle_call lib doc |
||||||
|
#Kettle doc |
||||||
|
|
||||||
|
} errM]} { |
||||||
|
$event targetset_end FAILED -note "kettle_build_doc failed: $errM" |
||||||
|
} else { |
||||||
|
$event targetset_end OK |
||||||
|
} |
||||||
|
# -- --- --- --- --- --- |
||||||
|
} else { |
||||||
|
puts stderr "No change detected in src/doc" |
||||||
|
$event targetset_end SKIPPED |
||||||
|
} |
||||||
|
$event end |
||||||
|
$event destroy |
||||||
|
$installer destroy |
||||||
|
cd $original_wd |
||||||
|
} else { |
||||||
|
puts stderr "No doc folder found at $projectdir/src/doc" |
||||||
|
} |
||||||
|
} |
||||||
|
proc status {} { |
||||||
|
set projectdir [punk::repo::find_project] |
||||||
|
if {$projectdir eq ""} { |
||||||
|
puts stderr "No current project dir - unable to check doc status" |
||||||
|
return |
||||||
|
} |
||||||
|
if {![file exists $projectdir/src/doc]} { |
||||||
|
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||||
|
return $result |
||||||
|
} |
||||||
|
set original_wd [pwd] |
||||||
|
cd $projectdir/src |
||||||
|
puts stdout "Testing status of doctools source location $projectdir/src/doc ..." |
||||||
|
flush stdout |
||||||
|
#---------- |
||||||
|
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||||
|
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||||
|
set event [$installer start_event {-install_step kettledoc}] |
||||||
|
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||||
|
$event targetset_init QUERY kettle_build_doc ;#usually VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated - but here we use QUERY to ensure no writes to .punkcheck |
||||||
|
set last_completion [$event targetset_last_complete] |
||||||
|
|
||||||
|
if {[llength $last_completion]} { |
||||||
|
#adding a source causes it to be checksummed |
||||||
|
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||||
|
#---------- |
||||||
|
set changeinfo [$event targetset_source_changes] |
||||||
|
if {\ |
||||||
|
[llength [dict get $changeinfo changed]]\ |
||||||
|
} { |
||||||
|
puts stdout "changed" |
||||||
|
puts stdout $changeinfo |
||||||
|
} else { |
||||||
|
puts stdout "No changes detected in $projectdir/src/doc tree" |
||||||
|
} |
||||||
|
} else { |
||||||
|
#no previous completion-record for this target - must assume changed - no need to trigger checksumming |
||||||
|
puts stdout "No existing record of doc build in .punkcheck. Assume it needs to be rebuilt." |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
$event destroy |
||||||
|
$installer destroy |
||||||
|
|
||||||
|
cd $original_wd |
||||||
|
} |
||||||
|
proc validate {} { |
||||||
|
#todo - run and validate punk::docgen output |
||||||
|
set projectdir [punk::repo::find_project] |
||||||
|
if {$projectdir eq ""} { |
||||||
|
puts stderr "No current project dir - unable to check doc status" |
||||||
|
return |
||||||
|
} |
||||||
|
if {![file exists $projectdir/src/doc]} { |
||||||
|
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||||
|
return $result |
||||||
|
} |
||||||
|
set original_wd [pwd] |
||||||
|
set docroot $projectdir/src/doc |
||||||
|
cd $docroot |
||||||
|
|
||||||
|
dtplite validate $docroot |
||||||
|
|
||||||
|
#punk::mix::cli::lib::kettle_call lib validate-doc |
||||||
|
|
||||||
|
cd $original_wd |
||||||
|
} |
||||||
|
|
||||||
|
namespace eval collection { |
||||||
|
variable pkg |
||||||
|
set pkg punk::mix::commandset::doc |
||||||
|
|
||||||
|
namespace export * |
||||||
|
namespace path [namespace parent] |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
namespace eval lib { |
||||||
|
variable pkg |
||||||
|
set pkg punk::mix::commandset::doc |
||||||
|
proc do_docgen {{project_subpath modules}} { |
||||||
|
#Extract doctools comments from source code |
||||||
|
set projectdir [punk::repo::find_project] |
||||||
|
set output_base [file join $projectdir src docgen] |
||||||
|
set codesource_path [file join $projectdir $project_subpath] |
||||||
|
if {![file isdirectory $codesource_path]} { |
||||||
|
puts stderr "WARNING punk::mix::commandset::doc unable to find codesource_path $codesource_path during do_docgen - skipping inline doctools generation" |
||||||
|
return |
||||||
|
} |
||||||
|
if {[file isdirectory $output_base]} { |
||||||
|
if {[catch { |
||||||
|
file delete -force $output_base |
||||||
|
}]} { |
||||||
|
error "do_docgen failed to delete existing output base folder: $output_base" |
||||||
|
} |
||||||
|
} |
||||||
|
file mkdir $output_base |
||||||
|
|
||||||
|
set matched_paths [punk::path::treefilenames -dir $codesource_path -antiglob_paths {**/mix/templates/** **/project_layouts/** **/decktemplates/** **/_aside **/_aside/**} *.tm] |
||||||
|
set count 0 |
||||||
|
set newdocs [list] |
||||||
|
set docgen_header_comments "" |
||||||
|
append docgen_header_comments {[comment {--- punk::docgen generated from inline doctools comments ---}]} \n |
||||||
|
append docgen_header_comments {[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]} \n |
||||||
|
append docgen_header_comments {[comment {--- punk::docgen overwrites this file ---}]} \n |
||||||
|
foreach fullpath $matched_paths { |
||||||
|
set doctools [punk::docgen::get_doctools_comments $fullpath] |
||||||
|
if {$doctools ne ""} { |
||||||
|
set fname [file tail $fullpath] |
||||||
|
set mod_tail [file rootname $fname] |
||||||
|
set relpath [punk::path::relative $codesource_path [file dirname $fullpath]] |
||||||
|
if {$relpath eq "."} { |
||||||
|
set relpath "" |
||||||
|
} |
||||||
|
set tailsegs [file split $relpath] |
||||||
|
set module_fullname [join $tailsegs ::]::$mod_tail |
||||||
|
set target_docname $fname.man |
||||||
|
set this_outdir [file join $output_base $relpath] |
||||||
|
|
||||||
|
if {[string length $fname] > 99} { |
||||||
|
#output needs to be tarballed to do checksum change tests in a reasonably straightforward and not-too-terribly slow way. |
||||||
|
#hack - review. Determine exact limit - test if tcllib tar fixed or if it's a limit of the particular tar format |
||||||
|
#work around tcllib tar filename length limit ( somewhere around 100?) This seems to be a limit on the length of a particular segment in the path.. not whole path length? |
||||||
|
#this case only came up because docgen used to path munge to long filenames - but left because we know there is a limit and renaming fixes it - even if it's ugly - but still allows doc generation. |
||||||
|
#review - if we're checking fname - should also test length of whole path and determine limits for tar |
||||||
|
package require md5 |
||||||
|
set target_docname [md5::md5 -hex $fullpath]_overlongfilename.man |
||||||
|
puts stderr "WARNING - overlong file name - renaming $fullpath" |
||||||
|
puts stderr " to [file dirname $fullpath]/$target_docname" |
||||||
|
} |
||||||
|
|
||||||
|
file mkdir $this_outdir |
||||||
|
puts stdout "saving [string length $doctools] bytes of doctools output from file $relpath/$fname" |
||||||
|
set outfile [file join $this_outdir $target_docname] |
||||||
|
set fd [open $outfile w] |
||||||
|
fconfigure $fd -translation binary |
||||||
|
puts -nonewline $fd $docgen_header_comments$doctools |
||||||
|
close $fd |
||||||
|
incr count |
||||||
|
lappend newdocs [list $module_fullname $outfile] |
||||||
|
} |
||||||
|
} |
||||||
|
return [list count $count docs $newdocs base $output_base] |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::mix::commandset::doc [namespace eval punk::mix::commandset::doc { |
||||||
|
variable pkg punk::mix::commandset::doc |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
@ -0,0 +1,288 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::mix::commandset::layout 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
package require punk::args |
||||||
|
#sort of a circular dependency when commandset loaded by punk::mix::cli - that's ok, but this could theoretically be loaded by another cli and with another base |
||||||
|
package require punk::mix |
||||||
|
package require punk::mix::base |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::mix::commandset::layout { |
||||||
|
namespace export * |
||||||
|
|
||||||
|
|
||||||
|
#per layout functions |
||||||
|
proc files {{layout ""}} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
*values -min 1 -max 1 |
||||||
|
layout -type string -minlen 1 |
||||||
|
} [list $layout]] |
||||||
|
|
||||||
|
set allfiles [lib::layout_all_files $layout] |
||||||
|
return [join $allfiles \n] |
||||||
|
} |
||||||
|
proc templatefiles {layout} { |
||||||
|
set templatefiles [lib::layout_scan_for_template_files $layout] |
||||||
|
return [join $templatefiles \n] |
||||||
|
} |
||||||
|
proc templatefiles.relative {layout} { |
||||||
|
|
||||||
|
set layoutdict [lib::layouts_dict] |
||||||
|
if {![dict exists $layoutdict $layout]} { |
||||||
|
puts stderr "layout '$layout' not found." |
||||||
|
return |
||||||
|
} |
||||||
|
set layoutinfo [dict get $layoutdict $layout] |
||||||
|
set layoutfolder [dict get $layoutinfo path] |
||||||
|
|
||||||
|
|
||||||
|
set stripprefix [file normalize $layoutfolder] |
||||||
|
set templatefiles [lib::layout_scan_for_template_files $layout] |
||||||
|
set tails [list] |
||||||
|
foreach templatefullpath $templatefiles { |
||||||
|
lappend tails [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] |
||||||
|
} |
||||||
|
return [join $tails \n] |
||||||
|
} |
||||||
|
|
||||||
|
#layout collection functions - to be imported with punk::overlay::import_commandset separately |
||||||
|
namespace eval collection { |
||||||
|
namespace export * |
||||||
|
proc _defaultx {{glob {}}} { |
||||||
|
if {![string length $glob]} { |
||||||
|
set glob * |
||||||
|
} |
||||||
|
set layouts [list] |
||||||
|
set layoutdict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts] |
||||||
|
#set tplfolderdict [punk::mix::base::lib::get_template_basefolders] |
||||||
|
dict for {layoutname layoutinfo} $layoutdict { |
||||||
|
lappend layouts [list $layoutname $layoutinfo] |
||||||
|
} |
||||||
|
#return [join [lsort -index 0 $layouts] \n] |
||||||
|
return [join $layouts \n] |
||||||
|
} |
||||||
|
|
||||||
|
proc _default {args} { |
||||||
|
punk::args::get_dict [subst { |
||||||
|
*proc -name ::punk::mix::commandset::layout::collection::_default |
||||||
|
-startdir -type string |
||||||
|
-not -type string -multiple 1 |
||||||
|
globsearches -default * -multiple 1 |
||||||
|
}] $args |
||||||
|
|
||||||
|
set tdict_low_to_high [as_dict {*}$args] |
||||||
|
#convert to screen order - with higher priority at the top |
||||||
|
set tdict [dict create] |
||||||
|
foreach k [lreverse [dict keys $tdict_low_to_high]] { |
||||||
|
dict set tdict $k [dict get $tdict_low_to_high $k] |
||||||
|
} |
||||||
|
|
||||||
|
package require overtype |
||||||
|
package require textblock |
||||||
|
#set pathinfolist [dict values $tdict] |
||||||
|
#set paths [lsearch -all -inline -index 1 -subindices $pathinfolist *] ;#relies on first key of templates_dict being path |
||||||
|
|
||||||
|
set names [dict keys $tdict] |
||||||
|
set paths [list] |
||||||
|
set pathtypes [list] |
||||||
|
dict for {nm tinfo} $tdict { |
||||||
|
lappend paths [dict get $tinfo path] |
||||||
|
lappend pathtypes [dict get $tinfo sourceinfo pathtype] |
||||||
|
} |
||||||
|
|
||||||
|
set title(path) "Path" |
||||||
|
set widest(path) [tcl::mathfunc::max {*}[lmap v [concat [list $title(path)] $paths] {punk::strlen $v}]] |
||||||
|
set col(path) [string repeat " " $widest(path)] |
||||||
|
|
||||||
|
set title(pathtype) "[a+ green]Path Type[a]" |
||||||
|
set widest(pathtype) [tcl::mathfunc::max {*}[lmap v [concat [list $title(pathtype)] $pathtypes] {punk::strlen $v}]] |
||||||
|
set col(pathtype) [string repeat " " $widest(pathtype)] |
||||||
|
|
||||||
|
set title(name) "Layout Name" |
||||||
|
set widest(name) [tcl::mathfunc::max {*}[lmap v [concat [list $title(name)] $names] {punk::strlen $v}]] |
||||||
|
set col(name) [string repeat " " $widest(name)] |
||||||
|
|
||||||
|
set vsep " | " |
||||||
|
set vsep_w [string length $vsep] ;#unicode? |
||||||
|
set tablewidth [expr {$widest(name) + $vsep_w + $widest(pathtype) + $vsep_w + $widest(path)}] |
||||||
|
set table "" |
||||||
|
append table [string repeat - $tablewidth] \n |
||||||
|
append table "[textblock::join -- [overtype::left $col(name) $title(name)] $vsep [overtype::left $col(pathtype) $title(pathtype)] $vsep [overtype::left $col(path) $title(path)]]" \n |
||||||
|
append table [string repeat - $tablewidth] \n |
||||||
|
|
||||||
|
foreach n $names pt $pathtypes p $paths { |
||||||
|
append table "[textblock::join -- [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n |
||||||
|
} |
||||||
|
|
||||||
|
return $table |
||||||
|
} |
||||||
|
proc references {args} { |
||||||
|
set tdict_low_to_high [references_as_dict {*}$args] |
||||||
|
#convert to screen order - with higher priority at the top |
||||||
|
set tdict [dict create] |
||||||
|
foreach k [lreverse [dict keys $tdict_low_to_high]] { |
||||||
|
dict set tdict $k [dict get $tdict_low_to_high $k] |
||||||
|
} |
||||||
|
|
||||||
|
package require overtype |
||||||
|
package require textblock |
||||||
|
#set pathinfolist [dict values $tdict] |
||||||
|
#set paths [lsearch -all -inline -index 1 -subindices $pathinfolist *] ;#relies on first key of templates_dict being path |
||||||
|
|
||||||
|
set names [dict keys $tdict] |
||||||
|
set paths [list] |
||||||
|
set pathtypes [list] |
||||||
|
dict for {nm tinfo} $tdict { |
||||||
|
lappend paths [dict get $tinfo path] |
||||||
|
lappend pathtypes [dict get $tinfo sourceinfo pathtype] |
||||||
|
} |
||||||
|
|
||||||
|
set title(path) "Path" |
||||||
|
set widest(path) [tcl::mathfunc::max {*}[lmap v [concat [list $title(path)] $paths] {punk::strlen $v}]] |
||||||
|
set col(path) [string repeat " " $widest(path)] |
||||||
|
|
||||||
|
set title(pathtype) "[a+ green]Path Type[a]" |
||||||
|
set widest(pathtype) [tcl::mathfunc::max {*}[lmap v [concat [list $title(pathtype)] $pathtypes] {punk::strlen $v}]] |
||||||
|
set col(pathtype) [string repeat " " $widest(pathtype)] |
||||||
|
|
||||||
|
set title(name) "Layout Name" |
||||||
|
set widest(name) [tcl::mathfunc::max {*}[lmap v [concat [list $title(name)] $names] {punk::strlen $v}]] |
||||||
|
set col(name) [string repeat " " $widest(name)] |
||||||
|
|
||||||
|
set vsep " | " |
||||||
|
set vsep_w [string length $vsep] ;#unicode? |
||||||
|
set tablewidth [expr {$widest(name) + $vsep_w + $widest(pathtype) + $vsep_w + $widest(path)}] |
||||||
|
set table "" |
||||||
|
append table [string repeat - $tablewidth] \n |
||||||
|
append table "[textblock::join -- [overtype::left $col(name) $title(name)] $vsep [overtype::left $col(pathtype) $title(pathtype)] $vsep [overtype::left $col(path) $title(path)]]" \n |
||||||
|
append table [string repeat - $tablewidth] \n |
||||||
|
|
||||||
|
foreach n $names pt $pathtypes p $paths { |
||||||
|
append table "[textblock::join -- [overtype::left $col(name) $n] $vsep [overtype::left $col(pathtype) $pt] $vsep [overtype::left $col(path) $p]]" \n |
||||||
|
} |
||||||
|
|
||||||
|
return $table |
||||||
|
} |
||||||
|
|
||||||
|
proc as_dict {args} { |
||||||
|
tailcall punk::mix::commandset::layout::lib::layouts_dict {*}$args |
||||||
|
} |
||||||
|
proc references_as_dict {args} { |
||||||
|
package require punk::cap |
||||||
|
if {[punk::cap::capability_has_handler punk.templates]} { |
||||||
|
set ref_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayoutrefs {*}$args] |
||||||
|
} else { |
||||||
|
put stderr "commandset::layout::lib::layouts_dict WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide template locations" |
||||||
|
} |
||||||
|
return $ref_dict |
||||||
|
} |
||||||
|
} |
||||||
|
namespace eval lib { |
||||||
|
proc layouts_dict {args} { |
||||||
|
package require punk::cap |
||||||
|
if {[punk::cap::capability_has_handler punk.templates]} { |
||||||
|
set layout_dict [punk::cap::call_handler punk.templates get_itemdict_projectlayouts {*}$args] |
||||||
|
} else { |
||||||
|
put stderr "commandset::layout::lib::layouts_dict WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide template locations" |
||||||
|
} |
||||||
|
return $layout_dict |
||||||
|
} |
||||||
|
|
||||||
|
proc layout_all_files {layout} { |
||||||
|
#todo - allow versionless layout name to pick highest version found |
||||||
|
set layoutdict [layouts_dict] |
||||||
|
if {![dict exists $layoutdict $layout]} { |
||||||
|
puts stderr "layout '$layout' not found." |
||||||
|
return |
||||||
|
} |
||||||
|
set layoutinfo [dict get $layoutdict $layout] |
||||||
|
set layoutfolder [dict get $layoutinfo path] |
||||||
|
if {![file isdirectory $layoutfolder]} { |
||||||
|
puts stderr "layout '$layout' points to path $layoutfolder - but it doesn't seem to exist" |
||||||
|
} |
||||||
|
set file_list [list] |
||||||
|
util::foreach-file $layoutfolder path { |
||||||
|
lappend file_list $path |
||||||
|
} |
||||||
|
|
||||||
|
return $file_list |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
proc layout_scan_for_template_files {layout {tags {}}} { |
||||||
|
#todo JMN |
||||||
|
set layoutdict [layouts_dict] |
||||||
|
if {![dict exists $layoutdict $layout]} { |
||||||
|
puts stderr "layout '$layout' not found." |
||||||
|
return |
||||||
|
} |
||||||
|
set layoutinfo [dict get $layoutdict $layout] |
||||||
|
set layoutfolder [dict get $layoutinfo path] |
||||||
|
|
||||||
|
#use last matching layout found. review silent if multiple? |
||||||
|
if {![llength $tags]} { |
||||||
|
#todo - get standard tags from somewhere |
||||||
|
set tagnames [list project] |
||||||
|
foreach tn $tagnames { |
||||||
|
lappend tags [string cat % $tn %] |
||||||
|
} |
||||||
|
} |
||||||
|
set file_list [list] |
||||||
|
util::foreach-file $layoutfolder path { |
||||||
|
set fd [open $path r] |
||||||
|
fconfigure $fd -translation binary |
||||||
|
set data [read $fd] |
||||||
|
close $fd |
||||||
|
foreach tag $tags { |
||||||
|
if {[string match "*$tag*" $data]} { |
||||||
|
lappend file_list $path |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return $file_list |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::mix::commandset::layout [namespace eval punk::mix::commandset::layout { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
@ -0,0 +1,593 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::mix::commandset::loadedlib 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
package require punk::ns |
||||||
|
package require punk::lib |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::mix::commandset::loadedlib { |
||||||
|
namespace export * |
||||||
|
#search automatically wrapped in * * - can contain inner * ? globs |
||||||
|
proc search {args} { |
||||||
|
set argspecs { |
||||||
|
*proc -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter" |
||||||
|
-return -type string -default table -choices {table tableobject list lines} |
||||||
|
-present -type integer -default 2 -choices {0 1 2} -choicelabels {absent present both} -help "(unimplemented) Display only those that are 0:absent 1:present 2:both" |
||||||
|
-highlight -type boolean -default 1 -help "Highlight which version is present with ansi underline and colour" |
||||||
|
-refresh -default 0 -type boolean -help "Re-scan the tm and library folders" |
||||||
|
searchstrings -default * -multiple 1 -help "Names to search for, may contain glob chars (* ?) e.g *lib* |
||||||
|
If no glob chars are explicitly specified, the searchstring will be wrapped with star globs. |
||||||
|
eg name -> *name* |
||||||
|
" |
||||||
|
} |
||||||
|
set argd [punk::args::get_dict $argspecs $args] |
||||||
|
set searchstrings [dict get $argd values searchstrings] |
||||||
|
set opts [dict get $argd opts] |
||||||
|
set opt_return [dict get $opts -return] |
||||||
|
set opt_highlight [dict get $opts -highlight] |
||||||
|
|
||||||
|
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything |
||||||
|
if {[catch {package require natsort}]} { |
||||||
|
set has_natsort 0 |
||||||
|
} else { |
||||||
|
set has_natsort 1 |
||||||
|
} |
||||||
|
set packages [package names] |
||||||
|
set matches [list] |
||||||
|
foreach search $searchstrings { |
||||||
|
if {[regexp {[?*]} $search]} { |
||||||
|
#caller has specified specific glob pattern - use it |
||||||
|
#todo - respect supplied case only if uppers present? require another flag? |
||||||
|
lappend matches {*}[lsearch -all -inline -nocase $packages $search] |
||||||
|
} elseif {[string match =* $search]} { |
||||||
|
lappend matches {*}[lsearch -all -inline -exact $packages [string range $search 1 end]] |
||||||
|
} else { |
||||||
|
#make it easy to search for anything |
||||||
|
lappend matches {*}[lsearch -all -inline -nocase $packages "*$search*"] |
||||||
|
} |
||||||
|
} |
||||||
|
set matches [lsort -unique $matches][unset matches] |
||||||
|
set matchinfo [list] |
||||||
|
set highlight_ansi [a+ web-limegreen underline] |
||||||
|
set RST [a] |
||||||
|
foreach m $matches { |
||||||
|
set versions [package versions $m] |
||||||
|
if {![llength $versions]} { |
||||||
|
#e.g builtins such as zlib - shows no versions - but will show version when package present/provide used |
||||||
|
set versions [package provide $m] |
||||||
|
#if {![catch {package present $m} v]} { |
||||||
|
# set versions $v |
||||||
|
#} |
||||||
|
} |
||||||
|
if {$has_natsort} { |
||||||
|
set versions [natsort::sort $versions] |
||||||
|
} else { |
||||||
|
set versions [lsort $versions] |
||||||
|
} |
||||||
|
if {$opt_highlight} { |
||||||
|
set v [package provide $m] |
||||||
|
if {$v ne ""} { |
||||||
|
set posn [lsearch $versions $v] |
||||||
|
if {$posn >= 0} { |
||||||
|
#FIXME! (probably in textblock::pad ?) |
||||||
|
#TODO - determine why underline is extended to padding even with double reset. (space or other char required to prevent) |
||||||
|
set highlighted "$highlight_ansi$v$RST $RST" |
||||||
|
set versions [lreplace $versions $posn $posn $highlighted] |
||||||
|
} else { |
||||||
|
#shouldn't be possible? |
||||||
|
puts stderr "failed to find version '$v' in versions:$versions for package $m" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
lappend matchinfo [list $m $versions] |
||||||
|
} |
||||||
|
switch -- $opt_return { |
||||||
|
list { |
||||||
|
return $matchinfo |
||||||
|
} |
||||||
|
lines { |
||||||
|
return [join $matchinfo \n] |
||||||
|
} |
||||||
|
table - tableobject { |
||||||
|
set t [textblock::class::table new] |
||||||
|
$t add_column -headers "Package" |
||||||
|
$t add_column -headers "Version" |
||||||
|
$t configure -show_hseps 0 |
||||||
|
foreach m $matchinfo { |
||||||
|
$t add_row [list [lindex $m 0] [join [lindex $m 1] " "]] |
||||||
|
} |
||||||
|
if {$opt_return eq "tableobject"} { |
||||||
|
return $t |
||||||
|
} |
||||||
|
set result [$t print] |
||||||
|
$t destroy |
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
proc loaded.search {searchstring} { |
||||||
|
set search_result [search $searchstring] |
||||||
|
set all_libs [split $search_result \n] |
||||||
|
set col1items [list] |
||||||
|
set col2items [list] |
||||||
|
set col3items [list] |
||||||
|
foreach libinfo $all_libs { |
||||||
|
if {[string trim $libinfo] eq ""} { |
||||||
|
continue |
||||||
|
} |
||||||
|
set versions [lassign $libinfo libname] |
||||||
|
if {[set ver [package provide $libname]] ne ""} { |
||||||
|
lappend col1items $libname |
||||||
|
lappend col2items $versions |
||||||
|
lappend col3items $ver |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
package require overtype |
||||||
|
set title1 "Library" |
||||||
|
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {string length $v}]] |
||||||
|
set col1 [string repeat " " $widest1] |
||||||
|
set title2 "Versions Avail." |
||||||
|
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {string length $v}]] |
||||||
|
set col2 [string repeat " " $widest2] |
||||||
|
set title3 "Loaded Version" |
||||||
|
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {string length $v}]] |
||||||
|
set col3 [string repeat " " $widest3] |
||||||
|
|
||||||
|
|
||||||
|
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}] |
||||||
|
|
||||||
|
set table "" |
||||||
|
append table [string repeat - $tablewidth] \n |
||||||
|
append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n |
||||||
|
append table [string repeat - $tablewidth] \n |
||||||
|
foreach c1 $col1items c2 $col2items c3 $col3items { |
||||||
|
append table "[overtype::left $col1 $c1] [overtype::left $col2 $c2] [overtype::left $col3 $c3]" \n |
||||||
|
} |
||||||
|
|
||||||
|
return $table |
||||||
|
|
||||||
|
|
||||||
|
set loaded_libs [list] |
||||||
|
foreach libinfo $all_libs { |
||||||
|
if {[string trim $libinfo] eq ""} { |
||||||
|
continue |
||||||
|
} |
||||||
|
set versions [lassign $libinfo libname] |
||||||
|
if {[set ver [package provide $libname]] ne ""} { |
||||||
|
lappend loaded_libs "$libname $versions (loaded $ver)" |
||||||
|
} |
||||||
|
} |
||||||
|
return [join $loaded_libs \n] |
||||||
|
} |
||||||
|
|
||||||
|
proc info {libname} { |
||||||
|
if {[catch {package require natsort}]} { |
||||||
|
set has_natsort 0 |
||||||
|
} else { |
||||||
|
set has_natsort 1 |
||||||
|
} |
||||||
|
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything |
||||||
|
set pkgsknown [package names] |
||||||
|
if {[set posn [lsearch $pkgsknown $libname]] >= 0} { |
||||||
|
puts stdout "Found package [lindex $pkgsknown $posn]" |
||||||
|
} else { |
||||||
|
puts stderr "Package not found as available library/module - check tcl::tm::list and \$auto_path" |
||||||
|
} |
||||||
|
set versions [package versions [lindex $libname 0]] |
||||||
|
if {$has_natsort} { |
||||||
|
set versions [natsort::sort $versions] |
||||||
|
} else { |
||||||
|
set versions [lsort $versions] |
||||||
|
} |
||||||
|
if {![llength $versions]} { |
||||||
|
puts stderr "No version numbers found for library/module $libname" |
||||||
|
return false |
||||||
|
} |
||||||
|
puts stdout "Versions of $libname found: $versions" |
||||||
|
set alphaposn [lsearch $versions "999999.*"] |
||||||
|
if {$alphaposn >= 0} { |
||||||
|
set alpha [lindex $versions $alphaposn] |
||||||
|
#remove and tack onto beginning.. |
||||||
|
set versions [lreplace $versions $alphaposn $alphaposn] |
||||||
|
set versions [list $alpha {*}$versions] |
||||||
|
} |
||||||
|
foreach ver $versions { |
||||||
|
set loadinfo [package ifneeded $libname $ver] |
||||||
|
puts stdout "$libname $ver" |
||||||
|
puts stdout "--- 'package ifneeded' script ---" |
||||||
|
puts stdout $loadinfo |
||||||
|
puts stdout "---" |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc copyasmodule {library modulefoldername args} { |
||||||
|
set defaults [list -askme 1] |
||||||
|
set opts [dict merge $defaults $args] |
||||||
|
set opt_askme [dict get $opts -askme] |
||||||
|
|
||||||
|
if {[catch {package require natsort}]} { |
||||||
|
set has_natsort 0 |
||||||
|
} else { |
||||||
|
set has_natsort 1 |
||||||
|
} |
||||||
|
|
||||||
|
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything |
||||||
|
|
||||||
|
if {[file pathtype $modulefoldername] eq "absolute"} { |
||||||
|
if {![file exists $modulefoldername]} { |
||||||
|
error "Path '$modulefoldername' not found. Enter a fully qualified path, or just the tail such as 'modules' if you are within the project to use <projectdir>/src/modules" |
||||||
|
} |
||||||
|
#use the target folder as the source of projectdir info |
||||||
|
set pathinfo [punk::repo::find_repos $modulefoldername] |
||||||
|
set projectdir [dict get $pathinfo closest] |
||||||
|
set modulefolder_path $modulefoldername |
||||||
|
} else { |
||||||
|
#use the current working directory as the source of projectdir info |
||||||
|
set pathinfo [punk::repo::find_repos [pwd]] |
||||||
|
set projectdir [dict get $pathinfo closest] |
||||||
|
if {$projectdir ne ""} { |
||||||
|
set modulefolders [punk::mix::cli::lib::find_source_module_paths $projectdir] |
||||||
|
foreach k [list modules vendormodules] { |
||||||
|
set knownfolder [file join $projectdir src $k] |
||||||
|
if {$knownfolder ni $modulefolders} { |
||||||
|
lappend modulefolders $knownfolder |
||||||
|
} |
||||||
|
} |
||||||
|
set mtails [list] |
||||||
|
foreach path $modulefolders { |
||||||
|
lappend mtails [file tail $path] |
||||||
|
} |
||||||
|
|
||||||
|
#special case bootsupport/modules so it can be referred to as just bootsupport or bootsupport/modules |
||||||
|
lappend modulefolders [file join $projectdir src bootsupport/modules] |
||||||
|
|
||||||
|
if {$modulefoldername ni $mtails && $modulefoldername ni "bootsupport bootsupport/modules"} { |
||||||
|
set msg "Suplied modulefoldername '$modulefoldername' doesn't appear to be a known module folder within the project at $projectdir\n" |
||||||
|
append msg "Known module folders: [lsort $mtails]\n" |
||||||
|
append msg "Use a name from the above list, or a fully qualified path\n" |
||||||
|
error $msg |
||||||
|
} |
||||||
|
|
||||||
|
if {$modulefoldername eq "bootsupport"} { |
||||||
|
set modulefoldername "bootsupport/modules" |
||||||
|
} |
||||||
|
set modulefolder_path [file join $projectdir src $modulefoldername] |
||||||
|
} else { |
||||||
|
set msg "No current project found at or above current directory\n" |
||||||
|
append msg "Supplied modulefoldername '$modulefoldername' is a name or relative path - cannot use when outside a project." \n |
||||||
|
append msg "Supply an absolute path for the target modulefolder, or try again from within a project directory" \n |
||||||
|
error $msg |
||||||
|
} |
||||||
|
} |
||||||
|
puts stdout "-----------------------------" |
||||||
|
if {$projectdir ne ""} { |
||||||
|
puts stdout "Using projectdir: $projectdir for lib.copyasmodule" |
||||||
|
} else { |
||||||
|
puts stdout "No current project." |
||||||
|
} |
||||||
|
puts stdout "-----------------------------" |
||||||
|
if {![file exists $modulefolder_path]} { |
||||||
|
error "Selected module folder path '$modulefolder_path' doesn't exist. Required subdirectories for namespaced modules will be created automatically - but base selected folder must exist first" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set libfound [lsearch -all -inline [package names] $library] |
||||||
|
if {[llength $libfound] != 1 || ![string length $libfound]} { |
||||||
|
error "Library must match exactly one entry in the list of package names visible to the current interpretor: found '$libfound'" |
||||||
|
} |
||||||
|
|
||||||
|
set versions [package versions [lindex $libfound 0]] |
||||||
|
if {$has_natsort} { |
||||||
|
set versions [natsort::sort $versions] |
||||||
|
} else { |
||||||
|
set versions [lsort $versions] |
||||||
|
} |
||||||
|
if {![llength $versions]} { |
||||||
|
error "No version numbers found for library/module $libfound - sorry, you will need to copy it across manually" |
||||||
|
} |
||||||
|
puts stdout "Versions of $libfound found: $versions" |
||||||
|
set alphaposn [lsearch $versions "999999.*"] |
||||||
|
if {$alphaposn >= 0} { |
||||||
|
set alpha [lindex $versions $alphaposn] |
||||||
|
#remove and tack onto beginning.. |
||||||
|
set versions [lreplace $versions $alphaposn $alphaposn] |
||||||
|
set versions [list $alpha {*}$versions] |
||||||
|
} |
||||||
|
|
||||||
|
set ver [lindex $versions end] ;# todo - make selectable! don't assume tail is latest?.. package vcompare? |
||||||
|
if {[llength $versions] > 1} { |
||||||
|
puts stdout "Version selected: $ver" |
||||||
|
} |
||||||
|
|
||||||
|
set loadinfo [package ifneeded $libfound $ver] |
||||||
|
set loadinfo [string map {\r\n \n} $loadinfo] |
||||||
|
set loadinfo_lines [split $loadinfo \n] |
||||||
|
if {[catch {llength $loadinfo}]} { |
||||||
|
set loadinfo_is_listshaped 0 |
||||||
|
} else { |
||||||
|
set loadinfo_is_listshaped 1 |
||||||
|
} |
||||||
|
|
||||||
|
#check for redirection to differently cased version of self - this is only detected if this is the only command in the package ifneeded result |
||||||
|
#- must have matching version. REVIEW this requirement. Is there a legitimate reason to divert to a differently cased other-version? |
||||||
|
set is_package_require_self_recased 0 |
||||||
|
set is_package_require_diversion 0 |
||||||
|
set lib_diversion_name "" |
||||||
|
if {[llength $loadinfo_lines] == 1} { |
||||||
|
#e.g Thread 3.0b1 diverts to thread 3.0b1 |
||||||
|
set line1 [lindex $loadinfo_lines 0] |
||||||
|
#check if multiparted with semicolon |
||||||
|
#We need to distinguish "package require <lib> <ver>; more stuff" from "package require <lib> ver> ;" possibly with trailing comment? |
||||||
|
set parts [list] |
||||||
|
if {[regexp {;} $line1]} { |
||||||
|
foreach p [split $line1 {;}] { |
||||||
|
set p [string trim $p] |
||||||
|
if {[string length $p]} { |
||||||
|
#only append parts with some content that doesn't look like a comment |
||||||
|
if {![string match "#*" $p]} { |
||||||
|
lappend parts $p |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
if {[llength $parts] == 1} { |
||||||
|
#seems like a lone package require statement. |
||||||
|
#check if package require, package\trequire etc |
||||||
|
if {[string match "package*require" [lrange $line1 0 1]]} { |
||||||
|
set is_package_require_diversion 1 |
||||||
|
if {[lindex $line1 2] eq "-exact"} { |
||||||
|
#package require -exact <pkg> <ver> |
||||||
|
set lib_diversion_name [lindex $line1 3] |
||||||
|
#check not an exact match - but is a -nocase match - i.e differs in case only |
||||||
|
if {($lib_diversion_name ne $libfound) && [string match -nocase $lib_diversion_name $libfound]} { |
||||||
|
if {[lindex $line1 4] eq $ver} { |
||||||
|
set is_package_require_self_recased 1 |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
#may be package require <pkg> <ver> |
||||||
|
#or package require <pkg> <ver> ?<ver>?... |
||||||
|
set lib_diversion_name [lindex $line1 2] |
||||||
|
#check not an exact match - but is a -nocase match - i.e differs in case only |
||||||
|
if {($lib_diversion_name ne $libfound) && [string match -nocase $lib_diversion_name $libfound]} { |
||||||
|
set requiredversions [lrange $line1 3 end] |
||||||
|
if {$ver in $requiredversions} { |
||||||
|
set is_package_require_self_recased 1 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$is_package_require_self_recased && [string length $lib_diversion_name]} { |
||||||
|
#we only follow one level of package require redirection - seems unlikely/imprudent to follow arbitrarily in a while loop(?) |
||||||
|
set libfound $lib_diversion_name |
||||||
|
set loadinfo [package ifneeded $libfound $ver] |
||||||
|
set loadinfo [string map {\r\n \n} $loadinfo] |
||||||
|
set loadinfo_lines [split $loadinfo \n] |
||||||
|
if {[catch {llength $loadinfo}]} { |
||||||
|
set loadinfo_is_listshaped 0 |
||||||
|
} else { |
||||||
|
set loadinfo_is_listshaped 1 |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
} else { |
||||||
|
if {$is_package_require_diversion} { |
||||||
|
#single |
||||||
|
#for now - we'll abort and tell the user to run again with specified pkg/version |
||||||
|
#We could automate - but it seems likely to be surprising. |
||||||
|
puts stderr "Loadinfo for $libfound seems to be diverting to another pkg/version: $loadinfo_lines" |
||||||
|
puts stderr "Review and consider trying with the pkg/version described in the result above." |
||||||
|
return |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
if {$loadinfo_is_listshaped && ([llength $loadinfo] == 2 && [lindex $loadinfo 0] eq "source")} { |
||||||
|
set source_file [lindex $loadinfo 1] |
||||||
|
} elseif {[string match "*source*" $loadinfo]} { |
||||||
|
set parts [list] |
||||||
|
foreach ln $loadinfo_lines { |
||||||
|
if {![string length $ln]} {continue} |
||||||
|
lappend parts {*}[split $ln ";"] |
||||||
|
} |
||||||
|
set sources_found [list] |
||||||
|
set loads_found [list] |
||||||
|
set dependencies [list] |
||||||
|
set incomplete_lines [list] |
||||||
|
foreach p $parts { |
||||||
|
set p [string trim $p] |
||||||
|
if {![string length $p]} { |
||||||
|
continue ;#empty line or trailing colon |
||||||
|
} |
||||||
|
if {[string match "*tclPkgSetup*" $p]} { |
||||||
|
puts stderr "Unable to process load script for library $libfound" |
||||||
|
puts stderr "The library appears to use the deprecated tcl library support utility 'tclPkgSetup'" |
||||||
|
return false |
||||||
|
} |
||||||
|
if {![::info complete $p]} { |
||||||
|
# |
||||||
|
#probably a perfectly valid script - but slightly more complicated than we can handle |
||||||
|
#better to defer to manual processing |
||||||
|
lappend incomplete_lines $p |
||||||
|
continue |
||||||
|
} |
||||||
|
if {[lindex $p 0] eq "source"} { |
||||||
|
#may have args.. e.g -encoding utf-8 |
||||||
|
lappend sources_found [lindex $p end] |
||||||
|
} |
||||||
|
if {[lindex $p 0] eq "load"} { |
||||||
|
lappend loads_found [lrange $p 1 end] |
||||||
|
} |
||||||
|
if {[lrange $p 0 1] eq "package require"} { |
||||||
|
lappend dependencies [lrange $p 2 end] |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $incomplete_lines]} { |
||||||
|
puts stderr "unable to interpret load script for library $libfound" |
||||||
|
puts stderr "Load info: $loadinfo" |
||||||
|
return false |
||||||
|
} |
||||||
|
if {[llength $loads_found]} { |
||||||
|
puts stderr "package $libfound appears to have binary components" |
||||||
|
foreach l $loads_found { |
||||||
|
puts stderr " binary - $l" |
||||||
|
} |
||||||
|
foreach s $sources_found { |
||||||
|
puts stderr " script - $s" |
||||||
|
} |
||||||
|
puts stderr "Unable to automatically copy binary libraries to your module folder." |
||||||
|
return false |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength $sources_found] != 1} { |
||||||
|
puts stderr "sorry - unable to interpret source library location" |
||||||
|
puts stderr "Only 1 source supported for now" |
||||||
|
puts stderr "Load info: $loadinfo" |
||||||
|
return false |
||||||
|
} |
||||||
|
if {[llength $dependencies]} { |
||||||
|
#todo - check/ignore if dependency is Tcl ? |
||||||
|
puts stderr "WARNING the package appears to depend on at least one other. Review and copy dependencies if required." |
||||||
|
foreach d $dependencies { |
||||||
|
puts stderr " - $d" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set source_file [lindex $sources_found 0] |
||||||
|
} else { |
||||||
|
puts stderr "sorry - unable to interpret source library location" |
||||||
|
puts stderr "Load info: $loadinfo" |
||||||
|
return false |
||||||
|
} |
||||||
|
|
||||||
|
# -- --------------------------------------- |
||||||
|
#Analyse source file |
||||||
|
if {![file exists $source_file]} { |
||||||
|
error "Unable to verify source file existence at: $source_file" |
||||||
|
} |
||||||
|
set source_data [fcat -translation binary $source_file] |
||||||
|
if {![string match "*package provide*" $source_data]} { |
||||||
|
puts stderr "Sorry - unable to verify source file contains 'package provide' statement of some sort - copy manually" |
||||||
|
return false |
||||||
|
} else { |
||||||
|
if {![string match "*$libfound*" $source_data]} { |
||||||
|
# as an exception - look for the specific 'package provide $pkg $version' as occurs in the auto-name auto-version modules |
||||||
|
#e.g anyname-0.1.tm example |
||||||
|
if {![string match "*package provide \$pkg \$version*" $source_data]} { |
||||||
|
puts stderr "Sorry - unable to verify source file contains 'package provide' and '$libfound' - copy manually" |
||||||
|
return false |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
if {[string match "*lappend ::auto_path*" $source_data] || [string match "*lappend auto_path*" $source_data] || [string match "*set ::auto_path*" $source_data]} { |
||||||
|
puts stderr "Sorry - '$libfound' source file '$source_file' appears to rely on ::auto_path and can't be automatically copied as a .tm module" |
||||||
|
puts stderr "Copy the library across to a lib folder instead" |
||||||
|
return false |
||||||
|
} |
||||||
|
# -- --------------------------------------- |
||||||
|
|
||||||
|
set moduleprefix [punk::ns::nsprefix $libfound] |
||||||
|
if {[string length $moduleprefix]} { |
||||||
|
set moduleprefix_parts [punk::ns::nsparts $moduleprefix] |
||||||
|
set relative_path [file join {*}$moduleprefix_parts] |
||||||
|
} else { |
||||||
|
set relative_path "" |
||||||
|
} |
||||||
|
set pkgtail [punk::ns::nstail $libfound] |
||||||
|
set target_path [file join $modulefolder_path $relative_path ${pkgtail}-${ver}.tm] |
||||||
|
|
||||||
|
if {$opt_askme} { |
||||||
|
puts stdout "WARNING - you should check that there aren't extra required files for the library/modules" |
||||||
|
puts stdout "" |
||||||
|
puts stdout "This is not intended for binary modules - use at own risk and check results" |
||||||
|
puts stdout "" |
||||||
|
puts stdout "Base module path: $modulefolder_path" |
||||||
|
puts stdout "Target path : $target_path" |
||||||
|
puts stdout "results of 'package ifneeded $libfound'" |
||||||
|
puts stdout "---" |
||||||
|
puts stdout "$loadinfo" |
||||||
|
puts stdout "---" |
||||||
|
set question "Proceed to create ${pkgtail}-${ver}.tm module? Y|N" |
||||||
|
set answer [punk::lib::askuser $question] ;#takes account of previous stdin state and terminal raw vs line state |
||||||
|
if {[string tolower $answer] ne "y"} { |
||||||
|
puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." |
||||||
|
return |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {![file exists $modulefolder_path]} { |
||||||
|
puts stdout "Creating module base folder at $modulefolder_path" |
||||||
|
file mkdir $modulefolder_path |
||||||
|
} |
||||||
|
if {![file exists [file dirname $target_path]]} { |
||||||
|
puts stdout "Creating relative folder at [file dirname $target_path]" |
||||||
|
file mkdir [file dirname $target_path] |
||||||
|
} |
||||||
|
|
||||||
|
if {[file exists $target_path]} { |
||||||
|
puts stdout "WARNING - module already exists at $target_path" |
||||||
|
if {$opt_askme} { |
||||||
|
set question "Copy anyway? Y|N" |
||||||
|
set answer [punk::lib::askuser $question] |
||||||
|
if {[string tolower $answer] ne "y"} { |
||||||
|
puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." |
||||||
|
return |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
file copy -force $source_file $target_path |
||||||
|
|
||||||
|
return $target_path |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::mix::commandset::loadedlib [namespace eval punk::mix::commandset::loadedlib { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
@ -0,0 +1,518 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::mix::commandset::module 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license BSD |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
package require punk::repo |
||||||
|
# depends on punk,punk::mix::base,punk::mix::cli |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::mix::commandset::module { |
||||||
|
namespace export * |
||||||
|
|
||||||
|
proc paths {} { |
||||||
|
set roots [punk::repo::find_repos ""] |
||||||
|
set project [lindex [dict get $roots project] 0] |
||||||
|
if {$project ne ""} { |
||||||
|
set is_project 1 |
||||||
|
set searchbase $project |
||||||
|
} else { |
||||||
|
set is_project 0 |
||||||
|
set searchbase [pwd] |
||||||
|
} |
||||||
|
|
||||||
|
if {[catch { |
||||||
|
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $searchbase] |
||||||
|
} errMsg]} { |
||||||
|
set source_module_folderlist [list] |
||||||
|
} |
||||||
|
|
||||||
|
set tm_folders [tcl::tm::list] |
||||||
|
package require overtype |
||||||
|
|
||||||
|
set result "" |
||||||
|
if {$is_project} { |
||||||
|
append result "Project module source paths:" \n |
||||||
|
foreach f $source_module_folderlist { |
||||||
|
append result "$f" \n |
||||||
|
} |
||||||
|
} |
||||||
|
append result \n |
||||||
|
append result "tcl::tm::list" \n |
||||||
|
foreach f $tm_folders { |
||||||
|
if {$is_project} { |
||||||
|
if {[punk::mix::cli::lib::path_a_aboveorat_b $project $f]} { |
||||||
|
set pinfo "(within project)" |
||||||
|
} else { |
||||||
|
set pinfo "" |
||||||
|
} |
||||||
|
} else { |
||||||
|
set pinfo "" |
||||||
|
} |
||||||
|
set warning "" |
||||||
|
if {![file isdirectory $f]} { |
||||||
|
set warning "(PATH NOT FOUND)" |
||||||
|
} |
||||||
|
append result "$f $pinfo $warning" \n |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
return $result |
||||||
|
} |
||||||
|
#require current dir when calling to be the projectdir, or |
||||||
|
proc templates {args} { |
||||||
|
set tdict_low_to_high [templates_dict {*}$args] |
||||||
|
#convert to screen order - with higher priority at the top |
||||||
|
set tdict [dict create] |
||||||
|
foreach k [lreverse [dict keys $tdict_low_to_high]] { |
||||||
|
dict set tdict $k [dict get $tdict_low_to_high $k] |
||||||
|
} |
||||||
|
|
||||||
|
package require overtype |
||||||
|
package require textblock |
||||||
|
#set pathinfolist [dict values $tdict] |
||||||
|
#set paths [lsearch -all -inline -index 1 -subindices $pathinfolist *] ;#relies on first key of templates_dict being path |
||||||
|
|
||||||
|
set names [dict keys $tdict] |
||||||
|
set paths [list] |
||||||
|
set pathtypes [list] |
||||||
|
dict for {nm tinfo} $tdict { |
||||||
|
lappend paths [dict get $tinfo path] |
||||||
|
lappend pathtypes [dict get $tinfo sourceinfo pathtype] |
||||||
|
} |
||||||
|
|
||||||
|
set title(path) "Path" |
||||||
|
set widest(path) [tcl::mathfunc::max {*}[lmap v [concat [list $title(path)] $paths] {punk::strlen $v}]] |
||||||
|
set col(path) [string repeat " " $widest(path)] |
||||||
|
|
||||||
|
set title(pathtype) "[a+ green]Path Type[a]" |
||||||
|
set widest(pathtype) [tcl::mathfunc::max {*}[lmap v [concat [list $title(pathtype)] $pathtypes] {string length $v}]] |
||||||
|
set col(pathtype) [string repeat " " $widest(pathtype)] |
||||||
|
|
||||||
|
set title(name) "Template Name" |
||||||
|
set widest(name) [tcl::mathfunc::max {*}[lmap v [concat [list $title(name)] $names] {string length $v}]] |
||||||
|
set col(name) [string repeat " " $widest(name)] |
||||||
|
|
||||||
|
set tablewidth [expr {$widest(name) + 1 + $widest(pathtype) + 1 + $widest(name)}] |
||||||
|
set table "" |
||||||
|
append table [string repeat - $tablewidth] \n |
||||||
|
append table "[textblock::join -- [overtype::left $col(name) $title(name)] " " [overtype::left $col(pathtype) $title(pathtype)] " " [overtype::left $col(path) $title(path)]]" \n |
||||||
|
append table [string repeat - $tablewidth] \n |
||||||
|
|
||||||
|
foreach n $names pt $pathtypes p $paths { |
||||||
|
append table "[overtype::left $col(name) $n] [overtype::left $col(pathtype) $pt] [overtype::left $col(path) $p]" \n |
||||||
|
} |
||||||
|
|
||||||
|
return $table |
||||||
|
} |
||||||
|
#return all module templates with repeated ones suffixed with .2 .3 etc |
||||||
|
proc templates_dict {args} { |
||||||
|
set argspec { |
||||||
|
*proc -name templates_dict -help "Templates from module and project paths" |
||||||
|
-startdir -default "" -help "Project folder used in addition to module paths" |
||||||
|
-not -default "" -multiple 1 |
||||||
|
*values |
||||||
|
globsearches -default * -multiple 1 |
||||||
|
} |
||||||
|
set argd [punk::args::get_dict $argspec $args] |
||||||
|
package require punk::cap |
||||||
|
if {[punk::cap::capability_has_handler punk.templates]} { |
||||||
|
set template_folder_dict [punk::cap::call_handler punk.templates get_itemdict_moduletemplates {*}$args] |
||||||
|
} else { |
||||||
|
put stderr "get_template_basefolders WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide template locations" |
||||||
|
} |
||||||
|
} |
||||||
|
proc new {args} { |
||||||
|
set year [clock format [clock seconds] -format %Y] |
||||||
|
set moduletypes [punk::mix::cli::lib::module_types] |
||||||
|
# use \uFFFD because unicode replacement char should consistently render as 1 wide |
||||||
|
set argspecs [subst { |
||||||
|
-project -default \uFFFD |
||||||
|
-version -default \uFFFD |
||||||
|
-license -default <unspecified> |
||||||
|
-template -default punk.module |
||||||
|
-type -default \uFFFD -choices {$moduletypes} |
||||||
|
-force -default 0 -type boolean |
||||||
|
-quiet -default 0 -type boolean |
||||||
|
*values -min 1 -max 1 |
||||||
|
module -type string |
||||||
|
}] |
||||||
|
set argd [punk::args::get_dict $argspecs $args] |
||||||
|
lassign [dict values $argd] opts values |
||||||
|
set module [dict get $values module] |
||||||
|
|
||||||
|
#set opts [dict merge $defaults $args] |
||||||
|
|
||||||
|
#todo - review compatibility between -template and -type |
||||||
|
#-type is the wrapping technology e.g 'plain' for none or tarjar or zip (modpod) etc (consider also snappy/snappy-tcl) |
||||||
|
#-template may be a folder - but only if the selected -type suports it |
||||||
|
|
||||||
|
|
||||||
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||||
|
# option -version |
||||||
|
# we need this value before looking at the named argument |
||||||
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||||
|
set opt_version_supplied [dict get $opts -version] |
||||||
|
if {$opt_version_supplied eq "\uFFFD"} { |
||||||
|
set opt_version "0.1.0" |
||||||
|
} else { |
||||||
|
set opt_version $opt_version_supplied |
||||||
|
if {![util::is_valid_tm_version $opt_version]} { |
||||||
|
error "deck module.new error - supplied -version $opt_version doesn't appear to be a valid Tcl module version" |
||||||
|
} |
||||||
|
} |
||||||
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||||
|
#named argument |
||||||
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||||
|
set mversion_supplied "" ;#version supplied directly in module argument |
||||||
|
if {[string first - $module]> 0} { |
||||||
|
#if it has a dash then version is required to be valid |
||||||
|
lassign [punk::mix::cli::lib::split_modulename_version $module] modulename mversion |
||||||
|
if {![util::is_valid_tm_version $mversion]} { |
||||||
|
error "deck module.new error - unable to determine modulename-version from supplied value '$module'" |
||||||
|
} |
||||||
|
set mversion_supplied $mversion ;#record as may need to compare to version from templatefile name |
||||||
|
set vcompare_is_mversion_bigger [package vcompare $mversion $opt_version] |
||||||
|
if {$vcompare_is_mversion_bigger > 0} { |
||||||
|
set opt_version $mversion; #module parameter has higher value than -version |
||||||
|
set vmsg "from module argument: $module" |
||||||
|
} else { |
||||||
|
set vmsg "from -version option: $opt_version_supplied" |
||||||
|
} |
||||||
|
if {$opt_version_supplied ne "\uFFFD"} { |
||||||
|
if {$vcompare_is_mversion_bigger != 0} { |
||||||
|
#is bigger or smaller |
||||||
|
puts stderr "module.new WARNING: version supplied in module argument as well as -version option. Using the higher version number $vmsg" |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
set modulename $module |
||||||
|
} |
||||||
|
punk::mix::cli::lib::validate_modulename $modulename -errorprefix "punk::mix::commandset::module::new" |
||||||
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||||
|
#options |
||||||
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||||
|
set opt_project [dict get $opts -project] |
||||||
|
set testdir [pwd] |
||||||
|
if {![string length [set projectdir [punk::repo::find_project $testdir]]]} { |
||||||
|
if {![string length [set projectdir [punk::repo::find_candidate $testdir]]]} { |
||||||
|
set msg [punk::repo::is_candidate_root_requirements_msg] |
||||||
|
error "module.new unable to create module in projectdir:$projectdir - directory doesn't appear to meet basic standards $msg" |
||||||
|
} |
||||||
|
} |
||||||
|
if {$opt_project == "\uFFFF"} { |
||||||
|
set projectname [file tail $projectdir] |
||||||
|
} else { |
||||||
|
set projectname $opt_project |
||||||
|
if {$projectname ne [file tail $projectdir]} { |
||||||
|
error "module.new -project '$opt_project' doesn't match detected projectname '$projectname' at path: $projectdir" |
||||||
|
} |
||||||
|
} |
||||||
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||||
|
set opt_license [dict get $opts -license] |
||||||
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||||
|
set opt_template [dict get $opts -template] |
||||||
|
if {[regexp {.*[?*].*} $opt_template]} { |
||||||
|
error "module.new -template does not support glob chars. Use an exact full name including version (and optionally .tm) - or use just the name without version or .tm, and the latest version will be selected" |
||||||
|
} |
||||||
|
|
||||||
|
set templates_dict [templates_dict] ;#keys are possibly prefixed with <vendor>. and/or suffixed with #2 #3 etc if there are collisions - the remaining unsuffixed being the one with highest preference |
||||||
|
#todo - allow versionless name - pick latest which isn't suffixed with #2 etc |
||||||
|
#if the user wants to exactly match an unversioned template, in the presence of versioned ones - they may need to include the trailing .tm |
||||||
|
if {[dict exists $templates_dict $opt_template]} { |
||||||
|
#exact long name (possibly including version) |
||||||
|
#Note - an unversioned .tm template will be matched here - even though versioned templates of the same name may exist. |
||||||
|
set templatefile [dict get $templates_dict $opt_template path] |
||||||
|
set templatefile_info [dict get $templates_dict $opt_template sourceinfo] |
||||||
|
} else { |
||||||
|
#if it wasn't an exact match for opt_template - then opt_template now shouldn't contain a version (we have also ruled out glob chars * & ? above) |
||||||
|
#(if it does - then we just won't find anything - which is fine) |
||||||
|
#module file name could contain dots - but only one dash - if it is versioned |
||||||
|
|
||||||
|
set matches [lsearch -all -inline [dict keys $templates_dict] $opt_template-*] ;#the key is of form vendor.modulename-version(#suffix) (version optional, suffix if lower precedence with same name was found) |
||||||
|
#only .tm (or .TM .Tm .tM) files make it into the templates_dict - they are allowed to be unversioned though. |
||||||
|
set key_version_list [list] |
||||||
|
foreach m $matches { |
||||||
|
#vendorname could contain dashes or dots - so easiest way to split out is to examine the stored vendor value in sourceinfo |
||||||
|
set vendor [dict get $templates_dict $m sourceinfo vendor] |
||||||
|
if {$vendor ne "_project"} { |
||||||
|
#_project special case - not included in module names |
||||||
|
set module $m |
||||||
|
} else { |
||||||
|
set module [string range [string length $vendor.] end] |
||||||
|
} |
||||||
|
lassign [punk::mix::cli::lib::split_modulename_version $m] _tailmname mversion |
||||||
|
lappend key_version_list [list $m $mversion] |
||||||
|
} |
||||||
|
if {[llength $matches]} { |
||||||
|
set highest_m "" |
||||||
|
set highest_v "" |
||||||
|
foreach kv $key_version_list { |
||||||
|
if {$highest_v eq ""} { |
||||||
|
set highest_m [lindex $kv 0] |
||||||
|
set highest_v [lindex $kv 1] |
||||||
|
} else { |
||||||
|
if {[package vcompare $highest_v [lindex $kv 1]] == -1} { |
||||||
|
set highest_m [lindex $kv 0] |
||||||
|
set highest_v [lindex $kv 1] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set templatefile [dict get $templates_dict $highest_m path] |
||||||
|
set templatefile_info [dict get $templates_dict $highest_m sourceinfo] |
||||||
|
} else { |
||||||
|
error "module.new unable to find template '$opt_template'. [dict size $templates_dict] Known templates. Use deck module.templates to display" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set tpldir [file dirname $templatefile] ;#use same folder for modulename_buildversion.txt, modulename_description.txt if they exist |
||||||
|
|
||||||
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||||
|
set opt_type [dict get $opts -type] |
||||||
|
if {$opt_type eq "\uFFFD"} { |
||||||
|
set opt_type [lindex [punk::mix::cli::lib::module_types] 0] ;#default to plain |
||||||
|
} |
||||||
|
if {$opt_type ni [punk::mix::cli::lib::module_types]} { |
||||||
|
error "module.new - error - unknown -type '$opt_type' known-types: [punk::mix::cli::lib::module_types]" |
||||||
|
} |
||||||
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||||
|
set opt_quiet [dict get $opts -quiet] |
||||||
|
set opt_force [dict get $opts -force] |
||||||
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
set subpath [punk::mix::cli::lib::module_subpath $modulename] ;#commonly empty string for simple modulename e.g "mymodule" but x::mymodule has subpath 'x' and x::y::mymodule has subpath 'x/y' |
||||||
|
if {![string length $subpath]} { |
||||||
|
set modulefolder $projectdir/src/modules |
||||||
|
} else { |
||||||
|
set modulefolder $projectdir/src/modules/$subpath |
||||||
|
} |
||||||
|
file mkdir $modulefolder |
||||||
|
|
||||||
|
set moduletail [namespace tail $modulename] |
||||||
|
set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
set template_tail [file tail $templatefile] ;#convert template_xxx-version.tm.x to {xxx version} |
||||||
|
set template_tail [string range $template_tail [string length template_] end] |
||||||
|
set ext [string tolower [file extension $template_tail]] |
||||||
|
if {$ext eq ".tm"} { |
||||||
|
set template_modulename_part [file rootname $template_tail] |
||||||
|
} elseif {[string is integer -strict [string range $ext 1 end]]} { |
||||||
|
#something like modulename-0.0.1.tm.2 |
||||||
|
#strip of last 2 dotted parts |
||||||
|
set shortened [file rootname $template_tail] |
||||||
|
if {![string equal -nocase [file extension $shortened] ".tm"]} { |
||||||
|
error "module.new error: Unable to interpret filename components of template file '$templatefile' (expected .tm as second-last or last component)" |
||||||
|
} |
||||||
|
set template_modulename_part [file rootname $shortened] |
||||||
|
} else { |
||||||
|
error "module.new error: Unable to interpret filename components of template file '$templatefile'" |
||||||
|
} |
||||||
|
lassign [punk::mix::cli::lib::split_modulename_version $template_modulename_part] t_mname t_version |
||||||
|
#t_version may be empty string if template is unversioned e.g template_whatever.tm |
||||||
|
|
||||||
|
set fd [open $templatefile r]; set template_filedata [read $fd]; close $fd |
||||||
|
if {[string match "*$magicversion*" $template_filedata]} { |
||||||
|
set use_magic 1 |
||||||
|
set build_version $opt_version |
||||||
|
set infile_version $magicversion |
||||||
|
} else { |
||||||
|
set use_magic 0 |
||||||
|
if {$opt_version_supplied ne "\uFFFF"} { |
||||||
|
set build_version $opt_version |
||||||
|
} else { |
||||||
|
# |
||||||
|
|
||||||
|
if {[util::is_valid_tm_version $t_version]} { |
||||||
|
if {$mversion_supplied eq ""} { |
||||||
|
set build_version $t_version |
||||||
|
} else { |
||||||
|
#we have a version from the named argument 'module' |
||||||
|
if {[package vcompare $mversion_supplied $t_version] > 0} { |
||||||
|
set build_version $mversion_supplied |
||||||
|
} else { |
||||||
|
set build_version $t_version |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
#probably an unversioned module template |
||||||
|
#use opt_version default from above |
||||||
|
set build_version $opt_version |
||||||
|
} |
||||||
|
} |
||||||
|
set infile_version $build_version |
||||||
|
} |
||||||
|
|
||||||
|
set moduletemplate [file join $projectname [punk::path::relative $projectdir $templatefile]] ;#if templatfile is on another volume - just $templatefile will be returned. |
||||||
|
#moduletemplate should usually be a relative path - but could be absolute, or contain info about the relative locations of projectdir vs templatefile if template comes from another project or a module outside the project |
||||||
|
#This path info may be undesired in the template output (%moduletemplate%) |
||||||
|
#it is nevertheless useful information - and not the only way developer-machine/build-machine paths can leak |
||||||
|
#for now the user has the option to override any templates and remove %moduletemplate% if it is a security/privacy concern |
||||||
|
|
||||||
|
#Don't put literal %x% in the code for the commandset::module itself - to stop them being seen by layout scanner as replacable tokens |
||||||
|
set tagnames [list moduletemplate $moduletemplate project $projectname pkg $modulename year $year license $opt_license version $infile_version] |
||||||
|
set strmap [list] |
||||||
|
foreach {tag val} $tagnames { |
||||||
|
lappend strmap %$tag% $val |
||||||
|
} |
||||||
|
set template_filedata [string map $strmap $template_filedata] |
||||||
|
|
||||||
|
set tmfile $modulefolder/${moduletail}-$infile_version.tm |
||||||
|
set podfile $modulefolder/#modpod-$moduletail-$infile_version/$moduletail-$infile_version.tm |
||||||
|
set has_tm [file exists $tmfile] |
||||||
|
set has_pod [file exists $podfile] |
||||||
|
if {$has_tm && $has_pos} { |
||||||
|
#invalid configuration - bomb out |
||||||
|
error "module.new error: Invalid target configuration found. module folder has both a .tm file $tmfile and a modpod file $podfile. Please delete one of them before trying again." |
||||||
|
} |
||||||
|
if {$opt_type eq "plain"} { |
||||||
|
set modulefile $tmfile |
||||||
|
} else { |
||||||
|
set modulefile $podfile |
||||||
|
} |
||||||
|
if {$has_tm || $has_pod} { |
||||||
|
if {!$opt_force} { |
||||||
|
if {$has_tm} { |
||||||
|
set errmsg "module.new error: module file $tmfile already exists - aborting" |
||||||
|
} else { |
||||||
|
set errmsg "module.new error: module file $podfile already exists - aborting" |
||||||
|
} |
||||||
|
if {[string match "*$magicversion*" $tmfile]} { |
||||||
|
append errmsg \n "If you are attempting to create a module file with a specific version in the source-file name - you will need to use a template that doesn't contain the string '$magicversion' e.g the provided template moduleexactversion-0.0.1.tm" |
||||||
|
} |
||||||
|
error $errmsg |
||||||
|
} else { |
||||||
|
#review - prompt here vs caller? |
||||||
|
#we are committed to overwriting/replacing if there was a pre-existing module of same version |
||||||
|
if {$has_pod} { |
||||||
|
file delete -force [file dirname $podfile] |
||||||
|
} elseif {$has_tm} { |
||||||
|
file delete -force $tmfile |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
if {[file exists $tpldir/modulename_buildversion.txt]} { |
||||||
|
set fd [open $tpldir/modulename_buildversion.txt r]; set buildversion_filedata [read $fd]; close $fd |
||||||
|
} else { |
||||||
|
#mix_templates_dir warns of deprecation - review |
||||||
|
set lib_tpldir [file join [punk::mix::cli::lib::mix_templates_dir] modules];#fallback for modulename_buildversion.txt, modulename_description.txt |
||||||
|
set fd [open $lib_tpldir/modulename_buildversion.txt r]; set buildversion_filedata [read $fd]; close $fd |
||||||
|
} |
||||||
|
set buildversionfile [file join $modulefolder ${moduletail}-buildversion.txt] |
||||||
|
set existing_build_version "" |
||||||
|
if {[file exists $buildversionfile]} { |
||||||
|
set buildversiondata [punk::mix::util::fcat $buildversionfile] |
||||||
|
set lines [split $buildversiondata \n] |
||||||
|
set existing_build_version [string trim [lindex $lines 0]] |
||||||
|
if {[package vcompare $existing_build_version $build_version] >= 0} { |
||||||
|
#existing version in -buildversion.txt file is lower than the module version we are creating |
||||||
|
error "module.new error: there is an existing buildversion file $buildversionfile with version $existing_build_version equal to or higher than $build_version - unable to continue" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set existing_tm_versions [glob -nocomplain -dir $modulefolder -tails ${moduletail}-*.tm] |
||||||
|
#it shouldn't be possible to overmatch with the glob - because '-' is not valid in a Tcl module name |
||||||
|
set existing_pod_versions [glob -nocomplain -dir $modulefolder -tails #modpod-$moduletail-*] |
||||||
|
set existing_versions [concat $existing_tm_versions $existing_pod_versions] |
||||||
|
|
||||||
|
if {[llength $existing_versions]} { |
||||||
|
set name_version_pairs [list] |
||||||
|
lappend name_version_pairs [list $moduletail $infile_version] |
||||||
|
foreach existing $existing_versions { |
||||||
|
lassign [punk::mix::cli::lib::split_modulename_version $existing] namepart version ;# .tm is stripped and ignored |
||||||
|
if {[string match #modpod-* $namepart]} { |
||||||
|
set namepart [string range $namepart 8 end] |
||||||
|
} |
||||||
|
lappend name_version_pairs [list $namepart $version] |
||||||
|
} |
||||||
|
set name_version_pairs [lsort -command {package vcompare} -index 1 $name_version_pairs] ;#while plain lsort will often work with versions - it can get order wrong with some - so use package vcompare |
||||||
|
if {[lindex $name_version_pairs end] ne [list $moduletail $infile_version]} { |
||||||
|
set thisposn [lsearch -index 1 $name_version_pairs $infile_version] |
||||||
|
set name_version_pairs [lreplace $name_version_pairs $thisposn $thisposn] |
||||||
|
set other_versions [lsearch -all -inline -index 1 -subindices $name_version_pairs *] |
||||||
|
set errmsg "module.new error: There are existing modules in the target folder with higher versions than $infile_version." |
||||||
|
append errmsg \n "Other versions found: $other_versions" |
||||||
|
if {$magicversion in $other_versions} { |
||||||
|
append errmsg \n "Existing build version for special source file name: '$magicversion' is: '$existing_build_version'" |
||||||
|
append errmsg \n "If '$magicversion' file doesn't represent the latest source it should be removed or the filename and contents adjusted to be a specific version" |
||||||
|
} |
||||||
|
error $errmsg |
||||||
|
} else { |
||||||
|
puts stderr "module.new WARNING: There are existing modules in the target folder with lower versions than $infile_version - manual review recommended" |
||||||
|
puts stderr "Other versions found: [lsearch -all -inline -index 1 -subindices [lrange $name_version_pairs 0 end-1] *]" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {!$opt_quiet} { |
||||||
|
puts stdout "Creating $modulefile from template $moduletemplate" |
||||||
|
} |
||||||
|
file mkdir [file dirname $modulefile] |
||||||
|
|
||||||
|
set fd [open $modulefile w] |
||||||
|
fconfigure $fd -translation binary |
||||||
|
puts -nonewline $fd $template_filedata |
||||||
|
close $fd |
||||||
|
|
||||||
|
|
||||||
|
set buildversion_filedata [string map [list %Major.Minor.Level% $build_version] $buildversion_filedata] |
||||||
|
set fd [open $buildversionfile w] |
||||||
|
fconfigure $fd -translation binary |
||||||
|
puts -nonewline $fd $buildversion_filedata |
||||||
|
close $fd |
||||||
|
|
||||||
|
return [list file $modulefile version $build_version] |
||||||
|
} |
||||||
|
|
||||||
|
namespace eval lib { |
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::mix::commandset::module [namespace eval punk::mix::commandset::module { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,420 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::mix::commandset::repo 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::mix::commandset::repo { |
||||||
|
namespace export * |
||||||
|
proc tickets {{project ""}} { |
||||||
|
set result "" |
||||||
|
if {[string length $project]} { |
||||||
|
puts stderr "project status unimplemented" |
||||||
|
return |
||||||
|
} |
||||||
|
set active_dir [pwd] |
||||||
|
append result "Retrieving top 10 tickets only (for more, use fossil timeline -n <int> -t t)" \n |
||||||
|
append result [exec fossil timeline -n 10 -t t] |
||||||
|
|
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
proc fossilize { args} { |
||||||
|
#check if project already managed by fossil.. initialise and check in if not. |
||||||
|
puts stderr "unimplemented" |
||||||
|
} |
||||||
|
|
||||||
|
proc unfossilize {projectname args} { |
||||||
|
#remove/archive .fossil |
||||||
|
puts stderr "unimplemented" |
||||||
|
} |
||||||
|
proc state {} { |
||||||
|
set result "" |
||||||
|
set repopaths [punk::repo::find_repos [pwd]] |
||||||
|
set repos [dict get $repopaths repos] |
||||||
|
if {![llength $repos]} { |
||||||
|
append result [dict get $repopaths warnings] |
||||||
|
} else { |
||||||
|
append result [dict get $repopaths warnings] |
||||||
|
lassign [lindex $repos 0] repopath repotypes |
||||||
|
if {"fossil" in $repotypes} { |
||||||
|
append result \n "Fossil repo based at $repopath" |
||||||
|
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] |
||||||
|
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||||
|
} |
||||||
|
if {"git" in $repotypes} { |
||||||
|
append result \n "Git repo based at $repopath" |
||||||
|
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes git] |
||||||
|
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
proc fossil-move-repository {{path ""}} { |
||||||
|
set searchbase [pwd] |
||||||
|
set projectinfo [punk::repo::find_repos $searchbase] |
||||||
|
set projectbase [dict get $projectinfo closest] |
||||||
|
set is_fossil [expr {"fossil" in [dict get $projectinfo closest_types]}] |
||||||
|
if {[catch { |
||||||
|
package require sqlite3 |
||||||
|
} errM]} { |
||||||
|
puts stderr "sqlite3 package failed to load" |
||||||
|
puts stderr "Try using 'fossil test-move-repository <targetpath>' from within an open checkout folder, or ensure that the Tcl sqlite3 package is available." |
||||||
|
return |
||||||
|
} |
||||||
|
set ansiprompt [a+ green bold] |
||||||
|
set ansiwarn [a+ red bold] |
||||||
|
set ansihighlight [a+ cyan bold] |
||||||
|
set ansireset [a] |
||||||
|
|
||||||
|
set in_checkout 0 |
||||||
|
set is_checkout_relink 0; #whether we are attempting to link a checkout that has lost its repo |
||||||
|
#we may also encounter a different kind of relink candidate - other checkouts of the same repo that we examine and find don't point back. |
||||||
|
if {$projectbase eq "" || !$is_fossil} { |
||||||
|
set repodbs [glob -dir $searchbase -type f -tail *.fossil] |
||||||
|
if {![llength $repodbs]} { |
||||||
|
puts stderr "Current directory does not seem to be directly below a fossil checkout, and no .fossil files found" |
||||||
|
puts stderr "Please move to a folder containing the .fossil repository database to move, or to a folder directly within a fossil checkout (and with no intermediate git/fossil repos)" |
||||||
|
return |
||||||
|
} |
||||||
|
set choice_files [list] |
||||||
|
set i 1 |
||||||
|
set menu_message "" |
||||||
|
append menu_message "${ansiprompt}Select the number of the fossil repo db to potentially move (confirmation will be requested before any action is taken)${ansireset}" \n |
||||||
|
foreach db $repodbs { |
||||||
|
sqlite3 dbinfo [file join $searchbase $db] |
||||||
|
set ckouts [dbinfo eval {select name from config where name like 'ckout:%'}] |
||||||
|
dbinfo close |
||||||
|
lappend choice_files [list index $i repofile $db checkouts [llength $ckouts]] |
||||||
|
append menu_message "$i $db checkouts: [llength $ckouts]" \n |
||||||
|
incr i |
||||||
|
} |
||||||
|
puts stdout $menu_message |
||||||
|
set max [llength $choice_files] |
||||||
|
if {$max == 1} { |
||||||
|
set rangemsg "the number 1" |
||||||
|
} else { |
||||||
|
set rangemsg "a number from 1 to $max" |
||||||
|
} |
||||||
|
set answer [punk::repo::askuser "${ansiprompt}Enter $rangemsg to select a .fossil repository database to show details and potentially move. (or N to abort)${ansireset}"] |
||||||
|
if {![string is integer -strict $answer]} { |
||||||
|
puts stderr "Aborting" |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
set index [expr {int($answer) -1}] |
||||||
|
if {$index >= 0 && $index <= $max-1} { |
||||||
|
set repo_file_choice [lindex $choice_files $index] |
||||||
|
set repo_file [dict get $repo_file_choice repofile] |
||||||
|
set repo_file [file join $searchbase $repo_file] |
||||||
|
puts stdout "Selected fossil repo database file: $repo_file" |
||||||
|
} else { |
||||||
|
puts stderr " No menu number matched - aborting." |
||||||
|
return |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {[file exists $projectbase/_FOSSIL_]} { |
||||||
|
set cdbfile [file join $projectbase/_FOSSIL_] |
||||||
|
} elseif {[file exists $projectbase/.fslckout]} { |
||||||
|
set cdbfile [file join $projectbase/.fslckout] |
||||||
|
} else { |
||||||
|
puts stderr "No checkout database (_FOSSIL_ or .fslckout) found in nearest repository folder $projectbase (looked upwards from $searchbase)" |
||||||
|
puts stderr "Unable to locate repository databases for potential move. Please move to a checkout folder or a folder containing .fossil repositories" |
||||||
|
puts stderr "If run from a location where repositories are found, fossil-move-repository will give you the option to select a repository or cancel the operation" |
||||||
|
return |
||||||
|
} |
||||||
|
set in_checkout 1 |
||||||
|
sqlite3 cdb $cdbfile |
||||||
|
set repo_file [cdb eval {select value from vvar where name='repository'}] |
||||||
|
cdb close |
||||||
|
if {[string length [string trim $repo_file]] && [file pathtype $repo_file] eq "relative"} { |
||||||
|
set repo_file [file join $projectbase $repo_file] |
||||||
|
} |
||||||
|
if {![string length [string trim $repo_file]] || ![file exists $repo_file]} { |
||||||
|
puts stderr "${ansiwarn}Checkout at $projectbase points to repository '$repo_file' - but it doesn't seem to exist${ansireset}" |
||||||
|
set answer [punk::repo::askuser "${ansiprompt}Do you want to link this to an existing repository file? (Y|N)${ansireset}"] |
||||||
|
if {[string match y* [string tolower $answer]]} { |
||||||
|
set is_checkout_relink 1 |
||||||
|
} else { |
||||||
|
puts stderr "Aborting - Unable to link this checkout dir to a repository database file" |
||||||
|
return |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set pname [file rootname [file tail $repo_file]] |
||||||
|
set full_path_repo_file [file join $searchbase $repo_file] |
||||||
|
if {[file isfile $full_path_repo_file]} { |
||||||
|
sqlite3 dbinfo [file join $searchbase $repo_file] |
||||||
|
set ckouts [dbinfo eval {select name from config where name like 'ckout:%'}] |
||||||
|
dbinfo close |
||||||
|
if {![llength $ckouts]} { |
||||||
|
puts stdout "Repository db at [file join $searchbase $repo_file] appears to have no open checkouts" |
||||||
|
} else { |
||||||
|
puts stdout "Repository db at [file join $searchbase $repo_file] appears to have [llength $ckouts] open checkouts:" |
||||||
|
foreach ck $ckouts { |
||||||
|
puts stdout [string range $ck 6 end] |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
puts stderr "${ansiwarn}Missing repository db at $full_path_repo_file${ansireset}" |
||||||
|
} |
||||||
|
puts stdout "${ansihighlight}Report for all projects with repository file name $pname${ansireset}" |
||||||
|
puts stdout [punk::mix::commandset::project::collection::detail $pname] |
||||||
|
puts stdout [punk::mix::commandset::project::collection::work $pname -detail 1] |
||||||
|
|
||||||
|
#todo |
||||||
|
#ask user if they want to select a different pname |
||||||
|
set wantrenameprompt "${ansiprompt}Would you like to rename the .fossil file? (Y|N)${ansireset}" |
||||||
|
append wantrenameprompt \n "${ansiprompt}.eg change $pname.fossil to something else such as ${pname}_new.fossil${ansireset}" |
||||||
|
set answer [punk::repo::askuser $wantrenameprompt] |
||||||
|
set pname2 $pname |
||||||
|
if {[string match y* [string tolower $answer]]} { |
||||||
|
set dorenameprompt "${ansiprompt}Enter the new name and hit enter. (Just an alphanumeric name (possibly with dots/dashes/underscores) without .fossil and without any path)${ansireset}" |
||||||
|
set namechoice [punk::repo::askuser $dorenameprompt] |
||||||
|
if {[string length $namechoice]} { |
||||||
|
set permittedmap [list . "" - "" _ ""] |
||||||
|
if {[string is alnum -strict [string map $permittedmap $namechoice]]} { |
||||||
|
set pname2 $namechoice |
||||||
|
} else { |
||||||
|
puts stderr "Entered name was invalid. Must be numbers,letters,underscore,dot,dash" |
||||||
|
} |
||||||
|
} |
||||||
|
puts stdout "Continuing with name $pname2 - cancel at next prompt if this is incorrect" |
||||||
|
} |
||||||
|
|
||||||
|
set target_repodb_folder [punk::repo::fossil_get_repository_folder_for_project $pname2 -parentfolder $searchbase -askpath 1] |
||||||
|
#target_repodb_folder might be same as source folder - check for same file if name wasn't changed? |
||||||
|
if {![string length $target_repodb_folder]} { |
||||||
|
puts stderr "No usable repository database folder selected for $pname2.fossil file" |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
set existing_target_repofile 0 |
||||||
|
if {[file exists $target_repodb_folder/$pname2.fossil]} { |
||||||
|
set existing_target_repofile 1 |
||||||
|
puts stdout "${ansiwarn}NOTICE: $target_repodb_folder/$pname2.fossil already exists${ansireset}" |
||||||
|
if {!$is_checkout_relink} { |
||||||
|
set finalquestion "${ansiprompt}Are you sure you want to switch the repository $repo_file for the open checkout(s) to the existing file $target_repodb_folder/$pname2.fossil? (Y|N)${ansireset}" |
||||||
|
} else { |
||||||
|
set finalquestion "${ansiprompt}Are you sure you want to attempt to linke the repository (previously linked with '$repo_file') for the open checkout(s) to the existing file $target_repodb_folder/$pname2.fossil? (Y|N)${ansireset}" |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {!$is_checkout_relink} { |
||||||
|
set finalquestion "${ansiprompt}Proceed to move repository $repo_file to the new file $target_repodb_folder/$pname2.fossil? Y|N${ansireset}" |
||||||
|
} else { |
||||||
|
set finalquestion "${ansiprompt}Proceed to attempt link for missing repo db $repo_file to the new file $target_repodb_folder/$pname2.fossil? Y|N${ansireset}" |
||||||
|
} |
||||||
|
} |
||||||
|
set line "${ansiwarn}[string repeat - [string length $finalquestion]]${ansireset}" |
||||||
|
set finalprompt $line\n |
||||||
|
append finalprompt $finalquestion \n |
||||||
|
append finalprompt $line \n |
||||||
|
|
||||||
|
set answer [punk::repo::askuser $finalprompt] |
||||||
|
if {[string match y* [string tolower $answer]]} { |
||||||
|
if {!$existing_target_repofile && !$is_checkout_relink} { |
||||||
|
if {[catch { |
||||||
|
file copy $repo_file $target_repodb_folder/$pname2.fossil |
||||||
|
} errM]} { |
||||||
|
puts stderr "${ansiwarn}FAILED to copy $repo_file to $target_repodb_folder/$pname2.fossil - aborting${ansireset}" |
||||||
|
puts stderr "Error message was:\n $errM" |
||||||
|
return |
||||||
|
} |
||||||
|
if {$in_checkout} { |
||||||
|
#in_checkout means we can assume projectbase var exists |
||||||
|
#there may be other checkouts on the old repo |
||||||
|
#if so, we will remind the user of their existence |
||||||
|
if {[catch {exec fossil test-move-repository $target_repodb_folder/$pname2.fossil} errM]} { |
||||||
|
puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" |
||||||
|
puts stderr "$errM" |
||||||
|
} else { |
||||||
|
|
||||||
|
sqlite3 oldrepo $repo_file |
||||||
|
set ckouts [oldrepo eval {select name from config where name like 'ckout:%'}] |
||||||
|
set pcode [oldrepo eval {select value from config where name = 'project-code'}] |
||||||
|
oldrepo close |
||||||
|
if {[string length $pcode] < 20} { |
||||||
|
puts stderr "WARNING: Failed to get project-code from repo db $repo_file" |
||||||
|
} |
||||||
|
set other_checkouts [list] |
||||||
|
set norm_projectbase [file normalize $projectbase] |
||||||
|
foreach ck $ckouts { |
||||||
|
set ckfolder [string trim [string range $ck 6 end]] |
||||||
|
if {![file isdirectory $ckfolder]} { |
||||||
|
#as the process was launched within a checkout - we won't bother user with reports of non-existant other checkouts |
||||||
|
continue |
||||||
|
} |
||||||
|
if {[file normalize $ckfolder] ne $norm_projectbase} { |
||||||
|
lappend other_checkouts $ckfolder |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $other_checkouts]} { |
||||||
|
puts stderr "${ansiwarn}Other checkouts of $repo_file that may need consideration${ansireset}" |
||||||
|
foreach other $other_checkouts { |
||||||
|
puts stdout $other |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
#we aren't in a checkout - moving a repo to a new db location and/or name so there's no reason to prefer one checkout over another.. presumably the user either wants to move them all - or be asked.. |
||||||
|
sqlite3 oldrepo $repo_file |
||||||
|
set ckouts [oldrepo eval {select name from config where name like 'ckout:%'}] |
||||||
|
oldrepo close |
||||||
|
if {[llength $ckouts] > 1} { |
||||||
|
puts stdout "There are [llength $ckouts] checkouts for the repository you are moving" |
||||||
|
puts stdout "You will be asked for each checkout if you want to adjust it to point to $target_repodb_folder/$pname2.folder" |
||||||
|
} |
||||||
|
set original_cwd [pwd] |
||||||
|
foreach ck $ckouts { |
||||||
|
set ckfolder [string trim [string range $ck 6 end]] |
||||||
|
if {![file isdirectory $ckfolder]} { |
||||||
|
puts stderr "old repo shows a checkout at $ckfolder - but it doesn't seem to exist. Ignoring" |
||||||
|
continue |
||||||
|
} |
||||||
|
cd $ckfolder |
||||||
|
puts stdout [exec fossil info] |
||||||
|
puts stdout [state] |
||||||
|
set answer [punk::repo::askuser "${ansiprompt}Do you want to point this checkout to $target_repodb_folder/$pname2.folder? (Y|N) Q to stop processing checkouts${ansireset}"] |
||||||
|
if {[string match q* [string tolower $answer]]} { |
||||||
|
puts stderr "User aborting loop" |
||||||
|
break |
||||||
|
} |
||||||
|
if {[string match y* [string tolower $answer]]} { |
||||||
|
if {[catch {exec fossil test-move-repository $target_repodb_folder/$pname2.fossil} moveresult]} { |
||||||
|
puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" |
||||||
|
puts stderr "$moveresult" |
||||||
|
} else { |
||||||
|
puts stdout "OK - move performed with result:" |
||||||
|
puts stdout $moveresult |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
cd $original_cwd |
||||||
|
|
||||||
|
} |
||||||
|
} else { |
||||||
|
if {$is_checkout_relink} { |
||||||
|
#relinking a lost checkout to an existing repo.. we should probably check it's other checkouts and see if they point back |
||||||
|
if {[catch {exec fossil test-move-repository $target_repodb_folder/$pname2.fossil} errM]} { |
||||||
|
puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" |
||||||
|
puts stderr "$errM" |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {$in_checkout} { |
||||||
|
if {[catch {exec fossil test-move-repository $target_repodb_folder/$pname2.fossil} errM]} { |
||||||
|
puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" |
||||||
|
puts stderr "$errM" |
||||||
|
} |
||||||
|
} else { |
||||||
|
#not in checkout - we're wanting what pointed to one repo to point to a different existing one - presumably for all checkouts |
||||||
|
sqlite3 newrepo $target_repodb_folder/$pname2.fossil |
||||||
|
set newpname [newrepo eval {select value from config where name = 'project-name'}] |
||||||
|
set newpcode [newrepo eval {select value from config where name = 'project-code'}] |
||||||
|
set newckouts [newrepo eval {select name from config where name like 'ckout:%'}] |
||||||
|
newrepo close |
||||||
|
|
||||||
|
sqlite3 oldrepo $repo_file |
||||||
|
set oldpname [oldrepo eval {select value from config where name = 'project-name'}] |
||||||
|
set oldpcode [oldrepo eval {select value from config where name = 'project-code'}] |
||||||
|
set oldckouts [oldrepo eval {select name from config where name like 'ckout:%'}] |
||||||
|
oldrepo close |
||||||
|
if {$newpname eq $oldpname} { |
||||||
|
set ansi_newpname [a+ green bold]$newpname[a] |
||||||
|
set ansi_oldpname [a+ green bold]$oldpname[a] |
||||||
|
} else { |
||||||
|
set ansi_newpname [a+ cyan bold]$newpname[a] |
||||||
|
set ansi_oldpname [a+ red bold]$oldpname[a] |
||||||
|
} |
||||||
|
if {$newpcode eq $oldpcode} { |
||||||
|
set ansi_newpcode [a+ green bold]$newpcode[a] |
||||||
|
set ansi_oldpcode [a+ green bold]$oldpcode[a] |
||||||
|
} else { |
||||||
|
set ansi_newpcode [a+ cyan bold]$newpcode[a] |
||||||
|
set ansi_oldpcode [a+ red bold]$oldpcode[a] |
||||||
|
} |
||||||
|
puts stdout "Target repository $target_repodb_folder/$pname2.fossil has project-name: $ansi_newpname and [llength $newckouts] existing checkouts" |
||||||
|
puts stdout "Target project code: $ansi_newpcode" |
||||||
|
puts stdout "Source repository $repo_file has project-name: $ansi_oldpname and [llength $oldckouts] existing checkouts" |
||||||
|
puts stdout "Source project code: $ansi_oldpcode" |
||||||
|
if {[llength $oldckouts] > 1} { |
||||||
|
puts stdout "You will be asked for each checkout if you want to adjust it to point to $target_repodb_folder/$pname2.folder" |
||||||
|
} |
||||||
|
set original_cwd [pwd] |
||||||
|
foreach ck $oldckouts { |
||||||
|
set ckfolder [string trim [string range $ck 6 end]] |
||||||
|
if {![file isdirectory $ckfolder]} { |
||||||
|
puts stderr "old repo shows a checkout at $ckfolder - but it doesn't seem to exist. Ignoring" |
||||||
|
continue |
||||||
|
} |
||||||
|
cd $ckfolder |
||||||
|
puts stdout [exec fossil info] |
||||||
|
puts stdout [state] |
||||||
|
set answer [punk::repo::askuser "${ansiprompt}Do you want to point this checkout to $target_repodb_folder/$pname2.folder? (Y|N) Q to stop processing checkouts${ansireset}"] |
||||||
|
if {[string match q* [string tolower $answer]]} { |
||||||
|
puts stderr "User aborting loop" |
||||||
|
break |
||||||
|
} |
||||||
|
if {[string match y* [string tolower $answer]]} { |
||||||
|
if {[catch {exec fossil test-move-repository $target_repodb_folder/$pname2.fossil} moveresult]} { |
||||||
|
puts stderr "${ansiwarn}The fossil test-move-repository command appears to have failed${ansireset}" |
||||||
|
puts stderr "$moveresult" |
||||||
|
} else { |
||||||
|
puts stdout "OK - move performed with result:" |
||||||
|
puts stdout $moveresult |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
cd $original_cwd |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
puts stdout "-done-" |
||||||
|
} else { |
||||||
|
puts stdout "-cancelled by user-" |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::mix::commandset::repo [namespace eval punk::mix::commandset::repo { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,94 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::mix::templates 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license BSD |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
package require punk::cap |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::mix::templates { |
||||||
|
variable pkg punk::mix::templates |
||||||
|
variable cap_provider |
||||||
|
|
||||||
|
namespace eval capsystem { |
||||||
|
if {[info commands capprovider.registration] eq ""} { |
||||||
|
punk::cap::class::interface_capprovider.registration create capprovider.registration |
||||||
|
oo::objdefine capprovider.registration { |
||||||
|
method get_declarations {} { |
||||||
|
set decls [list] |
||||||
|
lappend decls [list punk.templates {path templates pathtype adhoc vendor _project}] ;#todo - split out to a different provider package? |
||||||
|
|
||||||
|
lappend decls [list punk.templates {path templates pathtype module vendor punk}] |
||||||
|
#only punk::templates is allowed to register a _multivendor path - review |
||||||
|
#other punk.template providers should use module, absolute, currentproject and shellproject pathtypes only |
||||||
|
lappend decls [list punk.templates {path src/decktemplates pathtype currentproject_multivendor vendor punk}] |
||||||
|
lappend decls [list punk.templates {path decktemplates pathtype shellproject_multivendor vendor punk}] |
||||||
|
|
||||||
|
|
||||||
|
#we need a way to ensure we don't pull updates from a remote repo into a local project that is actually the same project ? review! |
||||||
|
#need flags as to whether/how provider allows template updates that are out of sync with the provider pkg version |
||||||
|
#perhaps a separate .txt file (alongside buildversion and description txt files) that has some package require statements (we can't put them in the template itself as the filled template may have nothing to do with the punk.templates provider) |
||||||
|
lappend decls [list punk.templates {path src/decktemplates/vendor/punk pathtype currentproject vendor punk allowupdates 0 repo "https://www.gitea1.intx.com.au/jn/punkshell" reposubdir "src/decktemplates/vendor/punk"}] |
||||||
|
lappend decls [list punk.isbogus {provider punk::mix::templates something blah}] ;#some capability for which there is no handler to validate - therefore no warning will result. |
||||||
|
#review - we should report unhandled caps somewhere, or provide a mechanism to detect/report. |
||||||
|
#we don't want to warn at the time this provider is loaded - as handler may legitimately be loaded later. |
||||||
|
return $decls |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[info commands provider] eq ""} { |
||||||
|
punk::cap::class::interface_capprovider.provider create provider punk::mix::templates |
||||||
|
oo::objdefine provider { |
||||||
|
method register {{capabilityname_glob *}} { |
||||||
|
#puts registering punk::mix::templates $capabilityname |
||||||
|
next $capabilityname_glob |
||||||
|
} |
||||||
|
method capabilities {} { |
||||||
|
next |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# -- --- |
||||||
|
#provider api |
||||||
|
# -- --- |
||||||
|
#none - declarations only |
||||||
|
#todo - template folder install/update/status methods? |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::mix::templates [namespace eval punk::mix::templates { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
@ -0,0 +1,6 @@ |
|||||||
|
#!/bin/sh |
||||||
|
# -*- tcl -*- \ |
||||||
|
# 'build.tcl' name as required by kettle |
||||||
|
# Can be run directly - but also using `deck Kettle ...` or `deck KettleShell ...`\ |
||||||
|
exec ./kettle -f "$0" "${1+$@}" |
||||||
|
kettle doc |
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,53 @@ |
|||||||
|
apply {code { |
||||||
|
set scriptpath [file normalize [info script]] |
||||||
|
if {[string match "#modpod-loadscript*.tcl" [file tail $scriptpath]]} { |
||||||
|
#jump up an extra dir level if we are within a #modpod-loadscript file. |
||||||
|
set mypath [file dirname [file dirname $scriptpath]] |
||||||
|
#expect to be in folder #modpod-<module>-<ver> |
||||||
|
#Now we need to test if we are in a mounted folder vs an extracted folder |
||||||
|
set container [file dirname $mypath] |
||||||
|
if {[string match "#mounted-modpod-*" $container]} { |
||||||
|
set mypath [file dirname $container] |
||||||
|
} |
||||||
|
set modver [string range [file tail [file dirname $scriptpath]] 8 end] ;# the containing folder is named #modpod-<module>-<ver> |
||||||
|
} else { |
||||||
|
set mypath [file dirname $scriptpath] |
||||||
|
set modver [file root [file tail [info script]]] |
||||||
|
} |
||||||
|
set mysegs [file split $mypath] |
||||||
|
set overhang [list] |
||||||
|
foreach libpath [tcl::tm::list] { |
||||||
|
set libsegs [file split $libpath] ;#split and rejoin with '/' because sometimes module paths may have mixed \ & / |
||||||
|
if {[file join $mysegs /] eq [file join [lrange $libsegs 0 [llength $mysegs]] /]} { |
||||||
|
#mypath is below libpath |
||||||
|
set overhang [lrange $mysegs [llength $libsegs]+1 end] |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
lassign [split $modver -] moduletail version |
||||||
|
set ns [join [concat $overhang $moduletail] ::] |
||||||
|
#if {![catch {package require modpod}]} { |
||||||
|
# ::modpod::disconnect [info script] |
||||||
|
#} |
||||||
|
package provide $ns $version |
||||||
|
namespace eval $ns $code |
||||||
|
} ::} { |
||||||
|
# |
||||||
|
# Module procs here, where current namespace is that of the module. |
||||||
|
# Package version can, if needed, be accessed as [uplevel 1 {set version}] |
||||||
|
# Last element of module name: [uplevel 1 {set moduletail}] |
||||||
|
# Full module name: [uplevel 1 {set ns}] |
||||||
|
|
||||||
|
#<modulecode> |
||||||
|
# |
||||||
|
#</modulecode> |
||||||
|
|
||||||
|
#<sourcefiles> |
||||||
|
# |
||||||
|
#</sourcefiles> |
||||||
|
|
||||||
|
#<loadfiles> |
||||||
|
# |
||||||
|
#</loadfiles> |
||||||
|
|
||||||
|
} |
||||||
Binary file not shown.
@ -0,0 +1,3 @@ |
|||||||
|
%Major.Minor.Level% |
||||||
|
#First line must be a semantic version number |
||||||
|
#all other lines are ignored. |
||||||
@ -0,0 +1,10 @@ |
|||||||
|
Identifier: %package% |
||||||
|
Version: %version% |
||||||
|
Title: %title% |
||||||
|
Creator: %name% <%email%> |
||||||
|
Description: %description% |
||||||
|
Rights: BSD |
||||||
|
URL: %url% |
||||||
|
Available: |
||||||
|
Architecture: tcl |
||||||
|
Subject: |
||||||
@ -0,0 +1,7 @@ |
|||||||
|
::lindex tcl;#\ |
||||||
|
@call tclsh "%~dp0%~n0.bat" %* & goto :eof |
||||||
|
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
||||||
|
puts stdout "script: [info script]" |
||||||
|
puts stdout "argv: $::argc" |
||||||
|
puts stdout "args: '$::argv'" |
||||||
|
|
||||||
@ -0,0 +1,112 @@ |
|||||||
|
: "[proc : args {}]" ;# *tcl shellbat - call with sh,bash,tclsh on any platform, or with cmd on windows. |
||||||
|
: <<'HIDE_FROM_BASH_AND_SH' |
||||||
|
: ;# leading colon hides from .bat, trailing slash hides next line from tcl \ |
||||||
|
@call tclsh "%~dp0%~n0.bat" %* |
||||||
|
: ;#\ |
||||||
|
@set taskexitcode=%errorlevel% & goto :exit |
||||||
|
# -*- tcl -*- |
||||||
|
# ################################################################################################# |
||||||
|
# This is a tcl shellbat file |
||||||
|
# It is tuned to run when called as a batch file, a tcl script, an sh script or a bash script, |
||||||
|
# so the specific layout and characters used are quite sensitive to change. |
||||||
|
# It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. |
||||||
|
# e.g ./filename.sh.bat in sh or bash or powershell |
||||||
|
# e.g filename.sh or filename.sh.bat at windows command prompt |
||||||
|
# e.g tclsh filename.sh.bat | sh filename.sh.bat | bash filename.sh.bat |
||||||
|
# In all cases an arbitrary number of arguments are accepted |
||||||
|
# To avoid the initial commandline on stdout when calling as a batch file on windows, use: |
||||||
|
# cmd /Q /c filename.sh.bat |
||||||
|
# (because we cannot use @if to silence it, as this isn't understood by tcl,sh or bash) |
||||||
|
# ################################################################################################# |
||||||
|
#fconfigure stdout -translation crlf |
||||||
|
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload |
||||||
|
#puts "script : [info script]" |
||||||
|
#puts "argcount : $::argc" |
||||||
|
#puts "argvalues: $::argv" |
||||||
|
|
||||||
|
|
||||||
|
#<tcl-payload> |
||||||
|
#<tcl-payload/> |
||||||
|
|
||||||
|
# --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||||
|
# only exit if needed. see exitcode notes at bottom of file and exit there for consistency across invocation methods |
||||||
|
# --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload |
||||||
|
#-- |
||||||
|
#-- bash/sh code follows. |
||||||
|
#-- protect from tcl using line continuation char on the previous comment for each line, like so: \ |
||||||
|
printf "etc" |
||||||
|
#-- or alternatively place sh/bash script within the false==false block |
||||||
|
#-- whilst being careful to balance braces {} |
||||||
|
#-- For more complex needs you should call out to external scripts |
||||||
|
#-- |
||||||
|
#-- END marker for hide_from_bash_and_sh\ |
||||||
|
HIDE_FROM_BASH_AND_SH |
||||||
|
|
||||||
|
#--------------------------------------------------------- |
||||||
|
#-- This if statement hides(mostly) a sh/bash code block from Tcl |
||||||
|
if false==false # else { |
||||||
|
then |
||||||
|
: |
||||||
|
#--------------------------------------------------------- |
||||||
|
#-- leave as is if all that's required is launching the Tcl payload" |
||||||
|
#-- |
||||||
|
#-- Note that sh/bash script isn't called when running a .bat from cmd.exe on windows by default |
||||||
|
#-- adjust line 4: @call tclsh ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate |
||||||
|
#-- if sh/bash scripting needs to run on windows too. |
||||||
|
#-- |
||||||
|
#printf "start of bash or sh code" |
||||||
|
|
||||||
|
#<shell-payload-pre-tcl> |
||||||
|
#</shell-payload-pre-tcl> |
||||||
|
|
||||||
|
|
||||||
|
#-- sh/bash launches Tcl here instead of shebang line at top |
||||||
|
#<shell-launch-tcl> |
||||||
|
#-- use exec to use exitcode (if any) directly from the tcl script |
||||||
|
exec /usr/bin/env tclsh "$0" "$@" |
||||||
|
#</shell-launch-tcl> |
||||||
|
|
||||||
|
#-- alternative - if sh/bash script required to run after the tcl call. |
||||||
|
#/usr/bin/env tclsh "$0" "$@" |
||||||
|
#tcl_exitcode=$? |
||||||
|
#echo "tcl_exitcode: ${tcl_exitcode}" |
||||||
|
|
||||||
|
#<shell-payload-post-tcl> |
||||||
|
#</shell-payload-post-tcl> |
||||||
|
|
||||||
|
#-- override exitcode example |
||||||
|
#exit 66 |
||||||
|
|
||||||
|
#printf "No need for trailing slashes for sh/bash code here\n" |
||||||
|
#--------------------------------------------------------- |
||||||
|
fi |
||||||
|
# closing brace for Tcl } |
||||||
|
#--------------------------------------------------------- |
||||||
|
|
||||||
|
#-- tcl and shell script now both active |
||||||
|
|
||||||
|
#-- comment for line sample 1 with trailing continuation slash \ |
||||||
|
#printf "tcl-invisible sh/bash line sample 1 \n" |
||||||
|
|
||||||
|
#-- comment for line sample 2 with trailing continuation slash \ |
||||||
|
#printf "tcl-invisible sh/bash line sample 2 \n" |
||||||
|
|
||||||
|
|
||||||
|
#-- Consistent exitcode from sh,bash,tclsh or cmd |
||||||
|
#-- Call exit in tcl (or sh/bash) code only if explicitly required, otherwise leave this commented out. |
||||||
|
#-- (script might be more widely useable without explicit exit. e.g in tcl: set ::argc 1; set ::argv "val"; source filename.sh.bat ) |
||||||
|
#-- exit line unprotected by trailing slash will work for tcl and/or sh/bash |
||||||
|
#exit 0 |
||||||
|
#exit 42 |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#-- make sure sh/bash/tcl all skip over .bat style exit \ |
||||||
|
: <<'shell_end' |
||||||
|
#-- .bat exit with exitcode from tcl process \ |
||||||
|
:exit |
||||||
|
: ;# \ |
||||||
|
@exit /B %taskexitcode% |
||||||
|
# .bat has exited \ |
||||||
|
shell_end |
||||||
|
|
||||||
@ -0,0 +1,112 @@ |
|||||||
|
: "[proc : args {}]" ;# *tcl shellbat - call with sh,bash,tclsh on any platform, or with cmd on windows. |
||||||
|
: <<'HIDE_FROM_BASH_AND_SH' |
||||||
|
: ;# leading colon hides from .bat, trailing slash hides next line from tcl \ |
||||||
|
@call tclsh "%~dp0%~n0.bat" %* |
||||||
|
: ;#\ |
||||||
|
@set taskexitcode=%errorlevel% & goto :exit |
||||||
|
# -*- tcl -*- |
||||||
|
# ################################################################################################# |
||||||
|
# This is a tcl shellbat file |
||||||
|
# It is tuned to run when called as a batch file, a tcl script, an sh script or a bash script, |
||||||
|
# so the specific layout and characters used are quite sensitive to change. |
||||||
|
# It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. |
||||||
|
# e.g ./filename.sh.bat in sh or bash or powershell |
||||||
|
# e.g filename.sh or filename.sh.bat at windows command prompt |
||||||
|
# e.g tclsh filename.sh.bat | sh filename.sh.bat | bash filename.sh.bat |
||||||
|
# In all cases an arbitrary number of arguments are accepted |
||||||
|
# To avoid the initial commandline on stdout when calling as a batch file on windows, use: |
||||||
|
# cmd /Q /c filename.sh.bat |
||||||
|
# (because we cannot use @if to silence it, as this isn't understood by tcl,sh or bash) |
||||||
|
# ################################################################################################# |
||||||
|
#fconfigure stdout -translation crlf |
||||||
|
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload |
||||||
|
#puts "script : [info script]" |
||||||
|
#puts "argcount : $::argc" |
||||||
|
#puts "argvalues: $::argv" |
||||||
|
|
||||||
|
|
||||||
|
#<tcl-payload> |
||||||
|
#<tcl-payload/> |
||||||
|
|
||||||
|
# --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||||
|
# only exit if needed. see exitcode notes at bottom of file and exit there for consistency across invocation methods |
||||||
|
# --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload |
||||||
|
#-- |
||||||
|
#-- bash/sh code follows. |
||||||
|
#-- protect from tcl using line continuation char on the previous comment for each line, like so: \ |
||||||
|
printf "etc" |
||||||
|
#-- or alternatively place sh/bash script within the false==false block |
||||||
|
#-- whilst being careful to balance braces {} |
||||||
|
#-- For more complex needs you should call out to external scripts |
||||||
|
#-- |
||||||
|
#-- END marker for hide_from_bash_and_sh\ |
||||||
|
HIDE_FROM_BASH_AND_SH |
||||||
|
|
||||||
|
#--------------------------------------------------------- |
||||||
|
#-- This if statement hides(mostly) a sh/bash code block from Tcl |
||||||
|
if false==false # else { |
||||||
|
then |
||||||
|
: |
||||||
|
#--------------------------------------------------------- |
||||||
|
#-- leave as is if all that's required is launching the Tcl payload" |
||||||
|
#-- |
||||||
|
#-- Note that sh/bash script isn't called when running a .bat from cmd.exe on windows by default |
||||||
|
#-- adjust line 4: @call tclsh ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate |
||||||
|
#-- if sh/bash scripting needs to run on windows too. |
||||||
|
#-- |
||||||
|
#printf "start of bash or sh code" |
||||||
|
|
||||||
|
#<shell-payload-pre-tcl> |
||||||
|
#</shell-payload-pre-tcl> |
||||||
|
|
||||||
|
|
||||||
|
#-- sh/bash launches Tcl here instead of shebang line at top |
||||||
|
#<shell-launch-tcl> |
||||||
|
#-- use exec to use exitcode (if any) directly from the tcl script |
||||||
|
exec /usr/bin/env tclsh "$0" "$@" |
||||||
|
#</shell-launch-tcl> |
||||||
|
|
||||||
|
#-- alternative - if sh/bash script required to run after the tcl call. |
||||||
|
#/usr/bin/env tclsh "$0" "$@" |
||||||
|
#tcl_exitcode=$? |
||||||
|
#echo "tcl_exitcode: ${tcl_exitcode}" |
||||||
|
|
||||||
|
#<shell-payload-post-tcl> |
||||||
|
#</shell-payload-post-tcl> |
||||||
|
|
||||||
|
#-- override exitcode example |
||||||
|
#exit 66 |
||||||
|
|
||||||
|
#printf "No need for trailing slashes for sh/bash code here\n" |
||||||
|
#--------------------------------------------------------- |
||||||
|
fi |
||||||
|
# closing brace for Tcl } |
||||||
|
#--------------------------------------------------------- |
||||||
|
|
||||||
|
#-- tcl and shell script now both active |
||||||
|
|
||||||
|
#-- comment for line sample 1 with trailing continuation slash \ |
||||||
|
#printf "tcl-invisible sh/bash line sample 1 \n" |
||||||
|
|
||||||
|
#-- comment for line sample 2 with trailing continuation slash \ |
||||||
|
#printf "tcl-invisible sh/bash line sample 2 \n" |
||||||
|
|
||||||
|
|
||||||
|
#-- Consistent exitcode from sh,bash,tclsh or cmd |
||||||
|
#-- Call exit in tcl (or sh/bash) code only if explicitly required, otherwise leave this commented out. |
||||||
|
#-- (script might be more widely useable without explicit exit. e.g in tcl: set ::argc 1; set ::argv "val"; source filename.sh.bat ) |
||||||
|
#-- exit line unprotected by trailing slash will work for tcl and/or sh/bash |
||||||
|
#exit 0 |
||||||
|
#exit 42 |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#-- make sure sh/bash/tcl all skip over .bat style exit \ |
||||||
|
: <<'shell_end' |
||||||
|
#-- .bat exit with exitcode from tcl process \ |
||||||
|
:exit |
||||||
|
: ;# \ |
||||||
|
@exit /B %taskexitcode% |
||||||
|
# .bat has exited \ |
||||||
|
shell_end |
||||||
|
|
||||||
@ -0,0 +1,104 @@ |
|||||||
|
: "[proc : args {}]" ;# *tcl shellbat - call with sh,bash,tclsh on any platform, or with cmd on windows. |
||||||
|
: <<'HIDE_FROM_BASH_AND_SH' |
||||||
|
: ;# leading colon hides from .bat, trailing slash hides next line from tcl \ |
||||||
|
@call tclsh "%~dp0%~n0.bat" %* |
||||||
|
: ;#\ |
||||||
|
@set taskexitcode=%errorlevel% & goto :exit |
||||||
|
# -*- tcl -*- |
||||||
|
# ################################################################################################# |
||||||
|
# This is a tcl shellbat file |
||||||
|
# It is tuned to run when called as a batch file, a tcl script, an sh script or a bash script, |
||||||
|
# so the specific layout and characters used are quite sensitive to change. |
||||||
|
# It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. |
||||||
|
# e.g ./filename.sh.bat in sh or bash or powershell |
||||||
|
# e.g filename.sh or filename.sh.bat at windows command prompt |
||||||
|
# e.g tclsh filename.sh.bat | sh filename.sh.bat | bash filename.sh.bat |
||||||
|
# In all cases an arbitrary number of arguments are accepted |
||||||
|
# To avoid the initial commandline on stdout when calling as a batch file on windows, use: |
||||||
|
# cmd /Q /c filename.sh.bat |
||||||
|
# (because we cannot use @if to silence it, as this isn't understood by tcl,sh or bash) |
||||||
|
# ################################################################################################# |
||||||
|
#fconfigure stdout -translation crlf |
||||||
|
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload |
||||||
|
#puts "script : [info script]" |
||||||
|
#puts "argcount : $::argc" |
||||||
|
#puts "argvalues: $::argv" |
||||||
|
|
||||||
|
|
||||||
|
#<tcl-payload> |
||||||
|
|
||||||
|
# --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||||
|
# only exit if needed. see exitcode notes at bottom of file and exit there for consistency across invocation methods |
||||||
|
# --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload |
||||||
|
#-- |
||||||
|
#-- bash/sh code follows. |
||||||
|
#-- protect from tcl using line continuation char on the previous comment for each line, like so: \ |
||||||
|
printf "etc" |
||||||
|
#-- or alternatively place sh/bash script within the false==false block |
||||||
|
#-- whilst being careful to balance braces {} |
||||||
|
#-- For more complex needs you should call out to external scripts |
||||||
|
#-- |
||||||
|
#-- END marker for hide_from_bash_and_sh\ |
||||||
|
HIDE_FROM_BASH_AND_SH |
||||||
|
|
||||||
|
#--------------------------------------------------------- |
||||||
|
#-- This if statement hides(mostly) a sh/bash code block from Tcl |
||||||
|
if false==false # else { |
||||||
|
then |
||||||
|
: |
||||||
|
#--------------------------------------------------------- |
||||||
|
#-- leave as is if all that's required is launching the Tcl payload" |
||||||
|
#-- |
||||||
|
#-- Note that sh/bash script isn't called when running a .bat from cmd.exe on windows by default |
||||||
|
#-- adjust line 4: @call tclsh ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate |
||||||
|
#-- if sh/bash scripting needs to run on windows too. |
||||||
|
#-- |
||||||
|
#printf "start of bash or sh code" |
||||||
|
|
||||||
|
|
||||||
|
#-- sh/bash launches Tcl here instead of shebang line at top |
||||||
|
|
||||||
|
#-- use exec to use exitcode (if any) directly from the tcl script |
||||||
|
exec /usr/bin/env tclsh "$0" "$@" |
||||||
|
|
||||||
|
#-- alternative - if sh/bash script required to run after the tcl call. |
||||||
|
#/usr/bin/env tclsh "$0" "$@" |
||||||
|
#tcl_exitcode=$? |
||||||
|
#echo "tcl_exitcode: ${tcl_exitcode}" |
||||||
|
|
||||||
|
#-- override exitcode example |
||||||
|
#exit 66 |
||||||
|
|
||||||
|
#printf "No need for trailing slashes for sh/bash code here\n" |
||||||
|
#--------------------------------------------------------- |
||||||
|
fi |
||||||
|
# closing brace for Tcl } |
||||||
|
#--------------------------------------------------------- |
||||||
|
|
||||||
|
#-- tcl and shell script now both active |
||||||
|
|
||||||
|
#-- comment for line sample 1 with trailing continuation slash \ |
||||||
|
#printf "tcl-invisible sh/bash line sample 1 \n" |
||||||
|
|
||||||
|
#-- comment for line sample 2 with trailing continuation slash \ |
||||||
|
#printf "tcl-invisible sh/bash line sample 2 \n" |
||||||
|
|
||||||
|
|
||||||
|
#-- Consistent exitcode from sh,bash,tclsh or cmd |
||||||
|
#-- Call exit in tcl (or sh/bash) code only if explicitly required, otherwise leave this commented out. |
||||||
|
#-- (script might be more widely useable without explicit exit. e.g in tcl: set ::argc 1; set ::argv "val"; source filename.sh.bat ) |
||||||
|
#-- exit line unprotected by trailing slash will work for tcl and/or sh/bash |
||||||
|
#exit 0 |
||||||
|
#exit 42 |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#-- make sure sh/bash/tcl all skip over .bat style exit \ |
||||||
|
: <<'shell_end' |
||||||
|
#-- .bat exit with exitcode from tcl process \ |
||||||
|
:exit |
||||||
|
: ;# \ |
||||||
|
@exit /B %taskexitcode% |
||||||
|
# .bat has exited \ |
||||||
|
shell_end |
||||||
|
|
||||||
@ -0,0 +1,106 @@ |
|||||||
|
if (true=="shellbat") #;#\ |
||||||
|
: <<'HIDE_FROM_BASH_AND_SH' |
||||||
|
::lindex tcl;# leading colons hide from .bat, trailing slash hides next line from tcl \ |
||||||
|
@call tclsh "%~dp0%~n0.bat" %* |
||||||
|
::lindex tcl;#\ |
||||||
|
@set taskexitcode=%errorlevel% & goto :exit |
||||||
|
# -*- tcl -*- |
||||||
|
# ################################################################################################# |
||||||
|
# This is a tcl shellbat file |
||||||
|
# It is tuned to run when called as a batch file, a tcl script, an sh script or a bash script, |
||||||
|
# so the specific layout and characters used are quite sensitive to change. |
||||||
|
# It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. |
||||||
|
# e.g ./filename.sh.bat in sh or bash or powershell |
||||||
|
# e.g filename.sh or filename.sh.bat at windows command prompt |
||||||
|
# e.g tclsh filename.sh.bat | sh filename.sh.bat | bash filename.sh.bat |
||||||
|
# In all cases an arbitrary number of arguments are accepted |
||||||
|
# To avoid the initial commandline on stdout when calling as a batch file on windows, use: |
||||||
|
# cmd /Q /c filename.sh.bat |
||||||
|
# (because we cannot use @if to silence it, as this isn't understood by tcl,sh or bash) |
||||||
|
# ################################################################################################# |
||||||
|
#fconfigure stdout -translation crlf |
||||||
|
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload |
||||||
|
#puts "script : [info script]" |
||||||
|
#puts "argcount : $::argc" |
||||||
|
#puts "argvalues: $::argv" |
||||||
|
|
||||||
|
#<tcl-payload> |
||||||
|
|
||||||
|
# --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||||
|
# only exit if needed. see exitcode notes at bottom of file and exit there for consistency across invocation methods |
||||||
|
# --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload |
||||||
|
#-- |
||||||
|
#-- bash/sh code follows. |
||||||
|
#-- protect from tcl using line continuation char on the previous comment for each line, like so: \ |
||||||
|
printf "etc" |
||||||
|
#-- or alternatively place sh/bash script within the false==false block |
||||||
|
#-- whilst being careful to balance braces {} |
||||||
|
#-- For more complex needs you should call out to external scripts |
||||||
|
#-- |
||||||
|
#-- END marker for hide_from_bash_and_sh\ |
||||||
|
HIDE_FROM_BASH_AND_SH |
||||||
|
#\ |
||||||
|
then |
||||||
|
|
||||||
|
#--------------------------------------------------------- |
||||||
|
if false==false # else { |
||||||
|
then |
||||||
|
: |
||||||
|
#--------------------------------------------------------- |
||||||
|
#-- leave as is if all that's required is launching the Tcl payload" |
||||||
|
#-- |
||||||
|
#-- Note that sh/bash script isn't called when running a .bat from cmd.exe on windows by default |
||||||
|
#-- adjust line 4: @call tclsh ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate |
||||||
|
#-- if sh/bash scripting needs to run on windows too. |
||||||
|
#-- |
||||||
|
#printf "start of bash or sh code" |
||||||
|
|
||||||
|
|
||||||
|
#-- sh/bash launches Tcl here instead of shebang line at top |
||||||
|
|
||||||
|
#-- use exec to use exitcode (if any) directly from the tcl script |
||||||
|
exec /usr/bin/env tclsh "$0" "$@" |
||||||
|
|
||||||
|
#-- alternative - if sh/bash script required to run after the tcl call. |
||||||
|
#/usr/bin/env tclsh "$0" "$@" |
||||||
|
#tcl_exitcode=$? |
||||||
|
#echo "tcl_exitcode: ${tcl_exitcode}" |
||||||
|
|
||||||
|
#-- override exitcode example |
||||||
|
#exit 66 |
||||||
|
|
||||||
|
#printf "No need for trailing slashes for sh/bash code here\n" |
||||||
|
#--------------------------------------------------------- |
||||||
|
fi |
||||||
|
# } |
||||||
|
#--------------------------------------------------------- |
||||||
|
|
||||||
|
#-- comment for line sample 1 with trailing continuation slash \ |
||||||
|
#printf "tcl-invisible sh/bash line sample 1 \n" |
||||||
|
|
||||||
|
#-- comment for line sample 2 with trailing continuation slash \ |
||||||
|
#printf "tcl-invisible sh/bash line sample 2 \n" |
||||||
|
|
||||||
|
|
||||||
|
#-- Consistent exitcode from sh,bash,tclsh or cmd |
||||||
|
#-- Call exit in tcl (or sh/bash) code only if explicitly required, otherwise leave this commented out. |
||||||
|
#-- (script might be more widely useable without explicit exit. e.g in tcl: set ::argc 1; set ::argv "val"; source filename.sh.bat ) |
||||||
|
#-- exit line unprotected by trailing slash will work for tcl and/or sh/bash |
||||||
|
#exit 0 |
||||||
|
#exit 42 |
||||||
|
|
||||||
|
|
||||||
|
#--------------------------------------------------------- |
||||||
|
#-- end if true==shellbat on very first line\ |
||||||
|
fi |
||||||
|
#--------------------------------------------------------- |
||||||
|
|
||||||
|
#-- make sure sh/bash/tcl all skip over .bat style exit \ |
||||||
|
: <<'shell_end' |
||||||
|
#-- .bat exit with exitcode from tcl process \ |
||||||
|
:exit |
||||||
|
::lindex tcl;#\ |
||||||
|
@exit /B %taskexitcode% |
||||||
|
#\ |
||||||
|
shell_end |
||||||
|
|
||||||
@ -0,0 +1,3 @@ |
|||||||
|
::lindex tcl;#\ |
||||||
|
@call tclsh "%~dp0%~n0.bat" %* & goto :eof |
||||||
|
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
||||||
@ -0,0 +1,8 @@ |
|||||||
|
::lindex tcl;#\ |
||||||
|
@call tclsh "%~dp0%~n0.bat" %* & goto :eof |
||||||
|
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
||||||
|
puts stdout "exe: [info nameof]" |
||||||
|
puts stdout "scr: [info script]" |
||||||
|
puts stdout "argc: $::argc" |
||||||
|
puts stdout "argv: '$::argv'" |
||||||
|
|
||||||
@ -0,0 +1,19 @@ |
|||||||
|
::set - { |
||||||
|
@goto start |
||||||
|
# -- tcl bat |
||||||
|
:start |
||||||
|
@echo off |
||||||
|
set script=%0 |
||||||
|
echo %* |
||||||
|
if exist %script%.bat set script=%script%.bat |
||||||
|
tclsh %script% %* |
||||||
|
goto end of BAT file |
||||||
|
};unset - ;# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
||||||
|
|
||||||
|
puts stdout "exe: [info nameof]" |
||||||
|
puts stdout "scr: [info script]" |
||||||
|
puts stdout "argc: $::argc" |
||||||
|
puts stdout "argv: '$::argv'" |
||||||
|
|
||||||
|
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl\ |
||||||
|
:end of BAT file |
||||||
@ -0,0 +1,365 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::mix::util 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
namespace eval punk::mix::util { |
||||||
|
variable has_winpath 0 |
||||||
|
} |
||||||
|
|
||||||
|
if {"windows" eq $::tcl_platform(platform)} { |
||||||
|
if {![catch {package require punk::winpath}]} { |
||||||
|
set punk::mix::util::has_winpath 1 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::mix::util { |
||||||
|
variable tmpfile_counter 0 ;#additional tmpfile collision avoidance |
||||||
|
|
||||||
|
namespace export * |
||||||
|
|
||||||
|
#NOTE fileutil::cat seems to silently ignore options if passed at end instead of before file! |
||||||
|
proc fcat {args} { |
||||||
|
variable has_winpath |
||||||
|
|
||||||
|
|
||||||
|
set knownopts [list -eofchar -translation -encoding --] |
||||||
|
set last_opt 0 |
||||||
|
for {set i 0} {$i < [llength $args]} {incr i} { |
||||||
|
set ival [lindex $args $i] |
||||||
|
#puts stdout "i:$i a: $ival known: [expr {$ival in $knownopts}]" |
||||||
|
if {$ival eq "--"} { |
||||||
|
set last_opt $i |
||||||
|
break |
||||||
|
} else { |
||||||
|
if {$ival in $knownopts} { |
||||||
|
#puts ">known at $i : [lindex $args $i]" |
||||||
|
if {($i % 2) != 0} { |
||||||
|
error "unexpected option at index $i. known options: $knownopts must come in -opt val pairs." |
||||||
|
} |
||||||
|
incr i |
||||||
|
set last_opt $i |
||||||
|
} else { |
||||||
|
set last_opt [expr {$i - 1}] |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set first_non_opt [expr {$last_opt + 1}] |
||||||
|
|
||||||
|
#puts stderr "first_non_opt: $first_non_opt" |
||||||
|
set opts [lrange $args -1 $first_non_opt-1] |
||||||
|
set paths [lrange $args $first_non_opt end] |
||||||
|
if {![llength $paths]} { |
||||||
|
error "Unable to find file in the supplied arguments: $args. Ensure options are all -opt val pairs and that file name(s) follow" |
||||||
|
} |
||||||
|
|
||||||
|
#puts stderr "opts: $opts paths: $paths" |
||||||
|
|
||||||
|
#let's proceed, but warn the user if an apparent option is in paths |
||||||
|
foreach opt [list -encoding -eofchar -translation] { |
||||||
|
if {$opt in $paths} { |
||||||
|
puts stderr "fcat WARNING: apparent option $opt found after file argument(s) (expected them before filenames). Passing to fileutil::cat anyway - but for at least some versions, these options may be ignored. commandline 'fcat $args'" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$::tcl_platform(platform) ne "windows"} { |
||||||
|
return [fileutil::cat {*}$args] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set finalpaths [list] |
||||||
|
foreach p $paths { |
||||||
|
if {$has_winpath && [punk::winpath::illegalname_test $p]} { |
||||||
|
lappend finalpaths [punk::winpath::illegalname_fix $p] |
||||||
|
} else { |
||||||
|
lappend finalpaths $p |
||||||
|
} |
||||||
|
} |
||||||
|
fileutil::cat {*}$opts {*}$finalpaths |
||||||
|
} |
||||||
|
|
||||||
|
#---------------------------------------- |
||||||
|
namespace eval internal { |
||||||
|
proc path_common_prefix_pop {varname} { |
||||||
|
upvar 1 $varname var |
||||||
|
set var [lassign $var head] |
||||||
|
return $head |
||||||
|
} |
||||||
|
} |
||||||
|
proc path_common_prefix {args} { |
||||||
|
set dirs $args |
||||||
|
set parts [file split [internal::path_common_prefix_pop dirs]] |
||||||
|
while {[llength $dirs]} { |
||||||
|
set r {} |
||||||
|
foreach cmp $parts elt [file split [internal::path_common_prefix_pop dirs]] { |
||||||
|
if {$cmp ne $elt} break |
||||||
|
lappend r $cmp |
||||||
|
} |
||||||
|
set parts $r |
||||||
|
} |
||||||
|
if {[llength $parts]} { |
||||||
|
return [file join {*}$parts] |
||||||
|
} else { |
||||||
|
return "" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#retains case from first argument only - caseless comparison |
||||||
|
proc path_common_prefix_nocase {args} { |
||||||
|
set dirs $args |
||||||
|
set parts [file split [internal::path_common_prefix_pop dirs]] |
||||||
|
while {[llength $dirs]} { |
||||||
|
set r {} |
||||||
|
foreach cmp $parts elt [file split [internal::path_common_prefix_pop dirs]] { |
||||||
|
if {![string equal -nocase $cmp $elt]} break |
||||||
|
lappend r $cmp |
||||||
|
} |
||||||
|
set parts $r |
||||||
|
} |
||||||
|
if {[llength $parts]} { |
||||||
|
return [file join {*}$parts] |
||||||
|
} else { |
||||||
|
return "" |
||||||
|
} |
||||||
|
} |
||||||
|
#---------------------------------------- |
||||||
|
|
||||||
|
#namespace import ::punk::ns::nsimport_noclobber |
||||||
|
|
||||||
|
proc namespace_import_pattern_to_namespace_noclobber {pattern ns} { |
||||||
|
set source_ns [namespace qualifiers $pattern] |
||||||
|
if {![namespace exists $source_ns]} { |
||||||
|
error "namespace_import_pattern_to_namespace_noclobber error namespace $source_ns not found" |
||||||
|
} |
||||||
|
if {![string match ::* $ns]} { |
||||||
|
set nscaller [uplevel 1 {namespace current}] |
||||||
|
set ns [punk::nsjoin $nscaller $ns] |
||||||
|
} |
||||||
|
set a_export_patterns [namespace eval $source_ns {namespace export}] |
||||||
|
set a_commands [info commands $pattern] |
||||||
|
set a_tails [lmap v $a_commands {namespace tail $v}] |
||||||
|
set a_exported_tails [list] |
||||||
|
foreach pattern $a_export_patterns { |
||||||
|
set matches [lsearch -all -inline $a_tails $pattern] |
||||||
|
foreach m $matches { |
||||||
|
if {$m ni $a_exported_tails} { |
||||||
|
lappend a_exported_tails $m |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set imported_commands [list] |
||||||
|
foreach e $a_exported_tails { |
||||||
|
set imported [namespace eval $ns [string map [list <func> $e <a> $source_ns] { |
||||||
|
set cmd "" |
||||||
|
if {![catch {namespace import <a>::<func>}]} { |
||||||
|
set cmd <func> |
||||||
|
} |
||||||
|
set cmd |
||||||
|
}]] |
||||||
|
if {[string length $imported]} { |
||||||
|
lappend imported_commands $imported |
||||||
|
} |
||||||
|
} |
||||||
|
return $imported_commands |
||||||
|
} |
||||||
|
|
||||||
|
proc askuser {question} { |
||||||
|
if {![catch {package require punk::lib}]} { |
||||||
|
return [punk::lib::askuser $question] ;#takes account of terminal mode raw vs line (if punk::console used) |
||||||
|
} |
||||||
|
puts stdout $question |
||||||
|
flush stdout |
||||||
|
set stdin_state [fconfigure stdin] |
||||||
|
fconfigure stdin -blocking 1 |
||||||
|
set answer [gets stdin] |
||||||
|
fconfigure stdin -blocking [dict get $stdin_state -blocking] |
||||||
|
return $answer |
||||||
|
} |
||||||
|
|
||||||
|
#review - can be surprising if caller unaware it uses try |
||||||
|
proc do_in_path {path script} { |
||||||
|
#from ::kettle::path::in |
||||||
|
set here [pwd] |
||||||
|
try { |
||||||
|
cd $path |
||||||
|
uplevel 1 $script |
||||||
|
} finally { |
||||||
|
cd $here |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc foreach-file {path script_pathvariable script} { |
||||||
|
upvar 1 $script_pathvariable thepath |
||||||
|
|
||||||
|
set known {} |
||||||
|
lappend waiting $path |
||||||
|
while {[llength $waiting]} { |
||||||
|
set pending $waiting |
||||||
|
set waiting {} |
||||||
|
set at 0 |
||||||
|
while {$at < [llength $pending]} { |
||||||
|
set current [lindex $pending $at] |
||||||
|
incr at |
||||||
|
|
||||||
|
# Do not follow into parent. |
||||||
|
if {[string match *.. $current]} continue |
||||||
|
|
||||||
|
# Ignore what we have visited already. |
||||||
|
set c [file dirname [file normalize $current/___]] |
||||||
|
if {[dict exists $known $c]} continue |
||||||
|
dict set known $c . |
||||||
|
|
||||||
|
if {[file tail $c] eq ".git"} { |
||||||
|
continue |
||||||
|
} |
||||||
|
|
||||||
|
# Expand directories. |
||||||
|
if {[file isdirectory $c]} { |
||||||
|
lappend waiting {*}[lsort -unique [glob -directory $c * .*]] |
||||||
|
continue |
||||||
|
} |
||||||
|
|
||||||
|
# Handle files as per the user's will. |
||||||
|
set thepath $current |
||||||
|
switch -exact -- [catch { uplevel 1 $script } result] { |
||||||
|
0 - 4 { |
||||||
|
# ok, continue - nothing |
||||||
|
} |
||||||
|
2 { |
||||||
|
# return, abort, rethrow |
||||||
|
return -code return |
||||||
|
} |
||||||
|
3 { |
||||||
|
# break, abort |
||||||
|
return |
||||||
|
} |
||||||
|
1 - default { |
||||||
|
# error, any thing else - rethrow |
||||||
|
return -code error $result |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc is_valid_tm_version {versionpart} { |
||||||
|
#Needs to be suitable for use with Tcl's 'package vcompare' |
||||||
|
if {![catch [list package vcompare $versionpart $versionpart]]} { |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
#Note that semver only has a small overlap with tcl tm versions. |
||||||
|
#todo - work out what overlap and whether it's even useful |
||||||
|
#see also TIP #439: Semantic Versioning (tcl 9??) |
||||||
|
proc semver {versionstring} { |
||||||
|
set re {^(0|[1-9]\d*)\.(0|[1-9]\d*)\.(0|[1-9]\d*)(?:-((?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*)(?:\.(?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*))*))?(?:\+([0-9a-zA-Z-]+(?:\.[0-9a-zA-Z-]+)*))?$} |
||||||
|
} |
||||||
|
#todo - semver conversion/validation for other systems? |
||||||
|
proc magic_tm_version {} { |
||||||
|
set magicbase 999999 ;#deliberately large so given load-preference when testing! |
||||||
|
#we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version |
||||||
|
return ${magicbase}.0a1.0 |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
proc tmpfile {{prefix tmp_}} { |
||||||
|
#note risk of collision if pregenerating a list of tmpfile names |
||||||
|
#we will maintain an icrementing id so the caller doesn't have to bear that in mind |
||||||
|
variable tmpfile_counter |
||||||
|
global tcl_platform |
||||||
|
return .punkutil_$prefix[pid]_[clock microseconds]_[incr tmpfile_counter]_[info hostname]_$tcl_platform(user) |
||||||
|
} |
||||||
|
|
||||||
|
proc tmpdir {} { |
||||||
|
# Taken from tcllib fileutil. |
||||||
|
global tcl_platform env |
||||||
|
|
||||||
|
set attempdirs [list] |
||||||
|
set problems {} |
||||||
|
|
||||||
|
foreach tmp {TEMP TMP TMPDIR} { |
||||||
|
if { [info exists env($tmp)] } { |
||||||
|
lappend attempdirs $env($tmp) |
||||||
|
} else { |
||||||
|
lappend problems "No environment variable $tmp" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
switch $tcl_platform(platform) { |
||||||
|
windows { |
||||||
|
lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" |
||||||
|
} |
||||||
|
macintosh { |
||||||
|
lappend attempdirs $env(TRASH_FOLDER) ;# a better place? |
||||||
|
} |
||||||
|
default { |
||||||
|
lappend attempdirs \ |
||||||
|
[file join / tmp] \ |
||||||
|
[file join / var tmp] \ |
||||||
|
[file join / usr tmp] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
lappend attempdirs [pwd] |
||||||
|
|
||||||
|
foreach tmp $attempdirs { |
||||||
|
if { [file isdirectory $tmp] && |
||||||
|
[file writable $tmp] } { |
||||||
|
return [file normalize $tmp] |
||||||
|
} elseif { ![file isdirectory $tmp] } { |
||||||
|
lappend problems "Not a directory: $tmp" |
||||||
|
} else { |
||||||
|
lappend problems "Not writable: $tmp" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Fail if nothing worked. |
||||||
|
return -code error "Unable to determine a proper directory for temporary files\n[join $problems \n]" |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::mix::util [namespace eval punk::mix::util { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,159 @@ |
|||||||
|
|
||||||
|
|
||||||
|
package require punk::mix::util |
||||||
|
|
||||||
|
tcl::namespace::eval ::punk::overlay { |
||||||
|
#based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend |
||||||
|
# extend an ensemble-like routine with the routines in some namespace |
||||||
|
# |
||||||
|
# e.g custom_from_base ::punk::mix::cli ::punk::mix::base |
||||||
|
# |
||||||
|
proc custom_from_base {routine base} { |
||||||
|
if {![tcl::string::match ::* $routine]} { |
||||||
|
set resolved [uplevel 1 [list ::tcl::namespace::which $routine]] |
||||||
|
if {$resolved eq {}} { |
||||||
|
error [list {no such routine} $routine] |
||||||
|
} |
||||||
|
set routine $resolved |
||||||
|
} |
||||||
|
set routinens [tcl::namespace::qualifiers $routine] |
||||||
|
if {$routinens eq {::}} { |
||||||
|
set routinens {} |
||||||
|
} |
||||||
|
set routinetail [tcl::namespace::tail $routine] |
||||||
|
|
||||||
|
if {![tcl::string::match ::* $base]} { |
||||||
|
set base [uplevel 1 [ |
||||||
|
list [tcl::namespace::which namespace] current]]::$base |
||||||
|
} |
||||||
|
|
||||||
|
if {![tcl::namespace::exists $base]} { |
||||||
|
error [list {no such namespace} $base] |
||||||
|
} |
||||||
|
|
||||||
|
set base [tcl::namespace::eval $base [ |
||||||
|
list [tcl::namespace::which namespace] current]] |
||||||
|
|
||||||
|
|
||||||
|
#while 1 { |
||||||
|
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||||
|
# if {[namespace which $renamed] eq {}} break |
||||||
|
#} |
||||||
|
|
||||||
|
tcl::namespace::eval $routine [ |
||||||
|
::list tcl::namespace::ensemble configure $routine -unknown [ |
||||||
|
::list ::apply {{base ensemble subcommand args} { |
||||||
|
::list ${base}::_redirected $ensemble $subcommand |
||||||
|
}} $base |
||||||
|
] |
||||||
|
] |
||||||
|
|
||||||
|
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util |
||||||
|
#namespace eval ${routine}::util { |
||||||
|
#::namespace import ::punk::mix::util::* |
||||||
|
#} |
||||||
|
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib |
||||||
|
#namespace eval ${routine}::lib [string map [list <base> $base] { |
||||||
|
# ::namespace import <base>::lib::* |
||||||
|
#}] |
||||||
|
|
||||||
|
tcl::namespace::eval ${routine}::lib [tcl::string::map [list <base> $base <routine> $routine] { |
||||||
|
if {[tcl::namespace::exists <base>::lib]} { |
||||||
|
::set current_paths [tcl::namespace::path] |
||||||
|
if {"<routine>" ni $current_paths} { |
||||||
|
::lappend current_paths <routine> |
||||||
|
} |
||||||
|
tcl::namespace::path $current_paths |
||||||
|
} |
||||||
|
}] |
||||||
|
|
||||||
|
tcl::namespace::eval $routine { |
||||||
|
::set exportlist [::list] |
||||||
|
::foreach cmd [tcl::info::commands [tcl::namespace::current]::*] { |
||||||
|
::set c [tcl::namespace::tail $cmd] |
||||||
|
if {![tcl::string::match _* $c]} { |
||||||
|
::lappend exportlist $c |
||||||
|
} |
||||||
|
} |
||||||
|
tcl::namespace::export {*}$exportlist |
||||||
|
} |
||||||
|
|
||||||
|
return $routine |
||||||
|
} |
||||||
|
#load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix |
||||||
|
#Note: commandset may be imported by different CLIs with different bases *at the same time* |
||||||
|
#so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) |
||||||
|
#we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. |
||||||
|
#commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they |
||||||
|
#want the convenience of using lib:xxx with commands coming from those packages. |
||||||
|
#This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. |
||||||
|
#The basic principle is that the commandset is loaded into the caller(s) with a prefix |
||||||
|
#- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) |
||||||
|
proc import_commandset {prefix separator cmdnamespace} { |
||||||
|
set bad_seps [list "::"] |
||||||
|
if {$separator in $bad_seps} { |
||||||
|
error "import_commandset invalid separator '$separator'" |
||||||
|
} |
||||||
|
#namespace may or may not be a package |
||||||
|
# allow with or without leading :: |
||||||
|
if {[tcl::string::range $cmdnamespace 0 1] eq "::"} { |
||||||
|
set cmdpackage [tcl::string::range $cmdnamespace 2 end] |
||||||
|
} else { |
||||||
|
set cmdpackage $cmdnamespace |
||||||
|
set cmdnamespace ::$cmdnamespace |
||||||
|
} |
||||||
|
|
||||||
|
if {![tcl::namespace::exists $cmdnamespace]} { |
||||||
|
#only do package require if the namespace not already present |
||||||
|
catch {package require $cmdpackage} pkg_load_info |
||||||
|
#recheck |
||||||
|
if {![tcl::namespace::exists $cmdnamespace]} { |
||||||
|
set prov [package provide $cmdpackage] |
||||||
|
if {[tcl::string::length $prov]} { |
||||||
|
set provinfo "(package $cmdpackage is present with version $prov)" |
||||||
|
} else { |
||||||
|
set provinfo "(package $cmdpackage not present)" |
||||||
|
} |
||||||
|
error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util |
||||||
|
|
||||||
|
#let child namespace 'lib' resolve parent namespace and thus util::xxx |
||||||
|
tcl::namespace::eval ${cmdnamespace}::lib [tcl::string::map [list <cmdns> $cmdnamespace] { |
||||||
|
::set nspaths [tcl::namespace::path] |
||||||
|
if {"<cmdns>" ni $nspaths} { |
||||||
|
::lappend nspaths <cmdns> |
||||||
|
} |
||||||
|
tcl::namespace::path $nspaths |
||||||
|
}] |
||||||
|
|
||||||
|
set imported_commands [list] |
||||||
|
set nscaller [uplevel 1 [list tcl::namespace::current]] |
||||||
|
if {[catch { |
||||||
|
#review - noclobber? |
||||||
|
tcl::namespace::eval ${nscaller}::temp_import [list tcl::namespace::import ${cmdnamespace}::*] |
||||||
|
foreach cmd [tcl::info::commands ${nscaller}::temp_import::*] { |
||||||
|
set cmdtail [tcl::namespace::tail $cmd] |
||||||
|
if {$cmdtail eq "_default"} { |
||||||
|
set import_as ${nscaller}::${prefix} |
||||||
|
} else { |
||||||
|
set import_as ${nscaller}::${prefix}${separator}${cmdtail} |
||||||
|
} |
||||||
|
rename $cmd $import_as |
||||||
|
lappend imported_commands $import_as |
||||||
|
} |
||||||
|
} errM]} { |
||||||
|
puts stderr "Error loading commandset $prefix $separator $cmdnamespace" |
||||||
|
puts stderr "err: $errM" |
||||||
|
} |
||||||
|
return $imported_commands |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
package provide punk::overlay [tcl::namespace::eval punk::overlay { |
||||||
|
variable version |
||||||
|
set version 0.1 |
||||||
|
}] |
||||||
@ -0,0 +1,438 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::path 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin punkshell_module_punk::path 0 0.1.0] |
||||||
|
#[copyright "2023"] |
||||||
|
#[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::path] |
||||||
|
#[description] |
||||||
|
#[keywords module path filesystem] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::path |
||||||
|
#[para] Filesystem path utility functions |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::path |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6-}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::path::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::path::class}] |
||||||
|
#[para] class definitions |
||||||
|
if {[info commands [namespace current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
} |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::path { |
||||||
|
namespace export * |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::path}] |
||||||
|
#[para] Core API functions for punk::path |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
proc pathglob_as_re {pathglob} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun pathglob_as_re] [arg pathglob]] |
||||||
|
#[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure |
||||||
|
#[para] ** matches any number of subdirectories. |
||||||
|
#[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself) |
||||||
|
#[para] e.g /etc/**.txt will match any .txt files at any depth below /etc |
||||||
|
#[para] any segment that does not contain ** must match exactly one segment in the path |
||||||
|
#[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc |
||||||
|
#[para] The pathglob doesn't have to contain glob characters, in which case the returned regex will match the pathglob exactly as specified. |
||||||
|
#[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals |
||||||
|
|
||||||
|
|
||||||
|
#todo - consider whether a way to escape the glob chars ? * is practical - to allow literals ? * |
||||||
|
# - would require counting immediately-preceding backslashes |
||||||
|
set pats [list] |
||||||
|
foreach seg [file split $pathglob] { |
||||||
|
if {[string range $seg end end] eq "/"} { |
||||||
|
set seg [string range $seg 0 end-1] ;# e.g c:/ -> c: / -> "" so that join at end doesn't double up |
||||||
|
} |
||||||
|
switch -- $seg { |
||||||
|
* {lappend pats {[^/]*}} |
||||||
|
** {lappend pats {.*}} |
||||||
|
default { |
||||||
|
set seg [string map [list {^ {\^} $ {\$} [} {\[} ( {\(} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters in the input as literals |
||||||
|
#set seg [string map [list . {[.]}] $seg] |
||||||
|
set seg [string map {. [.]} $seg] |
||||||
|
if {[regexp {[*?]} $seg]} { |
||||||
|
set pat [string map [list ** {.*} * {[^/]*} ? {[^/]}] $seg] |
||||||
|
lappend pats "$pat" |
||||||
|
} else { |
||||||
|
lappend pats "$seg" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return "^[join $pats /]\$" |
||||||
|
} |
||||||
|
proc globmatchpath {pathglob path args} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun globmatchpath] [arg pathglob] [arg path] [opt {option value...}]] |
||||||
|
#[para] Return true if the pathglob matches the path |
||||||
|
#[para] see [fun pathglob_as_re] for pathglob description |
||||||
|
#[para] Caller must ensure that file separator is forward slash. (e.g use file normalize on windows) |
||||||
|
#[para] |
||||||
|
#[para] Known options: |
||||||
|
#[para] -nocase 0|1 (default 0 - case sensitive) |
||||||
|
#[para] If -nocase is not supplied - default to case sensitive *except for driveletter* |
||||||
|
#[para] ie - the driveletter alone in paths such as c:/etc will still be case insensitive. (ie c:/ETC/* will match C:/ETC/blah but not C:/etc/blah) |
||||||
|
#[para] Explicitly specifying -nocase 0 will require the entire case to match including the driveletter. |
||||||
|
|
||||||
|
set opts [dict create\ |
||||||
|
-nocase \uFFFF\ |
||||||
|
] |
||||||
|
foreach {k v} $args { |
||||||
|
switch -- $k { |
||||||
|
-nocase { |
||||||
|
dict set opts $k $v |
||||||
|
} |
||||||
|
default { |
||||||
|
error "Unrecognised option '$k'. Known-options: [dict keys $opts]" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
# -- --- --- --- --- --- |
||||||
|
set opt_nocase [dict get $opts -nocase] |
||||||
|
set explicit_nocase 1 ;#default to disprove |
||||||
|
if {$opt_nocase eq "\uFFFF"} { |
||||||
|
set opt_nocase 0 |
||||||
|
set explicit_nocase 0 |
||||||
|
} |
||||||
|
# -- --- --- --- --- --- |
||||||
|
if {$opt_nocase} { |
||||||
|
return [regexp -nocase [pathglob_as_re $pathglob] $path] |
||||||
|
} else { |
||||||
|
set re [pathglob_as_re $pathglob] |
||||||
|
if {$explicit_nocase} { |
||||||
|
set ismatch [regexp $re $path] ;#explicit -nocase 0 - require exact match of path literals including driveletter |
||||||
|
} else { |
||||||
|
#caller is using default for -nocase - which indicates case sensitivity - but we have an exception for the driveletter. |
||||||
|
set re_segments [file split $re] ;#Note that file split c:/etc gives {c:/ etc} but file split ^c:/etc gives {^c: etc} |
||||||
|
set first_seg [lindex $re_segments 0] |
||||||
|
if {[regexp {^\^(.{1}):$} $first_seg _match driveletter]} { |
||||||
|
#first part of re is like "^c:" i.e a drive letter |
||||||
|
set chars [string tolower $driveletter][string toupper $driveletter] |
||||||
|
set re [join [concat "^\[$chars\]:" [lrange $re_segments 1 end]] /] ;#rebuild re with case insensitive driveletter only - use join - not file join. file join will misinterpret leading re segment. |
||||||
|
} |
||||||
|
#puts stderr "-->re: $re" |
||||||
|
set ismatch [regexp $re $path] |
||||||
|
} |
||||||
|
} |
||||||
|
return $ismatch |
||||||
|
} |
||||||
|
|
||||||
|
#todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ |
||||||
|
#then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) |
||||||
|
proc treefilenames {args} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun treefilenames] [opt {option value...}] [opt {globpattern...}]] |
||||||
|
#[para]basic (glob based) list of filenames matching each pattern in tailglobs - recursive |
||||||
|
#[para] options: |
||||||
|
#[para] [opt -dir] <path> |
||||||
|
#[para] defaults to [lb]pwd[rb] - base path for tree to search |
||||||
|
#[para] [opt -antiglob_paths] <list> |
||||||
|
#[para] list of path patterns to exclude - may include * and ** path segments e.g /usr/** |
||||||
|
#[para]no natsorting - so order is dependent on filesystem |
||||||
|
|
||||||
|
set argd [punk::args::get_dict { |
||||||
|
-directory -default "\uFFFF" |
||||||
|
-call-depth-internal -default 0 -type integer |
||||||
|
-antiglob_paths -default {} |
||||||
|
*values -min 0 -max -1 -optional 1 -type string |
||||||
|
tailglobs -multiple 1 |
||||||
|
} $args] |
||||||
|
lassign [dict values $argd] opts values |
||||||
|
set tailglobs [dict values $values] |
||||||
|
# -- --- --- --- --- --- --- |
||||||
|
set opt_antiglob_paths [dict get $opts -antiglob_paths] |
||||||
|
set CALLDEPTH [dict get $opts -call-depth-internal] |
||||||
|
# -- --- --- --- --- --- --- |
||||||
|
set opt_dir [dict get $opts -directory] |
||||||
|
if {$opt_dir eq "\uFFFF"} { |
||||||
|
set opt_dir [pwd] |
||||||
|
} |
||||||
|
# -- --- --- --- --- --- --- |
||||||
|
|
||||||
|
set files [list] |
||||||
|
if {$CALLDEPTH == 0} { |
||||||
|
if {![file isdirectory $opt_dir]} { |
||||||
|
return [list] |
||||||
|
} |
||||||
|
set opts [dict merge $opts [list -directory $opt_dir]] |
||||||
|
if {![llength $tailglobs]} { |
||||||
|
lappend tailglobs * |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set skip 0 |
||||||
|
foreach anti $opt_antiglob_paths { |
||||||
|
if {[globmatchpath $anti $opt_dir]} { |
||||||
|
set skip 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {$skip} { |
||||||
|
return [list] |
||||||
|
} |
||||||
|
|
||||||
|
#todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match? |
||||||
|
set dirfiles [lsort [glob -nocomplain -dir $opt_dir -type f {*}$tailglobs]] |
||||||
|
lappend files {*}$dirfiles |
||||||
|
set dirdirs [glob -nocomplain -dir $opt_dir -type d *] |
||||||
|
foreach dir $dirdirs { |
||||||
|
set skip 0 |
||||||
|
foreach anti $opt_antiglob_paths { |
||||||
|
if {[globmatchpath $anti $dir]} { |
||||||
|
set skip 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {$skip} { |
||||||
|
continue |
||||||
|
} |
||||||
|
set nextopts [dict merge $opts [list -directory $dir -call-depth-internal [incr CALLDEPTH]]] |
||||||
|
lappend files {*}[treefilenames {*}$nextopts {*}$tailglobs] |
||||||
|
} |
||||||
|
return $files |
||||||
|
} |
||||||
|
|
||||||
|
#maint warning - also in punkcheck |
||||||
|
proc relative {reference location} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun relative] [arg reference] [arg location]] |
||||||
|
#[para] Taking two directory paths, a reference and a location, computes the path |
||||||
|
# of the location relative to the reference. |
||||||
|
#[list_begin itemized] |
||||||
|
#[item] |
||||||
|
#[para] Arguments: |
||||||
|
# [list_begin arguments] |
||||||
|
# [arg_def string reference] The path from which the relative path to location is determined. |
||||||
|
# [arg_def string location] The location path which may be above or below the reference path |
||||||
|
# [list_end] |
||||||
|
#[item] |
||||||
|
#[para] Results: |
||||||
|
#[para] The relative path of the location to the reference path. |
||||||
|
#[para] Will return a single dot "." if the paths are the same |
||||||
|
#[item] |
||||||
|
#[para] Notes: |
||||||
|
#[para] Both paths must be the same type - ie both absolute or both relative |
||||||
|
#[para] Case sensitive. ie punk::path::relative /etc /etC |
||||||
|
# will return ../etC |
||||||
|
#[para] On windows, the drive-letter component (only) is not case sensitive |
||||||
|
#[example_begin] |
||||||
|
# P% punk::path::relative c:/etc C:/etc |
||||||
|
# - . |
||||||
|
#[example_end] |
||||||
|
#[para] The part following the driveletter is case sensitive so in the following cases it recognises the driveletter matches but not the tail |
||||||
|
#[example_begin] |
||||||
|
# P% punk::path::relative c:/etc C:/Etc |
||||||
|
# - ../Etc |
||||||
|
#[example_end] |
||||||
|
#[para] On windows, if the paths are absolute and specifiy different volumes, only the location will be returned. |
||||||
|
#[example_begin] |
||||||
|
# P% punk::path::relative c:/etc d:/etc/blah |
||||||
|
# - d:/etc/blah |
||||||
|
#[example_end] |
||||||
|
#[para] Unix-like examples: |
||||||
|
#[example_begin] |
||||||
|
# P% punk::path::relative /usr/local/etc/ /usr/local/etc/somewhere/below |
||||||
|
# - somewhere/below |
||||||
|
# P% punk::path::relative /usr/local/etc/somewhere /usr/local/lib/here |
||||||
|
# - ../../lib/here |
||||||
|
#[example_end] |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
#see also kettle |
||||||
|
# Modified copy of ::fileutil::relative (tcllib) |
||||||
|
# Adapted to 8.5 ({*}). |
||||||
|
|
||||||
|
#review - check volume info on windows.. UNC paths? |
||||||
|
if {[file pathtype $reference] ne [file pathtype $location]} { |
||||||
|
return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $reference] vs. [file pathtype $location], ($reference vs. $location)" |
||||||
|
} |
||||||
|
|
||||||
|
#avoid normalizing if possible (file normalize *very* expensive on windows) |
||||||
|
set do_normalize 0 |
||||||
|
if {[file pathtype $reference] eq "relative"} { |
||||||
|
#if reference is relative so is location |
||||||
|
if {[regexp {[.]{2}} [list $reference $location]]} { |
||||||
|
set do_normalize 1 |
||||||
|
} |
||||||
|
if {[regexp {[.]/} [list $reference $location]]} { |
||||||
|
set do_normalize 1 |
||||||
|
} |
||||||
|
} else { |
||||||
|
set do_normalize 1 |
||||||
|
} |
||||||
|
if {$do_normalize} { |
||||||
|
set reference [file normalize $reference] |
||||||
|
set location [file normalize $location] |
||||||
|
} |
||||||
|
|
||||||
|
set save $location |
||||||
|
set reference [file split $reference] |
||||||
|
set location [file split $location] |
||||||
|
|
||||||
|
while {[lindex $location 0] eq [lindex $reference 0]} { |
||||||
|
set location [lrange $location 1 end] |
||||||
|
set reference [lrange $reference 1 end] |
||||||
|
if {![llength $location]} {break} |
||||||
|
} |
||||||
|
|
||||||
|
set location_len [llength $location] |
||||||
|
set reference_len [llength $reference] |
||||||
|
|
||||||
|
if {($location_len == 0) && ($reference_len == 0)} { |
||||||
|
# Cases: |
||||||
|
# (a) reference == location |
||||||
|
|
||||||
|
set location . |
||||||
|
} else { |
||||||
|
# Cases: |
||||||
|
# (b) ref is: ref/sub = sub |
||||||
|
# loc is: ref = {} |
||||||
|
|
||||||
|
# (c) ref is: ref = {} |
||||||
|
# loc is: ref/sub = sub |
||||||
|
|
||||||
|
while {$reference_len > 0} { |
||||||
|
set location [linsert $location 0 ..] |
||||||
|
incr reference_len -1 |
||||||
|
} |
||||||
|
set location [file join {*}$location] |
||||||
|
} |
||||||
|
return $location |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::path ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::path::lib { |
||||||
|
namespace export * |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::path::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::path::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval punk::path::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::path::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::path [namespace eval punk::path { |
||||||
|
variable pkg punk::path |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,104 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::tdl 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::tdl { |
||||||
|
# https://wiki.tcl-lang.org/page/Config+file+using+slave+interp |
||||||
|
|
||||||
|
variable sample_script { |
||||||
|
server -name bsd1 -os FreeBSD |
||||||
|
server -name p1 -os linux |
||||||
|
server -name trillion -os windows |
||||||
|
|
||||||
|
server -name vmhost1 -os FreeBSD { |
||||||
|
guest -name bsd1 -vmmanager iocage |
||||||
|
guest -name p1 -vmmanager bhyve |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc prettyparse {script} { |
||||||
|
set i [interp create -safe] |
||||||
|
try { |
||||||
|
# $i eval {unset {*}[info vars]} |
||||||
|
# foreach command [$i eval {info commands}] {$i hide $command} |
||||||
|
# $i invokehidden namespace delete {*}[$i invokehidden namespace children] |
||||||
|
$i alias unknown apply {{i tag args} { |
||||||
|
upvar 1 result result |
||||||
|
set e [concat [list tag $tag]\ |
||||||
|
[lrange $args 0 [expr {([llength $args] & ~1) - 1}]]] |
||||||
|
if {[llength $args] % 2} { |
||||||
|
set saved $result |
||||||
|
set result {} |
||||||
|
$i eval [lindex $args end] |
||||||
|
lappend e body $result |
||||||
|
set result $saved |
||||||
|
} |
||||||
|
lappend result $e |
||||||
|
list |
||||||
|
}} $i |
||||||
|
set result {} |
||||||
|
$i eval $script |
||||||
|
return $result |
||||||
|
} finally { |
||||||
|
interp delete $i |
||||||
|
} |
||||||
|
} |
||||||
|
proc prettyprint {data {level 0}} { |
||||||
|
set ind [string repeat " " $level] |
||||||
|
incr level |
||||||
|
set result {} |
||||||
|
foreach e $data { |
||||||
|
set line $ind[concat [list [dict get $e tag]] [dict remove $e tag body]] |
||||||
|
if {[dict exists $e body] && [llength [dict get $e body]]} { |
||||||
|
append line " {\n[prettyprint [dict get $e body] $level]\n$ind}" |
||||||
|
} |
||||||
|
lappend result $line |
||||||
|
} |
||||||
|
join $result \n |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::tdl [namespace eval punk::tdl { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
@ -0,0 +1,266 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::winpath 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license BSD |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval punk::winpath { |
||||||
|
namespace export winpath windir cdwin cdwindir illegalname_fix illegalname_test |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#\\servername\share etc or \\?\UNC\servername\share etc. |
||||||
|
proc is_unc_path {path} { |
||||||
|
set strcopy_path [punk::objclone $path] |
||||||
|
set strcopy_path [string map {\\ /} $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) |
||||||
|
if {[string first "//" $strcopy_path] == 0} { |
||||||
|
#check for "Dos device path" syntax |
||||||
|
if {[string range $strcopy_path 0 3] in {//?/ //./}} { |
||||||
|
#Note that //./ doesn't appear to be supported in Tcl as at 2023-08 - but //?/ works (except for //?/UNC/Server/share) |
||||||
|
if {[string range $strcopy_path 4 6] eq "UNC"} { |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
#some other Dos device path. Could be a drive which is mapped to a UNC path - but the path itself isn't a unc path |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} else { |
||||||
|
#leading double slash and not dos device path syntax |
||||||
|
return 1 |
||||||
|
} |
||||||
|
} |
||||||
|
return 0 |
||||||
|
} |
||||||
|
|
||||||
|
#ordinary \\Servername or \\servername\share or \\servername\share\path (or forward-slash equivalent) with no dos device syntax //?/ //./ etc. |
||||||
|
proc is_unc_path_plain {path} { |
||||||
|
if {[is_unc_path $path]} { |
||||||
|
if {![is_dos_device_path $path]} { |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#int-rep path preserved - but 'file attributes', and therefor this operation, is expensive (on windows at least) |
||||||
|
proc pwdshortname {{path {}}} { |
||||||
|
if {$path eq ""} { |
||||||
|
set path [pwd] |
||||||
|
} else { |
||||||
|
if {[file pathtype $path] eq "relative"} { |
||||||
|
set path [file normalize $path] |
||||||
|
} |
||||||
|
} |
||||||
|
return [dict get [file attributes $path] -shortname] |
||||||
|
} |
||||||
|
#dos device path syntax allows windows api to acces extended-length paths and filenames with illegal path characters such as trailing dots or whitespace |
||||||
|
#(can exist on server shares and on NTFS - but standard apps can't access without dos device syntax) |
||||||
|
proc is_dos_device_path {path} { |
||||||
|
set strcopy_path [punk::objclone $path] |
||||||
|
set strcopy_path [string map {\\ /} $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) |
||||||
|
if {[string range $strcopy_path 0 3] in {//?/ //./}} { |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
proc strip_dos_device_prefix {path} { |
||||||
|
#it's unlikely to be valid to strip only //?/ from a //?/UNC path so check for it here and diver to strip that. |
||||||
|
#(review.. or raise error because a //?/UNC path isn't *strictly* a UNC path? ) |
||||||
|
if {[is_unc_path $path]} { |
||||||
|
return [strip_unc_path_prefix $path] |
||||||
|
} |
||||||
|
if {[is_dos_device_path $path]} { |
||||||
|
return [string range $path 4 end] |
||||||
|
} else { |
||||||
|
return $path |
||||||
|
} |
||||||
|
} |
||||||
|
proc strip_unc_path_prefix {path} { |
||||||
|
if {[is_unc_path $path]} { |
||||||
|
#//?/UNC/server/etc |
||||||
|
set strcopy_path [punk::objclone $path] |
||||||
|
set trimmedpath [string range $strcopy_path 7 end] |
||||||
|
file pathtype $trimmedpath ;#shimmer it to path rep |
||||||
|
return $trimmedpath |
||||||
|
} elseif {is_unc_path_plain $path} { |
||||||
|
#plain unc //server |
||||||
|
set strcopy_path [punk::objclone $path] |
||||||
|
set trimmedpath [string range $strcopy_path 2 end] |
||||||
|
file pathtype $trimmedpath |
||||||
|
return $trimmedpath |
||||||
|
} else { |
||||||
|
return $path |
||||||
|
} |
||||||
|
} |
||||||
|
#we don't validate that path is actually illegal because we don't know the full range of such names. |
||||||
|
#The caller can apply this to any path. |
||||||
|
#don't test for platform here - needs to be callable from any platform for potential passing to windows (what usecase? 8.3 name is not always calculable independently) |
||||||
|
#The utility of this is questionable. prepending a dos-device path won't make a filename with illegal characters readable by windows. |
||||||
|
#It will need the 'shortname' at least for the illegal segment - if not the whole path |
||||||
|
#Whilst the 8.3 name algorithm - including undocumented hash function has been reverse engineered |
||||||
|
#- it depends on the content of the directory - as collisions cause a different name (e.g incremented number) |
||||||
|
#- it also depends on the history of the folder |
||||||
|
#- you can't take the current dir contents and a particular *existing* longname and determine the shortname algorithmically... |
||||||
|
#- the shortname may have been generated during a different directory state. |
||||||
|
#- It is then stored on disk (where?) - so access to reading the existing shortname is required. |
||||||
|
#- An implementation of the 8.3 algorithm would only be potentially useful in determining the name that will result from adding a new file |
||||||
|
# and would be subject to potential collisions if there are race-conditions in file creation |
||||||
|
#- Using an 8.3 algorithm externally would be dangerous in that it could appear to work a lot of the time - but return a different file entirely sometimes. |
||||||
|
#- Conclusion is that the 8.3 name must be retrieved rathern than calclated |
||||||
|
proc illegalname_fix {path} { |
||||||
|
#don't add extra dos device path syntax protection-prefix if already done |
||||||
|
if {[is_unc_path $path]} { |
||||||
|
error "illegalname_fix called on UNC path $path - unable to process" |
||||||
|
} |
||||||
|
if {[is_dos_device_path $path]} { |
||||||
|
#we may have appended |
||||||
|
return $path |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#\\servername\share theoretically maps to: \\?\UNC\servername\share in protected form. https://learn.microsoft.com/en-us/dotnet/standard/io/file-path-formats |
||||||
|
#NOTE: 2023-08 on windows 10 at least \\?\UNC\Server\share doesn't work - ie we can't use illegalname_fix on UNC paths such as \\Server\share |
||||||
|
#(but mapped drive to same path will work) |
||||||
|
#Note that test-path cmdlet in powershell is also flaky with regards to \\?\UNC\Server paths. |
||||||
|
#It seems prudent for now to disallow \\?\ protection for UNC paths such as \\server\etc |
||||||
|
if {[is_unc_path $path]} { |
||||||
|
set err "" |
||||||
|
append err "illegalname_fix doesn't currently support UNC paths (non dos device leading double slash or //?/UNC/...)" |
||||||
|
append err \n " - because //?/UNC/Servername/share is not supported in Tcl (and only minimally even in powershell) as at 2023. (on windows use mapped drive instead)" |
||||||
|
error $err |
||||||
|
} |
||||||
|
|
||||||
|
set strcopy_path [punk::objclone $path] |
||||||
|
|
||||||
|
|
||||||
|
#Note: path could still have leading double slash if it is a Dos device path: e.g. //?/c:/etc |
||||||
|
if {[file pathtype $path] eq "absolute"} { |
||||||
|
if {$path eq "~"} { |
||||||
|
# non-normalized ~ is classified as absolute |
||||||
|
# tilde special meaning is a bit of a nuisance.. but as it's the entire path in this case.. presumably it should be kept that way |
||||||
|
# leave for caller to interpret it - but it's not an illegal name whether it's interpreted with special meaning or not |
||||||
|
# unlikely this fix will be called on a plain tilde anyway |
||||||
|
return $path |
||||||
|
} else { |
||||||
|
set fullpath $path |
||||||
|
} |
||||||
|
} else { |
||||||
|
#set fullpath [file normalize $path] ;#very slow on windows |
||||||
|
#set fullpath [pwd]/$path ;#will keep ./ in middle of path - not valid for dos-device paths |
||||||
|
if {[string range $strcopy_path 0 1] eq "./"} { |
||||||
|
set strcopy_path [string range $strcopy_path 2 end] |
||||||
|
} |
||||||
|
set fullpath [file join [pwd] $strcopy_path] |
||||||
|
} |
||||||
|
#For file I/O, the "\\?\" prefix to a path string tells the Windows APIs to disable all string parsing |
||||||
|
# and to send the string that follows it straight to the file system. |
||||||
|
set protect "\\\\?\\" ;# value is: \\?\ prefix |
||||||
|
set protect2 "//?/" ;#file normalize may do this - it still works |
||||||
|
#don't use "//./" - not currently supported in Tcl - seems to work in powershell though. |
||||||
|
|
||||||
|
|
||||||
|
#choose //?/ as normalized version - since likely 'file normalize' will do it anyway, and experimentall, the windows API accepts both REVIEW |
||||||
|
set result ${protect2}$fullpath |
||||||
|
file pathtype $result ;#make it return a path rep |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
#don't test for platform here - needs to be callable from any platform for potential passing to windows |
||||||
|
#we can create files with windows illegal names by using //?/ dos device path syntax - but we need to detect when that is required. |
||||||
|
# |
||||||
|
# path int-rep preserving |
||||||
|
proc illegalname_test {path} { |
||||||
|
#https://learn.microsoft.com/en-us/windows/win32/fileio/naming-a-file |
||||||
|
#according to the above: Use any character in the current code page for a name, including Unicode characters and characters in the extended character set (128–255), except for the following: |
||||||
|
set reserved [list < > : \" / \\ | ? *] |
||||||
|
|
||||||
|
|
||||||
|
#we need to exclude things like path/.. path/. |
||||||
|
foreach seg [file split $path] { |
||||||
|
if {$seg in [list . ..]} { |
||||||
|
#review - what if there is a folder or file that actually has a name such as . or .. ? |
||||||
|
#unlikely in normal use - but could done deliberately for bad reasons? |
||||||
|
#We are unable to check for it here anyway - as this command is intended for checking the path string - not the actual path on a filesystem. |
||||||
|
# |
||||||
|
#/./ /../ segments don't require protection - keep checking. |
||||||
|
continue |
||||||
|
} |
||||||
|
|
||||||
|
#only check for actual space as other whitespace seems to work without being stripped |
||||||
|
#trailing tab and trailing \n or \r seem to be creatable in windows with Tcl - map to some glyph |
||||||
|
if {[string index $seg end] in [list " " "."]} { |
||||||
|
#windows API doesn't handle trailing dots or spaces (silently strips) - even though such files can be created on NTFS systems (or seen via samba etc) |
||||||
|
return 1 |
||||||
|
} |
||||||
|
} |
||||||
|
#glob chars '* ?' are probably illegal.. but although x*y.txt and x?y.txt don't display properly (* ? replaced with some other glyph) |
||||||
|
#- they seem to be readable from cmd and tclsh as is. |
||||||
|
# pipe symbol also has glyph substitution and behaves the same e.g a|b.txt |
||||||
|
#(at least with encoding system utf-8) |
||||||
|
|
||||||
|
#todo - determine what else constitutes an illegal name according to windows APIs and requires protection with dos device syntax |
||||||
|
return 0 |
||||||
|
} |
||||||
|
|
||||||
|
proc test_ntfs_tunneling {f1 f2 args} { |
||||||
|
file mkdir $f1 |
||||||
|
puts stderr "waiting 15secs..." |
||||||
|
after 5000 {puts -nonewline stderr .} |
||||||
|
after 5000 {puts -nonewline stderr .} |
||||||
|
after 5000 {puts -nonewline stderr .} |
||||||
|
after 500 {puts stderr \n} |
||||||
|
file mkdir $f2 |
||||||
|
puts stdout "$f1 [file stat $f1]" |
||||||
|
puts stdout "$f2 [file stat $f2]" |
||||||
|
file delete $f1 |
||||||
|
puts stdout "renaming $f2 to $f1" |
||||||
|
file rename $f2 $f1 |
||||||
|
puts stdout "$f1 [file stat $f1]" |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::winpath [namespace eval punk::winpath { |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,814 @@ |
|||||||
|
# sha1.tcl - |
||||||
|
# |
||||||
|
# Copyright (C) 2001 Don Libes <libes@nist.gov> |
||||||
|
# Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||||
|
# |
||||||
|
# SHA1 defined by FIPS 180-1, "The SHA1 Message-Digest Algorithm" |
||||||
|
# HMAC defined by RFC 2104, "Keyed-Hashing for Message Authentication" |
||||||
|
# |
||||||
|
# This is an implementation of SHA1 based upon the example code given in |
||||||
|
# FIPS 180-1 and upon the tcllib MD4 implementation and taking some ideas |
||||||
|
# and methods from the earlier tcllib sha1 version by Don Libes. |
||||||
|
# |
||||||
|
# This implementation permits incremental updating of the hash and |
||||||
|
# provides support for external compiled implementations either using |
||||||
|
# critcl (sha1c) or Trf. |
||||||
|
# |
||||||
|
# ref: http://www.itl.nist.gov/fipspubs/fip180-1.htm |
||||||
|
# |
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# @mdgen EXCLUDE: sha1c.tcl |
||||||
|
|
||||||
|
package require Tcl 8.2-; # tcl minimum version |
||||||
|
|
||||||
|
namespace eval ::sha1 { |
||||||
|
variable accel |
||||||
|
array set accel {tcl 0 critcl 0 cryptkit 0 trf 0} |
||||||
|
|
||||||
|
variable loaded {} |
||||||
|
variable active |
||||||
|
array set active {tcl 0 critcl 0 cryptkit 0 trf 0} |
||||||
|
|
||||||
|
namespace export sha1 hmac SHA1Init SHA1Update SHA1Final |
||||||
|
|
||||||
|
variable uid |
||||||
|
if {![info exists uid]} { |
||||||
|
set uid 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# Management of sha1 implementations. |
||||||
|
|
||||||
|
# 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 ::sha1::LoadAccelerator {name} { |
||||||
|
variable accel |
||||||
|
set r 0 |
||||||
|
switch -exact -- $name { |
||||||
|
tcl { |
||||||
|
# Already present (this file) |
||||||
|
set r 1 |
||||||
|
} |
||||||
|
critcl { |
||||||
|
if {![catch {package require tcllibc}] |
||||||
|
|| ![catch {package require sha1c}]} { |
||||||
|
set r [expr {[info commands ::sha1::sha1c] != {}}] |
||||||
|
} |
||||||
|
} |
||||||
|
cryptkit { |
||||||
|
if {![catch {package require cryptkit}]} { |
||||||
|
set r [expr {![catch {cryptkit::cryptInit}]}] |
||||||
|
} |
||||||
|
} |
||||||
|
trf { |
||||||
|
if {![catch {package require Trf}]} { |
||||||
|
set r [expr {![catch {::sha1 aa} msg]}] |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "invalid accelerator $key:\ |
||||||
|
must be one of [join [KnownImplementations] {, }]" |
||||||
|
} |
||||||
|
} |
||||||
|
set accel($name) $r |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# ::sha1::Implementations -- |
||||||
|
# |
||||||
|
# Determines which implementations are |
||||||
|
# present, i.e. loaded. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# None. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A list of implementation keys. |
||||||
|
|
||||||
|
proc ::sha1::Implementations {} { |
||||||
|
variable accel |
||||||
|
set res {} |
||||||
|
foreach n [array names accel] { |
||||||
|
if {!$accel($n)} continue |
||||||
|
lappend res $n |
||||||
|
} |
||||||
|
return $res |
||||||
|
} |
||||||
|
|
||||||
|
# ::sha1::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 ::sha1::KnownImplementations {} { |
||||||
|
return {critcl cryptkit trf tcl} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::sha1::Names {} { |
||||||
|
return { |
||||||
|
critcl {tcllibc based} |
||||||
|
cryptkit {cryptkit based} |
||||||
|
trf {Trf based} |
||||||
|
tcl {pure Tcl} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ::sha1::SwitchTo -- |
||||||
|
# |
||||||
|
# Activates a loaded named implementation. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# key Name of the implementation to activate. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::sha1::SwitchTo {key} { |
||||||
|
variable accel |
||||||
|
variable active |
||||||
|
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\"" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {![string equal $loaded ""]} { |
||||||
|
set active($loaded) 0 |
||||||
|
} |
||||||
|
if {![string equal $key ""]} { |
||||||
|
set active($key) 1 |
||||||
|
} |
||||||
|
|
||||||
|
# Remember the active implementation, for deactivation by future |
||||||
|
# switches. |
||||||
|
|
||||||
|
set loaded $key |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# SHA1Init -- |
||||||
|
# |
||||||
|
# Create and initialize an SHA1 state variable. This will be |
||||||
|
# cleaned up when we call SHA1Final |
||||||
|
# |
||||||
|
|
||||||
|
proc ::sha1::SHA1Init {} { |
||||||
|
variable active |
||||||
|
variable uid |
||||||
|
set token [namespace current]::[incr uid] |
||||||
|
upvar #0 $token state |
||||||
|
|
||||||
|
# FIPS 180-1: 7 - Initialize the hash state |
||||||
|
array set state \ |
||||||
|
[list \ |
||||||
|
A [expr {int(0x67452301)}] \ |
||||||
|
B [expr {int(0xEFCDAB89)}] \ |
||||||
|
C [expr {int(0x98BADCFE)}] \ |
||||||
|
D [expr {int(0x10325476)}] \ |
||||||
|
E [expr {int(0xC3D2E1F0)}] \ |
||||||
|
n 0 i "" ] |
||||||
|
if {$active(cryptkit)} { |
||||||
|
cryptkit::cryptCreateContext state(ckctx) CRYPT_UNUSED CRYPT_ALGO_SHA |
||||||
|
} elseif {$active(trf)} { |
||||||
|
set s {} |
||||||
|
switch -exact -- $::tcl_platform(platform) { |
||||||
|
windows { set s [open NUL w] } |
||||||
|
unix { set s [open /dev/null w] } |
||||||
|
} |
||||||
|
if {$s != {}} { |
||||||
|
fconfigure $s -translation binary -buffering none |
||||||
|
::sha1 -attach $s -mode write \ |
||||||
|
-read-type variable \ |
||||||
|
-read-destination [subst $token](trfread) \ |
||||||
|
-write-type variable \ |
||||||
|
-write-destination [subst $token](trfwrite) |
||||||
|
array set state [list trfread 0 trfwrite 0 trf $s] |
||||||
|
} |
||||||
|
} |
||||||
|
return $token |
||||||
|
} |
||||||
|
|
||||||
|
# SHA1Update -- |
||||||
|
# |
||||||
|
# This is called to add more data into the hash. You may call this |
||||||
|
# as many times as you require. Note that passing in "ABC" is equivalent |
||||||
|
# to passing these letters in as separate calls -- hence this proc |
||||||
|
# permits hashing of chunked data |
||||||
|
# |
||||||
|
# If we have a C-based implementation available, then we will use |
||||||
|
# it here in preference to the pure-Tcl implementation. |
||||||
|
# |
||||||
|
proc ::sha1::SHA1Update {token data} { |
||||||
|
variable active |
||||||
|
upvar #0 $token state |
||||||
|
|
||||||
|
if {$active(critcl)} { |
||||||
|
if {[info exists state(sha1c)]} { |
||||||
|
set state(sha1c) [sha1c $data $state(sha1c)] |
||||||
|
} else { |
||||||
|
set state(sha1c) [sha1c $data] |
||||||
|
} |
||||||
|
return |
||||||
|
} elseif {[info exists state(ckctx)]} { |
||||||
|
if {[string length $data] > 0} { |
||||||
|
cryptkit::cryptEncrypt $state(ckctx) $data |
||||||
|
} |
||||||
|
return |
||||||
|
} elseif {[info exists state(trf)]} { |
||||||
|
puts -nonewline $state(trf) $data |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# Update the state values |
||||||
|
incr state(n) [string length $data] |
||||||
|
append state(i) $data |
||||||
|
|
||||||
|
# Calculate the hash for any complete blocks |
||||||
|
set len [string length $state(i)] |
||||||
|
for {set n 0} {($n + 64) <= $len} {} { |
||||||
|
SHA1Transform $token [string range $state(i) $n [incr n 64]] |
||||||
|
} |
||||||
|
|
||||||
|
# Adjust the state for the blocks completed. |
||||||
|
set state(i) [string range $state(i) $n end] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# SHA1Final -- |
||||||
|
# |
||||||
|
# This procedure is used to close the current hash and returns the |
||||||
|
# hash data. Once this procedure has been called the hash context |
||||||
|
# is freed and cannot be used again. |
||||||
|
# |
||||||
|
# Note that the output is 160 bits represented as binary data. |
||||||
|
# |
||||||
|
proc ::sha1::SHA1Final {token} { |
||||||
|
upvar #0 $token state |
||||||
|
|
||||||
|
# Check for either of the C-compiled versions. |
||||||
|
if {[info exists state(sha1c)]} { |
||||||
|
set r $state(sha1c) |
||||||
|
unset state |
||||||
|
return $r |
||||||
|
} elseif {[info exists state(ckctx)]} { |
||||||
|
cryptkit::cryptEncrypt $state(ckctx) "" |
||||||
|
cryptkit::cryptGetAttributeString $state(ckctx) \ |
||||||
|
CRYPT_CTXINFO_HASHVALUE r 20 |
||||||
|
cryptkit::cryptDestroyContext $state(ckctx) |
||||||
|
# If nothing was hashed, we get no r variable set! |
||||||
|
if {[info exists r]} { |
||||||
|
unset state |
||||||
|
return $r |
||||||
|
} |
||||||
|
} elseif {[info exists state(trf)]} { |
||||||
|
close $state(trf) |
||||||
|
set r $state(trfwrite) |
||||||
|
unset state |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# Padding |
||||||
|
# |
||||||
|
set len [string length $state(i)] |
||||||
|
set pad [expr {56 - ($len % 64)}] |
||||||
|
if {$len % 64 > 56} { |
||||||
|
incr pad 64 |
||||||
|
} |
||||||
|
if {$pad == 0} { |
||||||
|
incr pad 64 |
||||||
|
} |
||||||
|
append state(i) [binary format a$pad \x80] |
||||||
|
|
||||||
|
# Append length in bits as big-endian wide int. |
||||||
|
set dlen [expr {8 * $state(n)}] |
||||||
|
append state(i) [binary format II 0 $dlen] |
||||||
|
|
||||||
|
# Calculate the hash for the remaining block. |
||||||
|
set len [string length $state(i)] |
||||||
|
for {set n 0} {($n + 64) <= $len} {} { |
||||||
|
SHA1Transform $token [string range $state(i) $n [incr n 64]] |
||||||
|
} |
||||||
|
|
||||||
|
# Output |
||||||
|
set r [bytes $state(A)][bytes $state(B)][bytes $state(C)][bytes $state(D)][bytes $state(E)] |
||||||
|
unset state |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# HMAC Hashed Message Authentication (RFC 2104) |
||||||
|
# |
||||||
|
# hmac = H(K xor opad, H(K xor ipad, text)) |
||||||
|
# |
||||||
|
|
||||||
|
# HMACInit -- |
||||||
|
# |
||||||
|
# This is equivalent to the SHA1Init procedure except that a key is |
||||||
|
# added into the algorithm |
||||||
|
# |
||||||
|
proc ::sha1::HMACInit {K} { |
||||||
|
|
||||||
|
# Key K is adjusted to be 64 bytes long. If K is larger, then use |
||||||
|
# the SHA1 digest of K and pad this instead. |
||||||
|
set len [string length $K] |
||||||
|
if {$len > 64} { |
||||||
|
set tok [SHA1Init] |
||||||
|
SHA1Update $tok $K |
||||||
|
set K [SHA1Final $tok] |
||||||
|
set len [string length $K] |
||||||
|
} |
||||||
|
set pad [expr {64 - $len}] |
||||||
|
append K [string repeat \0 $pad] |
||||||
|
|
||||||
|
# Cacluate the padding buffers. |
||||||
|
set Ki {} |
||||||
|
set Ko {} |
||||||
|
binary scan $K i16 Ks |
||||||
|
foreach k $Ks { |
||||||
|
append Ki [binary format i [expr {$k ^ 0x36363636}]] |
||||||
|
append Ko [binary format i [expr {$k ^ 0x5c5c5c5c}]] |
||||||
|
} |
||||||
|
|
||||||
|
set tok [SHA1Init] |
||||||
|
SHA1Update $tok $Ki; # initialize with the inner pad |
||||||
|
|
||||||
|
# preserve the Ko value for the final stage. |
||||||
|
# FRINK: nocheck |
||||||
|
set [subst $tok](Ko) $Ko |
||||||
|
|
||||||
|
return $tok |
||||||
|
} |
||||||
|
|
||||||
|
# HMACUpdate -- |
||||||
|
# |
||||||
|
# Identical to calling SHA1Update |
||||||
|
# |
||||||
|
proc ::sha1::HMACUpdate {token data} { |
||||||
|
SHA1Update $token $data |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# HMACFinal -- |
||||||
|
# |
||||||
|
# This is equivalent to the SHA1Final procedure. The hash context is |
||||||
|
# closed and the binary representation of the hash result is returned. |
||||||
|
# |
||||||
|
proc ::sha1::HMACFinal {token} { |
||||||
|
upvar #0 $token state |
||||||
|
|
||||||
|
set tok [SHA1Init]; # init the outer hashing function |
||||||
|
SHA1Update $tok $state(Ko); # prepare with the outer pad. |
||||||
|
SHA1Update $tok [SHA1Final $token]; # hash the inner result |
||||||
|
return [SHA1Final $tok] |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# Description: |
||||||
|
# This is the core SHA1 algorithm. It is a lot like the MD4 algorithm but |
||||||
|
# includes an extra round and a set of constant modifiers throughout. |
||||||
|
# |
||||||
|
set ::sha1::SHA1Transform_body { |
||||||
|
upvar #0 $token state |
||||||
|
|
||||||
|
# FIPS 180-1: 7a: Process Message in 16-Word Blocks |
||||||
|
binary scan $msg I* blocks |
||||||
|
set blockLen [llength $blocks] |
||||||
|
for {set i 0} {$i < $blockLen} {incr i 16} { |
||||||
|
set W [lrange $blocks $i [expr {$i+15}]] |
||||||
|
|
||||||
|
# FIPS 180-1: 7b: Expand the input into 80 words |
||||||
|
# For t = 16 to 79 |
||||||
|
# let Wt = (Wt-3 ^ Wt-8 ^ Wt-14 ^ Wt-16) <<< 1 |
||||||
|
set t3 12 |
||||||
|
set t8 7 |
||||||
|
set t14 1 |
||||||
|
set t16 -1 |
||||||
|
for {set t 16} {$t < 80} {incr t} { |
||||||
|
set x [expr {[lindex $W [incr t3]] ^ [lindex $W [incr t8]] ^ \ |
||||||
|
[lindex $W [incr t14]] ^ [lindex $W [incr t16]]}] |
||||||
|
lappend W [expr {int(($x << 1) | (($x >> 31) & 1))}] |
||||||
|
} |
||||||
|
|
||||||
|
# FIPS 180-1: 7c: Copy hash state. |
||||||
|
set A $state(A) |
||||||
|
set B $state(B) |
||||||
|
set C $state(C) |
||||||
|
set D $state(D) |
||||||
|
set E $state(E) |
||||||
|
|
||||||
|
# FIPS 180-1: 7d: Do permutation rounds |
||||||
|
# For t = 0 to 79 do |
||||||
|
# TEMP = (A<<<5) + ft(B,C,D) + E + Wt + Kt; |
||||||
|
# E = D; D = C; C = S30(B); B = A; A = TEMP; |
||||||
|
|
||||||
|
# Round 1: ft(B,C,D) = (B & C) | (~B & D) ( 0 <= t <= 19) |
||||||
|
for {set t 0} {$t < 20} {incr t} { |
||||||
|
set TEMP [F1 $A $B $C $D $E [lindex $W $t]] |
||||||
|
set E $D |
||||||
|
set D $C |
||||||
|
set C [rotl32 $B 30] |
||||||
|
set B $A |
||||||
|
set A $TEMP |
||||||
|
} |
||||||
|
|
||||||
|
# Round 2: ft(B,C,D) = (B ^ C ^ D) ( 20 <= t <= 39) |
||||||
|
for {} {$t < 40} {incr t} { |
||||||
|
set TEMP [F2 $A $B $C $D $E [lindex $W $t]] |
||||||
|
set E $D |
||||||
|
set D $C |
||||||
|
set C [rotl32 $B 30] |
||||||
|
set B $A |
||||||
|
set A $TEMP |
||||||
|
} |
||||||
|
|
||||||
|
# Round 3: ft(B,C,D) = ((B & C) | (B & D) | (C & D)) ( 40 <= t <= 59) |
||||||
|
for {} {$t < 60} {incr t} { |
||||||
|
set TEMP [F3 $A $B $C $D $E [lindex $W $t]] |
||||||
|
set E $D |
||||||
|
set D $C |
||||||
|
set C [rotl32 $B 30] |
||||||
|
set B $A |
||||||
|
set A $TEMP |
||||||
|
} |
||||||
|
|
||||||
|
# Round 4: ft(B,C,D) = (B ^ C ^ D) ( 60 <= t <= 79) |
||||||
|
for {} {$t < 80} {incr t} { |
||||||
|
set TEMP [F4 $A $B $C $D $E [lindex $W $t]] |
||||||
|
set E $D |
||||||
|
set D $C |
||||||
|
set C [rotl32 $B 30] |
||||||
|
set B $A |
||||||
|
set A $TEMP |
||||||
|
} |
||||||
|
|
||||||
|
# Then perform the following additions. (That is, increment each |
||||||
|
# of the four registers by the value it had before this block |
||||||
|
# was started.) |
||||||
|
incr state(A) $A |
||||||
|
incr state(B) $B |
||||||
|
incr state(C) $C |
||||||
|
incr state(D) $D |
||||||
|
incr state(E) $E |
||||||
|
} |
||||||
|
|
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::sha1::F1 {A B C D E W} { |
||||||
|
expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \ |
||||||
|
+ ($D ^ ($B & ($C ^ $D))) + $E + $W + 0x5a827999) & 0xffffffff} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::sha1::F2 {A B C D E W} { |
||||||
|
expr {(((($A << 5) & 0xffffffff) | (($A >> 27) & 0x1f)) \ |
||||||
|
+ ($B ^ $C ^ $D) + $E + $W + 0x6ed9eba1) & 0xffffffff} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::sha1::F3 {A B C D E W} { |
||||||
|
expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \ |
||||||
|
+ (($B & $C) | ($D & ($B | $C))) + $E + $W + 0x8f1bbcdc) & 0xffffffff} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::sha1::F4 {A B C D E W} { |
||||||
|
expr {(((($A << 5) & 0xffffffff)| (($A >> 27) & 0x1f)) \ |
||||||
|
+ ($B ^ $C ^ $D) + $E + $W + 0xca62c1d6) & 0xffffffff} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::sha1::rotl32 {v n} { |
||||||
|
return [expr {((($v << $n) \ |
||||||
|
| (($v >> (32 - $n)) \ |
||||||
|
& (0x7FFFFFFF >> (31 - $n))))) \ |
||||||
|
& 0xFFFFFFFF}] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# |
||||||
|
# In order to get this code to go as fast as possible while leaving |
||||||
|
# the main code readable we can substitute the above function bodies |
||||||
|
# into the transform procedure. This inlines the code for us an avoids |
||||||
|
# a procedure call overhead within the loops. |
||||||
|
# |
||||||
|
# We can do some minor tweaking to improve speed on Tcl < 8.5 where we |
||||||
|
# know our arithmetic is limited to 64 bits. On > 8.5 we may have |
||||||
|
# unconstrained integer arithmetic and must avoid letting it run away. |
||||||
|
# |
||||||
|
|
||||||
|
regsub -all -line \ |
||||||
|
{\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
||||||
|
$::sha1::SHA1Transform_body \ |
||||||
|
{[expr {(rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999) \& 0xffffffff}]} \ |
||||||
|
::sha1::SHA1Transform_body_tmp |
||||||
|
|
||||||
|
regsub -all -line \ |
||||||
|
{\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
||||||
|
$::sha1::SHA1Transform_body_tmp \ |
||||||
|
{[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1) \& 0xffffffff}]} \ |
||||||
|
::sha1::SHA1Transform_body_tmp |
||||||
|
|
||||||
|
regsub -all -line \ |
||||||
|
{\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
||||||
|
$::sha1::SHA1Transform_body_tmp \ |
||||||
|
{[expr {(rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc) \& 0xffffffff}]} \ |
||||||
|
::sha1::SHA1Transform_body_tmp |
||||||
|
|
||||||
|
regsub -all -line \ |
||||||
|
{\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
||||||
|
$::sha1::SHA1Transform_body_tmp \ |
||||||
|
{[expr {(rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6) \& 0xffffffff}]} \ |
||||||
|
::sha1::SHA1Transform_body_tmp |
||||||
|
|
||||||
|
regsub -all -line \ |
||||||
|
{rotl32\(\$A,5\)} \ |
||||||
|
$::sha1::SHA1Transform_body_tmp \ |
||||||
|
{((($A << 5) \& 0xffffffff) | (($A >> 27) \& 0x1f))} \ |
||||||
|
::sha1::SHA1Transform_body_tmp |
||||||
|
|
||||||
|
regsub -all -line \ |
||||||
|
{\[rotl32 \$B 30\]} \ |
||||||
|
$::sha1::SHA1Transform_body_tmp \ |
||||||
|
{[expr {int(($B << 30) | (($B >> 2) \& 0x3fffffff))}]} \ |
||||||
|
::sha1::SHA1Transform_body_tmp |
||||||
|
# |
||||||
|
# Version 2 avoids a few truncations to 32 bits in non-essential places. |
||||||
|
# |
||||||
|
regsub -all -line \ |
||||||
|
{\[F1 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
||||||
|
$::sha1::SHA1Transform_body \ |
||||||
|
{[expr {rotl32($A,5) + ($D ^ ($B \& ($C ^ $D))) + $E + \1 + 0x5a827999}]} \ |
||||||
|
::sha1::SHA1Transform_body_tmp2 |
||||||
|
|
||||||
|
regsub -all -line \ |
||||||
|
{\[F2 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
||||||
|
$::sha1::SHA1Transform_body_tmp2 \ |
||||||
|
{[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0x6ed9eba1}]} \ |
||||||
|
::sha1::SHA1Transform_body_tmp2 |
||||||
|
|
||||||
|
regsub -all -line \ |
||||||
|
{\[F3 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
||||||
|
$::sha1::SHA1Transform_body_tmp2 \ |
||||||
|
{[expr {rotl32($A,5) + (($B \& $C) | ($D \& ($B | $C))) + $E + \1 + 0x8f1bbcdc}]} \ |
||||||
|
::sha1::SHA1Transform_body_tmp2 |
||||||
|
|
||||||
|
regsub -all -line \ |
||||||
|
{\[F4 \$A \$B \$C \$D \$E (\[.*?\])\]} \ |
||||||
|
$::sha1::SHA1Transform_body_tmp2 \ |
||||||
|
{[expr {rotl32($A,5) + ($B ^ $C ^ $D) + $E + \1 + 0xca62c1d6}]} \ |
||||||
|
::sha1::SHA1Transform_body_tmp2 |
||||||
|
|
||||||
|
regsub -all -line \ |
||||||
|
{rotl32\(\$A,5\)} \ |
||||||
|
$::sha1::SHA1Transform_body_tmp2 \ |
||||||
|
{(($A << 5) | (($A >> 27) \& 0x1f))} \ |
||||||
|
::sha1::SHA1Transform_body_tmp2 |
||||||
|
|
||||||
|
regsub -all -line \ |
||||||
|
{\[rotl32 \$B 30\]} \ |
||||||
|
$::sha1::SHA1Transform_body_tmp2 \ |
||||||
|
{[expr {($B << 30) | (($B >> 2) \& 0x3fffffff)}]} \ |
||||||
|
::sha1::SHA1Transform_body_tmp2 |
||||||
|
|
||||||
|
if {[package vsatisfies [package provide Tcl] 8.5]} { |
||||||
|
proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp |
||||||
|
} else { |
||||||
|
proc ::sha1::SHA1Transform {token msg} $::sha1::SHA1Transform_body_tmp2 |
||||||
|
} |
||||||
|
|
||||||
|
unset ::sha1::SHA1Transform_body |
||||||
|
unset ::sha1::SHA1Transform_body_tmp |
||||||
|
unset ::sha1::SHA1Transform_body_tmp2 |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
proc ::sha1::byte {n v} {expr {((0xFF << (8 * $n)) & $v) >> (8 * $n)}} |
||||||
|
proc ::sha1::bytes {v} { |
||||||
|
#format %c%c%c%c [byte 0 $v] [byte 1 $v] [byte 2 $v] [byte 3 $v] |
||||||
|
format %c%c%c%c \ |
||||||
|
[expr {((0xFF000000 & $v) >> 24) & 0xFF}] \ |
||||||
|
[expr {(0xFF0000 & $v) >> 16}] \ |
||||||
|
[expr {(0xFF00 & $v) >> 8}] \ |
||||||
|
[expr {0xFF & $v}] |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
proc ::sha1::Hex {data} { |
||||||
|
binary scan $data H* result |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# Description: |
||||||
|
# Pop the nth element off a list. Used in options processing. |
||||||
|
# |
||||||
|
proc ::sha1::Pop {varname {nth 0}} { |
||||||
|
upvar $varname args |
||||||
|
set r [lindex $args $nth] |
||||||
|
set args [lreplace $args $nth $nth] |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# fileevent handler for chunked file hashing. |
||||||
|
# |
||||||
|
proc ::sha1::Chunk {token channel {chunksize 4096}} { |
||||||
|
upvar #0 $token state |
||||||
|
|
||||||
|
SHA1Update $token [read $channel $chunksize] |
||||||
|
|
||||||
|
if {[eof $channel]} { |
||||||
|
fileevent $channel readable {} |
||||||
|
set state(reading) 0 |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
proc ::sha1::sha1 {args} { |
||||||
|
array set opts {-hex 0 -filename {} -channel {} -chunksize 4096} |
||||||
|
if {[llength $args] == 1} { |
||||||
|
set opts(-hex) 1 |
||||||
|
} else { |
||||||
|
while {[string match -* [set option [lindex $args 0]]]} { |
||||||
|
switch -glob -- $option { |
||||||
|
-hex { set opts(-hex) 1 } |
||||||
|
-bin { set opts(-hex) 0 } |
||||||
|
-file* { set opts(-filename) [Pop args 1] } |
||||||
|
-channel { set opts(-channel) [Pop args 1] } |
||||||
|
-chunksize { set opts(-chunksize) [Pop args 1] } |
||||||
|
default { |
||||||
|
if {[llength $args] == 1} { break } |
||||||
|
if {[string compare $option "--"] == 0} { Pop args; break } |
||||||
|
set err [join [lsort [concat -bin [array names opts]]] ", "] |
||||||
|
return -code error "bad option $option:\ |
||||||
|
must be one of $err" |
||||||
|
} |
||||||
|
} |
||||||
|
Pop args |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-filename) != {}} { |
||||||
|
set opts(-channel) [open $opts(-filename) r] |
||||||
|
fconfigure $opts(-channel) -translation binary |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-channel) == {}} { |
||||||
|
|
||||||
|
if {[llength $args] != 1} { |
||||||
|
return -code error "wrong # args:\ |
||||||
|
should be \"sha1 ?-hex? -filename file | string\"" |
||||||
|
} |
||||||
|
set tok [SHA1Init] |
||||||
|
SHA1Update $tok [lindex $args 0] |
||||||
|
set r [SHA1Final $tok] |
||||||
|
|
||||||
|
} else { |
||||||
|
|
||||||
|
set tok [SHA1Init] |
||||||
|
# FRINK: nocheck |
||||||
|
set [subst $tok](reading) 1 |
||||||
|
fileevent $opts(-channel) readable \ |
||||||
|
[list [namespace origin Chunk] \ |
||||||
|
$tok $opts(-channel) $opts(-chunksize)] |
||||||
|
# FRINK: nocheck |
||||||
|
vwait [subst $tok](reading) |
||||||
|
set r [SHA1Final $tok] |
||||||
|
|
||||||
|
# If we opened the channel - we should close it too. |
||||||
|
if {$opts(-filename) != {}} { |
||||||
|
close $opts(-channel) |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-hex)} { |
||||||
|
set r [Hex $r] |
||||||
|
} |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
proc ::sha1::hmac {args} { |
||||||
|
array set opts {-hex 1 -filename {} -channel {} -chunksize 4096} |
||||||
|
if {[llength $args] != 2} { |
||||||
|
while {[string match -* [set option [lindex $args 0]]]} { |
||||||
|
switch -glob -- $option { |
||||||
|
-key { set opts(-key) [Pop args 1] } |
||||||
|
-hex { set opts(-hex) 1 } |
||||||
|
-bin { set opts(-hex) 0 } |
||||||
|
-file* { set opts(-filename) [Pop args 1] } |
||||||
|
-channel { set opts(-channel) [Pop args 1] } |
||||||
|
-chunksize { set opts(-chunksize) [Pop args 1] } |
||||||
|
default { |
||||||
|
if {[llength $args] == 1} { break } |
||||||
|
if {[string compare $option "--"] == 0} { Pop args; break } |
||||||
|
set err [join [lsort [array names opts]] ", "] |
||||||
|
return -code error "bad option $option:\ |
||||||
|
must be one of $err" |
||||||
|
} |
||||||
|
} |
||||||
|
Pop args |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength $args] == 2} { |
||||||
|
set opts(-key) [Pop args] |
||||||
|
} |
||||||
|
|
||||||
|
if {![info exists opts(-key)]} { |
||||||
|
return -code error "wrong # args:\ |
||||||
|
should be \"hmac ?-hex? -key key -filename file | string\"" |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-filename) != {}} { |
||||||
|
set opts(-channel) [open $opts(-filename) r] |
||||||
|
fconfigure $opts(-channel) -translation binary |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-channel) == {}} { |
||||||
|
|
||||||
|
if {[llength $args] != 1} { |
||||||
|
return -code error "wrong # args:\ |
||||||
|
should be \"hmac ?-hex? -key key -filename file | string\"" |
||||||
|
} |
||||||
|
set tok [HMACInit $opts(-key)] |
||||||
|
HMACUpdate $tok [lindex $args 0] |
||||||
|
set r [HMACFinal $tok] |
||||||
|
|
||||||
|
} else { |
||||||
|
|
||||||
|
set tok [HMACInit $opts(-key)] |
||||||
|
# FRINK: nocheck |
||||||
|
set [subst $tok](reading) 1 |
||||||
|
fileevent $opts(-channel) readable \ |
||||||
|
[list [namespace origin Chunk] \ |
||||||
|
$tok $opts(-channel) $opts(-chunksize)] |
||||||
|
# FRINK: nocheck |
||||||
|
vwait [subst $tok](reading) |
||||||
|
set r [HMACFinal $tok] |
||||||
|
|
||||||
|
# If we opened the channel - we should close it too. |
||||||
|
if {$opts(-filename) != {}} { |
||||||
|
close $opts(-channel) |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$opts(-hex)} { |
||||||
|
set r [Hex $r] |
||||||
|
} |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
|
||||||
|
# Try and load a compiled extension to help. |
||||||
|
namespace eval ::sha1 { |
||||||
|
variable e {} |
||||||
|
foreach e [KnownImplementations] { |
||||||
|
if {[LoadAccelerator $e]} { |
||||||
|
SwitchTo $e |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
unset e |
||||||
|
} |
||||||
|
|
||||||
|
package provide sha1 2.0.4 |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# Local Variables: |
||||||
|
# mode: tcl |
||||||
|
# indent-tabs-mode: nil |
||||||
|
# End: |
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,189 @@ |
|||||||
|
#---------------------------------------------------------------------- |
||||||
|
# |
||||||
|
# sets.tcl -- |
||||||
|
# |
||||||
|
# Definitions for the processing of sets. |
||||||
|
# |
||||||
|
# Copyright (c) 2004-2008 by Andreas Kupries. |
||||||
|
# |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ |
||||||
|
# |
||||||
|
#---------------------------------------------------------------------- |
||||||
|
|
||||||
|
# @mdgen EXCLUDE: sets_c.tcl |
||||||
|
|
||||||
|
package require Tcl 8.5- |
||||||
|
|
||||||
|
namespace eval ::struct::set {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Management of set implementations. |
||||||
|
|
||||||
|
# ::struct::set::LoadAccelerator -- |
||||||
|
# |
||||||
|
# Loads a named implementation, if possible. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# key Name of the implementation to load. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A boolean flag. True if the implementation |
||||||
|
# was successfully loaded; and False otherwise. |
||||||
|
|
||||||
|
proc ::struct::set::LoadAccelerator {key} { |
||||||
|
variable accel |
||||||
|
set r 0 |
||||||
|
switch -exact -- $key { |
||||||
|
critcl { |
||||||
|
# Critcl implementation of set requires Tcl 8.4. |
||||||
|
if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} |
||||||
|
if {[catch {package require tcllibc}]} {return 0} |
||||||
|
set r [llength [info commands ::struct::set_critcl]] |
||||||
|
} |
||||||
|
tcl { |
||||||
|
variable selfdir |
||||||
|
source [file join $selfdir sets_tcl.tcl] |
||||||
|
set r 1 |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "invalid accelerator/impl. package $key:\ |
||||||
|
must be one of [join [KnownImplementations] {, }]" |
||||||
|
} |
||||||
|
} |
||||||
|
set accel($key) $r |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::SwitchTo -- |
||||||
|
# |
||||||
|
# Activates a loaded named implementation. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# key Name of the implementation to activate. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::struct::set::SwitchTo {key} { |
||||||
|
variable accel |
||||||
|
variable loaded |
||||||
|
|
||||||
|
if {[string equal $key $loaded]} { |
||||||
|
# No change, nothing to do. |
||||||
|
return |
||||||
|
} elseif {![string equal $key ""]} { |
||||||
|
# Validate the target implementation of the switch. |
||||||
|
|
||||||
|
if {![info exists accel($key)]} { |
||||||
|
return -code error "Unable to activate unknown implementation \"$key\"" |
||||||
|
} elseif {![info exists accel($key)] || !$accel($key)} { |
||||||
|
return -code error "Unable to activate missing implementation \"$key\"" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Deactivate the previous implementation, if there was any. |
||||||
|
|
||||||
|
if {![string equal $loaded ""]} { |
||||||
|
rename ::struct::set ::struct::set_$loaded |
||||||
|
} |
||||||
|
|
||||||
|
# Activate the new implementation, if there is any. |
||||||
|
|
||||||
|
if {![string equal $key ""]} { |
||||||
|
rename ::struct::set_$key ::struct::set |
||||||
|
} |
||||||
|
|
||||||
|
# Remember the active implementation, for deactivation by future |
||||||
|
# switches. |
||||||
|
|
||||||
|
set loaded $key |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::struct::set::Loaded {} { |
||||||
|
variable loaded |
||||||
|
return $loaded |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::Implementations -- |
||||||
|
# |
||||||
|
# Determines which implementations are |
||||||
|
# present, i.e. loaded. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# None. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A list of implementation keys. |
||||||
|
|
||||||
|
proc ::struct::set::Implementations {} { |
||||||
|
variable accel |
||||||
|
set res {} |
||||||
|
foreach n [array names accel] { |
||||||
|
if {!$accel($n)} continue |
||||||
|
lappend res $n |
||||||
|
} |
||||||
|
return $res |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::KnownImplementations -- |
||||||
|
# |
||||||
|
# Determines which implementations are known |
||||||
|
# as possible implementations. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# None. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A list of implementation keys. In the order |
||||||
|
# of preference, most prefered first. |
||||||
|
|
||||||
|
proc ::struct::set::KnownImplementations {} { |
||||||
|
return {critcl tcl} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::struct::set::Names {} { |
||||||
|
return { |
||||||
|
critcl {tcllibc based} |
||||||
|
tcl {pure Tcl} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Initialization: Data structures. |
||||||
|
|
||||||
|
namespace eval ::struct::set { |
||||||
|
variable selfdir [file dirname [info script]] |
||||||
|
variable accel |
||||||
|
array set accel {tcl 0 critcl 0} |
||||||
|
variable loaded {} |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Initialization: Choose an implementation, |
||||||
|
## most prefered first. Loads only one of the |
||||||
|
## possible implementations. And activates it. |
||||||
|
|
||||||
|
namespace eval ::struct::set { |
||||||
|
variable e |
||||||
|
foreach e [KnownImplementations] { |
||||||
|
if {[LoadAccelerator $e]} { |
||||||
|
SwitchTo $e |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
unset e |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
namespace eval ::struct { |
||||||
|
# Export the constructor command. |
||||||
|
namespace export set |
||||||
|
} |
||||||
|
|
||||||
|
package provide struct::set 2.2.3 |
||||||
@ -0,0 +1,189 @@ |
|||||||
|
#---------------------------------------------------------------------- |
||||||
|
# |
||||||
|
# sets.tcl -- |
||||||
|
# |
||||||
|
# Definitions for the processing of sets. |
||||||
|
# |
||||||
|
# Copyright (c) 2004-2008 by Andreas Kupries. |
||||||
|
# |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ |
||||||
|
# |
||||||
|
#---------------------------------------------------------------------- |
||||||
|
|
||||||
|
# @mdgen EXCLUDE: sets_c.tcl |
||||||
|
|
||||||
|
package require Tcl 8.5- |
||||||
|
|
||||||
|
namespace eval ::struct::set {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Management of set implementations. |
||||||
|
|
||||||
|
# ::struct::set::LoadAccelerator -- |
||||||
|
# |
||||||
|
# Loads a named implementation, if possible. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# key Name of the implementation to load. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A boolean flag. True if the implementation |
||||||
|
# was successfully loaded; and False otherwise. |
||||||
|
|
||||||
|
proc ::struct::set::LoadAccelerator {key} { |
||||||
|
variable accel |
||||||
|
set r 0 |
||||||
|
switch -exact -- $key { |
||||||
|
critcl { |
||||||
|
# Critcl implementation of set requires Tcl 8.4. |
||||||
|
if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} |
||||||
|
if {[catch {package require tcllibc}]} {return 0} |
||||||
|
set r [llength [info commands ::struct::set_critcl]] |
||||||
|
} |
||||||
|
tcl { |
||||||
|
variable selfdir |
||||||
|
source [file join $selfdir sets_tcl.tcl] |
||||||
|
set r 1 |
||||||
|
} |
||||||
|
default { |
||||||
|
return -code error "invalid accelerator/impl. package $key:\ |
||||||
|
must be one of [join [KnownImplementations] {, }]" |
||||||
|
} |
||||||
|
} |
||||||
|
set accel($key) $r |
||||||
|
return $r |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::SwitchTo -- |
||||||
|
# |
||||||
|
# Activates a loaded named implementation. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# key Name of the implementation to activate. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::struct::set::SwitchTo {key} { |
||||||
|
variable accel |
||||||
|
variable loaded |
||||||
|
|
||||||
|
if {[string equal $key $loaded]} { |
||||||
|
# No change, nothing to do. |
||||||
|
return |
||||||
|
} elseif {![string equal $key ""]} { |
||||||
|
# Validate the target implementation of the switch. |
||||||
|
|
||||||
|
if {![info exists accel($key)]} { |
||||||
|
return -code error "Unable to activate unknown implementation \"$key\"" |
||||||
|
} elseif {![info exists accel($key)] || !$accel($key)} { |
||||||
|
return -code error "Unable to activate missing implementation \"$key\"" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Deactivate the previous implementation, if there was any. |
||||||
|
|
||||||
|
if {![string equal $loaded ""]} { |
||||||
|
rename ::struct::set ::struct::set_$loaded |
||||||
|
} |
||||||
|
|
||||||
|
# Activate the new implementation, if there is any. |
||||||
|
|
||||||
|
if {![string equal $key ""]} { |
||||||
|
rename ::struct::set_$key ::struct::set |
||||||
|
} |
||||||
|
|
||||||
|
# Remember the active implementation, for deactivation by future |
||||||
|
# switches. |
||||||
|
|
||||||
|
set loaded $key |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc ::struct::set::Loaded {} { |
||||||
|
variable loaded |
||||||
|
return $loaded |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::Implementations -- |
||||||
|
# |
||||||
|
# Determines which implementations are |
||||||
|
# present, i.e. loaded. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# None. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A list of implementation keys. |
||||||
|
|
||||||
|
proc ::struct::set::Implementations {} { |
||||||
|
variable accel |
||||||
|
set res {} |
||||||
|
foreach n [array names accel] { |
||||||
|
if {!$accel($n)} continue |
||||||
|
lappend res $n |
||||||
|
} |
||||||
|
return $res |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::KnownImplementations -- |
||||||
|
# |
||||||
|
# Determines which implementations are known |
||||||
|
# as possible implementations. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# None. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A list of implementation keys. In the order |
||||||
|
# of preference, most prefered first. |
||||||
|
|
||||||
|
proc ::struct::set::KnownImplementations {} { |
||||||
|
return {critcl tcl} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::struct::set::Names {} { |
||||||
|
return { |
||||||
|
critcl {tcllibc based} |
||||||
|
tcl {pure Tcl} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Initialization: Data structures. |
||||||
|
|
||||||
|
namespace eval ::struct::set { |
||||||
|
variable selfdir [file dirname [info script]] |
||||||
|
variable accel |
||||||
|
array set accel {tcl 0 critcl 0} |
||||||
|
variable loaded {} |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Initialization: Choose an implementation, |
||||||
|
## most prefered first. Loads only one of the |
||||||
|
## possible implementations. And activates it. |
||||||
|
|
||||||
|
namespace eval ::struct::set { |
||||||
|
variable e |
||||||
|
foreach e [KnownImplementations] { |
||||||
|
if {[LoadAccelerator $e]} { |
||||||
|
SwitchTo $e |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
unset e |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
namespace eval ::struct { |
||||||
|
# Export the constructor command. |
||||||
|
namespace export set |
||||||
|
} |
||||||
|
|
||||||
|
package provide struct::set 2.2.3 |
||||||
@ -0,0 +1,93 @@ |
|||||||
|
#---------------------------------------------------------------------- |
||||||
|
# |
||||||
|
# sets_tcl.tcl -- |
||||||
|
# |
||||||
|
# Definitions for the processing of sets. C implementation. |
||||||
|
# |
||||||
|
# Copyright (c) 2007 by Andreas Kupries. |
||||||
|
# |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: sets_c.tcl,v 1.3 2008/03/25 07:15:34 andreas_kupries Exp $ |
||||||
|
# |
||||||
|
#---------------------------------------------------------------------- |
||||||
|
|
||||||
|
package require critcl |
||||||
|
# @sak notprovided struct_setc |
||||||
|
package provide struct_setc 2.1.1 |
||||||
|
package require Tcl 8.5- |
||||||
|
|
||||||
|
namespace eval ::struct { |
||||||
|
# Supporting code for the main command. |
||||||
|
|
||||||
|
catch { |
||||||
|
#critcl::cheaders -g |
||||||
|
#critcl::debug memory symbols |
||||||
|
} |
||||||
|
|
||||||
|
critcl::cheaders sets/*.h |
||||||
|
critcl::csources sets/*.c |
||||||
|
|
||||||
|
critcl::ccode { |
||||||
|
/* -*- c -*- */ |
||||||
|
|
||||||
|
#include <m.h> |
||||||
|
} |
||||||
|
|
||||||
|
# Main command, set creation. |
||||||
|
|
||||||
|
critcl::ccommand set_critcl {dummy interp objc objv} { |
||||||
|
/* Syntax - dispatcher to the sub commands. |
||||||
|
*/ |
||||||
|
|
||||||
|
static CONST char* methods [] = { |
||||||
|
"add", "contains", "difference", "empty", |
||||||
|
"equal","exclude", "include", "intersect", |
||||||
|
"intersect3", "size", "subsetof", "subtract", |
||||||
|
"symdiff", "union", |
||||||
|
NULL |
||||||
|
}; |
||||||
|
enum methods { |
||||||
|
S_add, S_contains, S_difference, S_empty, |
||||||
|
S_equal,S_exclude, S_include, S_intersect, |
||||||
|
S_intersect3, S_size, S_subsetof, S_subtract, |
||||||
|
S_symdiff, S_union |
||||||
|
}; |
||||||
|
|
||||||
|
int m; |
||||||
|
|
||||||
|
if (objc < 2) { |
||||||
|
Tcl_WrongNumArgs (interp, objc, objv, "cmd ?arg ...?"); |
||||||
|
return TCL_ERROR; |
||||||
|
} else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", |
||||||
|
0, &m) != TCL_OK) { |
||||||
|
return TCL_ERROR; |
||||||
|
} |
||||||
|
|
||||||
|
/* Dispatch to methods. They check the #args in detail before performing |
||||||
|
* the requested functionality |
||||||
|
*/ |
||||||
|
|
||||||
|
switch (m) { |
||||||
|
case S_add: return sm_ADD (NULL, interp, objc, objv); |
||||||
|
case S_contains: return sm_CONTAINS (NULL, interp, objc, objv); |
||||||
|
case S_difference: return sm_DIFFERENCE (NULL, interp, objc, objv); |
||||||
|
case S_empty: return sm_EMPTY (NULL, interp, objc, objv); |
||||||
|
case S_equal: return sm_EQUAL (NULL, interp, objc, objv); |
||||||
|
case S_exclude: return sm_EXCLUDE (NULL, interp, objc, objv); |
||||||
|
case S_include: return sm_INCLUDE (NULL, interp, objc, objv); |
||||||
|
case S_intersect: return sm_INTERSECT (NULL, interp, objc, objv); |
||||||
|
case S_intersect3: return sm_INTERSECT3 (NULL, interp, objc, objv); |
||||||
|
case S_size: return sm_SIZE (NULL, interp, objc, objv); |
||||||
|
case S_subsetof: return sm_SUBSETOF (NULL, interp, objc, objv); |
||||||
|
case S_subtract: return sm_SUBTRACT (NULL, interp, objc, objv); |
||||||
|
case S_symdiff: return sm_SYMDIFF (NULL, interp, objc, objv); |
||||||
|
case S_union: return sm_UNION (NULL, interp, objc, objv); |
||||||
|
} |
||||||
|
/* Not coming to this place */ |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
@ -0,0 +1,452 @@ |
|||||||
|
#---------------------------------------------------------------------- |
||||||
|
# |
||||||
|
# sets_tcl.tcl -- |
||||||
|
# |
||||||
|
# Definitions for the processing of sets. |
||||||
|
# |
||||||
|
# Copyright (c) 2004-2008 by Andreas Kupries. |
||||||
|
# |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: sets_tcl.tcl,v 1.4 2008/03/09 04:38:47 andreas_kupries Exp $ |
||||||
|
# |
||||||
|
#---------------------------------------------------------------------- |
||||||
|
|
||||||
|
package require Tcl 8.5- |
||||||
|
|
||||||
|
namespace eval ::struct::set { |
||||||
|
# Only export one command, the one used to instantiate a new tree |
||||||
|
namespace export set_tcl |
||||||
|
} |
||||||
|
|
||||||
|
########################## |
||||||
|
# Public functions |
||||||
|
|
||||||
|
# ::struct::set::set -- |
||||||
|
# |
||||||
|
# Command that access all set commands. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# cmd Name of the subcommand to dispatch to. |
||||||
|
# args Arguments for the subcommand. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# Whatever the result of the subcommand is. |
||||||
|
|
||||||
|
proc ::struct::set::set_tcl {cmd args} { |
||||||
|
# Do minimal args checks here |
||||||
|
if { [llength [info level 0]] == 1 } { |
||||||
|
return -code error "wrong # args: should be \"$cmd ?arg arg ...?\"" |
||||||
|
} |
||||||
|
::set sub S_$cmd |
||||||
|
if { [llength [info commands ::struct::set::$sub]] == 0 } { |
||||||
|
::set optlist [info commands ::struct::set::S_*] |
||||||
|
::set xlist {} |
||||||
|
foreach p $optlist { |
||||||
|
lappend xlist [string range $p 17 end] |
||||||
|
} |
||||||
|
return -code error \ |
||||||
|
"bad option \"$cmd\": must be [linsert [join [lsort $xlist] ", "] "end-1" "or"]" |
||||||
|
} |
||||||
|
return [uplevel 1 [linsert $args 0 ::struct::set::$sub]] |
||||||
|
} |
||||||
|
|
||||||
|
########################## |
||||||
|
# Implementations of the functionality. |
||||||
|
# |
||||||
|
|
||||||
|
# ::struct::set::S_empty -- |
||||||
|
# |
||||||
|
# Determines emptiness of the set |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# set -- The set to check for emptiness. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A boolean value. True indicates that the set is empty. |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
# None. |
||||||
|
# |
||||||
|
# Notes: |
||||||
|
|
||||||
|
proc ::struct::set::S_empty {set} { |
||||||
|
return [expr {[llength $set] == 0}] |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::S_size -- |
||||||
|
# |
||||||
|
# Computes the cardinality of the set. |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# set -- The set to inspect. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# An integer greater than or equal to zero. |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::struct::set::S_size {set} { |
||||||
|
return [llength [Cleanup $set]] |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::S_contains -- |
||||||
|
# |
||||||
|
# Determines if the item is in the set. |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# set -- The set to inspect. |
||||||
|
# item -- The element to look for. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A boolean value. True indicates that the element is present. |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::struct::set::S_contains {set item} { |
||||||
|
return [expr {[lsearch -exact $set $item] >= 0}] |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::S_union -- |
||||||
|
# |
||||||
|
# Computes the union of the arguments. |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# args -- List of sets to unify. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The union of the arguments. |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::struct::set::S_union {args} { |
||||||
|
switch -exact -- [llength $args] { |
||||||
|
0 {return {}} |
||||||
|
1 {return [lindex $args 0]} |
||||||
|
} |
||||||
|
foreach setX $args { |
||||||
|
foreach x $setX {::set ($x) {}} |
||||||
|
} |
||||||
|
return [array names {}] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ::struct::set::S_intersect -- |
||||||
|
# |
||||||
|
# Computes the intersection of the arguments. |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# args -- List of sets to intersect. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The intersection of the arguments |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::struct::set::S_intersect {args} { |
||||||
|
switch -exact -- [llength $args] { |
||||||
|
0 {return {}} |
||||||
|
1 {return [lindex $args 0]} |
||||||
|
} |
||||||
|
::set res [lindex $args 0] |
||||||
|
foreach set [lrange $args 1 end] { |
||||||
|
if {[llength $res] && [llength $set]} { |
||||||
|
::set res [Intersect $res $set] |
||||||
|
} else { |
||||||
|
# Squash 'res'. Otherwise we get the wrong result if res |
||||||
|
# is not empty, but 'set' is. |
||||||
|
::set res {} |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
return $res |
||||||
|
} |
||||||
|
|
||||||
|
proc ::struct::set::Intersect {A B} { |
||||||
|
if {[llength $A] == 0} {return {}} |
||||||
|
if {[llength $B] == 0} {return {}} |
||||||
|
|
||||||
|
# This is slower than local vars, but more robust |
||||||
|
if {[llength $B] > [llength $A]} { |
||||||
|
::set res $A |
||||||
|
::set A $B |
||||||
|
::set B $res |
||||||
|
} |
||||||
|
::set res {} |
||||||
|
foreach x $A {::set ($x) {}} |
||||||
|
foreach x $B { |
||||||
|
if {[info exists ($x)]} { |
||||||
|
lappend res $x |
||||||
|
} |
||||||
|
} |
||||||
|
return $res |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::S_difference -- |
||||||
|
# |
||||||
|
# Compute difference of two sets. |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# A, B -- Sets to compute the difference for. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A - B |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::struct::set::S_difference {A B} { |
||||||
|
if {[llength $A] == 0} {return {}} |
||||||
|
if {[llength $B] == 0} {return $A} |
||||||
|
|
||||||
|
array set tmp {} |
||||||
|
foreach x $A {::set tmp($x) .} |
||||||
|
foreach x $B {catch {unset tmp($x)}} |
||||||
|
return [array names tmp] |
||||||
|
} |
||||||
|
|
||||||
|
if {0} { |
||||||
|
# Tcllib SF Bug 1002143. We cannot use the implementation below. |
||||||
|
# It will treat set elements containing '(' and ')' as array |
||||||
|
# elements, and this screws up the storage of elements as the name |
||||||
|
# of local vars something fierce. No way around this. Disabling |
||||||
|
# this code and always using the other implementation (s.a.) is |
||||||
|
# the only possible fix. |
||||||
|
|
||||||
|
if {[package vcompare [package provide Tcl] 8.4] < 0} { |
||||||
|
# Tcl 8.[23]. Use explicit array to perform the operation. |
||||||
|
} else { |
||||||
|
# Tcl 8.4+, has 'unset -nocomplain' |
||||||
|
|
||||||
|
proc ::struct::set::S_difference {A B} { |
||||||
|
if {[llength $A] == 0} {return {}} |
||||||
|
if {[llength $B] == 0} {return $A} |
||||||
|
|
||||||
|
# Get the variable B out of the way, avoid collisions |
||||||
|
# prepare for "pure list optimization" |
||||||
|
::set ::struct::set::tmp [lreplace $B -1 -1 unset -nocomplain] |
||||||
|
unset B |
||||||
|
|
||||||
|
# unset A early: no local variables left |
||||||
|
foreach [lindex [list $A [unset A]] 0] {.} {break} |
||||||
|
|
||||||
|
eval $::struct::set::tmp |
||||||
|
return [info locals] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::S_symdiff -- |
||||||
|
# |
||||||
|
# Compute symmetric difference of two sets. |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# A, B -- The sets to compute the s.difference for. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# The symmetric difference of the two input sets. |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::struct::set::S_symdiff {A B} { |
||||||
|
# symdiff == (A-B) + (B-A) == (A+B)-(A*B) |
||||||
|
if {[llength $A] == 0} {return $B} |
||||||
|
if {[llength $B] == 0} {return $A} |
||||||
|
return [S_union \ |
||||||
|
[S_difference $A $B] \ |
||||||
|
[S_difference $B $A]] |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::S_intersect3 -- |
||||||
|
# |
||||||
|
# Return intersection and differences for two sets. |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# A, B -- The sets to inspect. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# List containing A*B, A-B, and B-A |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::struct::set::S_intersect3 {A B} { |
||||||
|
return [list \ |
||||||
|
[S_intersect $A $B] \ |
||||||
|
[S_difference $A $B] \ |
||||||
|
[S_difference $B $A]] |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::S_equal -- |
||||||
|
# |
||||||
|
# Compares two sets for equality. |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# a First set to compare. |
||||||
|
# b Second set to compare. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A boolean. True if the lists are equal. |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::struct::set::S_equal {A B} { |
||||||
|
::set A [Cleanup $A] |
||||||
|
::set B [Cleanup $B] |
||||||
|
|
||||||
|
# Equal if of same cardinality and difference is empty. |
||||||
|
|
||||||
|
if {[::llength $A] != [::llength $B]} {return 0} |
||||||
|
return [expr {[llength [S_difference $A $B]] == 0}] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::struct::set::Cleanup {A} { |
||||||
|
# unset A to avoid collisions |
||||||
|
if {[llength $A] < 2} {return $A} |
||||||
|
# We cannot use variables to avoid an explicit array. The set |
||||||
|
# elements may look like namespace vars (i.e. contain ::), and |
||||||
|
# such elements break that, cannot be proc-local variables. |
||||||
|
array set S {} |
||||||
|
foreach item $A {set S($item) .} |
||||||
|
return [array names S] |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::S_include -- |
||||||
|
# |
||||||
|
# Add an element to a set. |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# Avar -- Reference to the set variable to extend. |
||||||
|
# element -- The item to add to the set. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# None. |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
# The set in the variable referenced by Avar is extended |
||||||
|
# by the element (if the element was not already present). |
||||||
|
|
||||||
|
proc ::struct::set::S_include {Avar element} { |
||||||
|
# Avar = Avar + {element} |
||||||
|
upvar 1 $Avar A |
||||||
|
if {![info exists A] || ![S_contains $A $element]} { |
||||||
|
lappend A $element |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::S_exclude -- |
||||||
|
# |
||||||
|
# Remove an element from a set. |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# Avar -- Reference to the set variable to shrink. |
||||||
|
# element -- The item to remove from the set. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# None. |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
# The set in the variable referenced by Avar is shrunk, |
||||||
|
# the element remove (if the element was actually present). |
||||||
|
|
||||||
|
proc ::struct::set::S_exclude {Avar element} { |
||||||
|
# Avar = Avar - {element} |
||||||
|
upvar 1 $Avar A |
||||||
|
if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} |
||||||
|
while {[::set pos [lsearch -exact $A $element]] >= 0} { |
||||||
|
::set A [lreplace [K $A [::set A {}]] $pos $pos] |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::S_add -- |
||||||
|
# |
||||||
|
# Add a set to a set. Similar to 'union', but the first argument |
||||||
|
# is a variable. |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# Avar -- Reference to the set variable to extend. |
||||||
|
# B -- The set to add to the set in Avar. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# None. |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
# The set in the variable referenced by Avar is extended |
||||||
|
# by all the elements in B. |
||||||
|
|
||||||
|
proc ::struct::set::S_add {Avar B} { |
||||||
|
# Avar = Avar + B |
||||||
|
upvar 1 $Avar A |
||||||
|
if {![info exists A]} {set A {}} |
||||||
|
::set A [S_union [K $A [::set A {}]] $B] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::S_subtract -- |
||||||
|
# |
||||||
|
# Remove a set from a set. Similar to 'difference', but the first argument |
||||||
|
# is a variable. |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# Avar -- Reference to the set variable to shrink. |
||||||
|
# B -- The set to remove from the set in Avar. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# None. |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
# The set in the variable referenced by Avar is shrunk, |
||||||
|
# all elements of B are removed. |
||||||
|
|
||||||
|
proc ::struct::set::S_subtract {Avar B} { |
||||||
|
# Avar = Avar - B |
||||||
|
upvar 1 $Avar A |
||||||
|
if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} |
||||||
|
::set A [S_difference [K $A [::set A {}]] $B] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::S_subsetof -- |
||||||
|
# |
||||||
|
# A predicate checking if the first set is a subset |
||||||
|
# or equal to the second set. |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# A -- The possible subset. |
||||||
|
# B -- The set to compare to. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# A boolean value, true if A is subset of or equal to B |
||||||
|
# |
||||||
|
# Side effects: |
||||||
|
# None. |
||||||
|
|
||||||
|
proc ::struct::set::S_subsetof {A B} { |
||||||
|
# A subset|== B <=> (A == A*B) |
||||||
|
return [S_equal $A [S_intersect $A $B]] |
||||||
|
} |
||||||
|
|
||||||
|
# ::struct::set::K -- |
||||||
|
# Performance helper command. |
||||||
|
|
||||||
|
proc ::struct::set::K {x y} {::set x} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
namespace eval ::struct { |
||||||
|
# Put 'set::set' into the general structure namespace |
||||||
|
# for pickup by the main management. |
||||||
|
|
||||||
|
namespace import -force set::set_tcl |
||||||
|
} |
||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,80 @@ |
|||||||
|
# textutil.tcl -- |
||||||
|
# |
||||||
|
# Utilities for manipulating strings, words, single lines, |
||||||
|
# paragraphs, ... |
||||||
|
# |
||||||
|
# Copyright (c) 2000 by Ajuba Solutions. |
||||||
|
# Copyright (c) 2000 by Eric Melski <ericm@ajubasolutions.com> |
||||||
|
# Copyright (c) 2002 by Joe English <jenglish@users.sourceforge.net> |
||||||
|
# Copyright (c) 2001-2006 by Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||||
|
# |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: textutil.tcl,v 1.17 2006/09/21 06:46:24 andreas_kupries Exp $ |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requirements |
||||||
|
|
||||||
|
package require Tcl 8.2 |
||||||
|
|
||||||
|
namespace eval ::textutil {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## API implementation |
||||||
|
## All through sub-packages imported here. |
||||||
|
|
||||||
|
package require textutil::string |
||||||
|
package require textutil::repeat |
||||||
|
package require textutil::adjust |
||||||
|
package require textutil::split |
||||||
|
package require textutil::tabify |
||||||
|
package require textutil::trim |
||||||
|
package require textutil::wcswidth |
||||||
|
|
||||||
|
namespace eval ::textutil { |
||||||
|
# Import the miscellaneous string command for public export |
||||||
|
|
||||||
|
namespace import -force string::chop string::tail |
||||||
|
namespace import -force string::cap string::uncap string::capEachWord |
||||||
|
namespace import -force string::longestCommonPrefix |
||||||
|
namespace import -force string::longestCommonPrefixList |
||||||
|
|
||||||
|
# Import the repeat commands for public export |
||||||
|
|
||||||
|
namespace import -force repeat::strRepeat repeat::blank |
||||||
|
|
||||||
|
# Import the adjust commands for public export |
||||||
|
|
||||||
|
namespace import -force adjust::adjust adjust::indent adjust::undent |
||||||
|
|
||||||
|
# Import the split commands for public export |
||||||
|
|
||||||
|
namespace import -force split::splitx split::splitn |
||||||
|
|
||||||
|
# Import the trim commands for public export |
||||||
|
|
||||||
|
namespace import -force trim::trim trim::trimleft trim::trimright |
||||||
|
namespace import -force trim::trimPrefix trim::trimEmptyHeading |
||||||
|
|
||||||
|
# Import the tabify commands for public export |
||||||
|
|
||||||
|
namespace import -force tabify::tabify tabify::untabify |
||||||
|
namespace import -force tabify::tabify2 tabify::untabify2 |
||||||
|
|
||||||
|
# Re-export all the imported commands |
||||||
|
|
||||||
|
namespace export chop tail cap uncap capEachWord |
||||||
|
namespace export longestCommonPrefix longestCommonPrefixList |
||||||
|
namespace export strRepeat blank |
||||||
|
namespace export adjust indent undent |
||||||
|
namespace export splitx splitn |
||||||
|
namespace export trim trimleft trimright trimPrefix trimEmptyHeading |
||||||
|
namespace export tabify untabify tabify2 untabify2 |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide textutil 0.9 |
||||||
@ -0,0 +1,761 @@ |
|||||||
|
# trim.tcl -- |
||||||
|
# |
||||||
|
# Various ways of trimming a string. |
||||||
|
# |
||||||
|
# Copyright (c) 2000 by Ajuba Solutions. |
||||||
|
# Copyright (c) 2000 by Eric Melski <ericm@ajubasolutions.com> |
||||||
|
# Copyright (c) 2002-2004 by Johannes-Heinrich Vogeler <vogeler@users.sourceforge.net> |
||||||
|
# Copyright (c) 2001-2006 by Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||||
|
# |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: adjust.tcl,v 1.16 2011/12/13 18:12:56 andreas_kupries Exp $ |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requirements |
||||||
|
|
||||||
|
package require Tcl 8.2- |
||||||
|
package require textutil::repeat |
||||||
|
package require textutil::string |
||||||
|
|
||||||
|
namespace eval ::textutil::adjust {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## API implementation |
||||||
|
|
||||||
|
namespace eval ::textutil::adjust { |
||||||
|
namespace import -force ::textutil::repeat::strRepeat |
||||||
|
} |
||||||
|
|
||||||
|
proc ::textutil::adjust::adjust {text args} { |
||||||
|
if {[string length [string trim $text]] == 0} { |
||||||
|
return "" |
||||||
|
} |
||||||
|
|
||||||
|
Configure $args |
||||||
|
Adjust text newtext |
||||||
|
|
||||||
|
return $newtext |
||||||
|
} |
||||||
|
|
||||||
|
proc ::textutil::adjust::Configure {args} { |
||||||
|
variable Justify left |
||||||
|
variable Length 72 |
||||||
|
variable FullLine 0 |
||||||
|
variable StrictLength 0 |
||||||
|
variable Hyphenate 0 |
||||||
|
variable HyphPatterns ; # hyphenation patterns (TeX) |
||||||
|
|
||||||
|
set args [ lindex $args 0 ] |
||||||
|
foreach { option value } $args { |
||||||
|
switch -exact -- $option { |
||||||
|
-full { |
||||||
|
if { ![ string is boolean -strict $value ] } then { |
||||||
|
error "expected boolean but got \"$value\"" |
||||||
|
} |
||||||
|
set FullLine [ string is true $value ] |
||||||
|
} |
||||||
|
-hyphenate { |
||||||
|
# the word exceeding the length of line is tried to be |
||||||
|
# hyphenated; if a word cannot be hyphenated to fit into |
||||||
|
# the line processing stops! The length of the line should |
||||||
|
# be set to a reasonable value! |
||||||
|
|
||||||
|
if { ![ string is boolean -strict $value ] } then { |
||||||
|
error "expected boolean but got \"$value\"" |
||||||
|
} |
||||||
|
set Hyphenate [string is true $value] |
||||||
|
if { $Hyphenate && ![info exists HyphPatterns(_LOADED_)]} { |
||||||
|
error "hyphenation patterns not loaded!" |
||||||
|
} |
||||||
|
} |
||||||
|
-justify { |
||||||
|
set lovalue [ string tolower $value ] |
||||||
|
switch -exact -- $lovalue { |
||||||
|
left - |
||||||
|
right - |
||||||
|
center - |
||||||
|
plain { |
||||||
|
set Justify $lovalue |
||||||
|
} |
||||||
|
default { |
||||||
|
error "bad value \"$value\": should be center, left, plain or right" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
-length { |
||||||
|
if { ![ string is integer $value ] } then { |
||||||
|
error "expected positive integer but got \"$value\"" |
||||||
|
} |
||||||
|
if { $value < 1 } then { |
||||||
|
error "expected positive integer but got \"$value\"" |
||||||
|
} |
||||||
|
set Length $value |
||||||
|
} |
||||||
|
-strictlength { |
||||||
|
# the word exceeding the length of line is moved to the |
||||||
|
# next line without hyphenation; words longer than given |
||||||
|
# line length are cut into smaller pieces |
||||||
|
|
||||||
|
if { ![ string is boolean -strict $value ] } then { |
||||||
|
error "expected boolean but got \"$value\"" |
||||||
|
} |
||||||
|
set StrictLength [ string is true $value ] |
||||||
|
} |
||||||
|
default { |
||||||
|
error "bad option \"$option\": must be -full, -hyphenate, \ |
||||||
|
-justify, -length, or -strictlength" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return "" |
||||||
|
} |
||||||
|
|
||||||
|
# ::textutil::adjust::Adjust |
||||||
|
# |
||||||
|
# History: |
||||||
|
# rewritten on 2004-04-13 for bugfix tcllib-bugs-882402 (jhv) |
||||||
|
|
||||||
|
proc ::textutil::adjust::Adjust { varOrigName varNewName } { |
||||||
|
variable Length |
||||||
|
variable FullLine |
||||||
|
variable StrictLength |
||||||
|
variable Hyphenate |
||||||
|
|
||||||
|
upvar $varOrigName orig |
||||||
|
upvar $varNewName text |
||||||
|
|
||||||
|
set pos 0; # Cursor after writing |
||||||
|
set line "" |
||||||
|
set text "" |
||||||
|
|
||||||
|
|
||||||
|
if {!$FullLine} { |
||||||
|
regsub -all -- "(\n)|(\t)" $orig " " orig |
||||||
|
regsub -all -- " +" $orig " " orig |
||||||
|
regsub -all -- "(^ *)|( *\$)" $orig "" orig |
||||||
|
} |
||||||
|
|
||||||
|
set words [split $orig] |
||||||
|
set numWords [llength $words] |
||||||
|
set numline 0 |
||||||
|
|
||||||
|
for {set cnt 0} {$cnt < $numWords} {incr cnt} { |
||||||
|
|
||||||
|
set w [lindex $words $cnt] |
||||||
|
set wLen [string length $w] |
||||||
|
|
||||||
|
# the word $w doesn't fit into the present line |
||||||
|
# case #1: we try to hyphenate |
||||||
|
|
||||||
|
if {$Hyphenate && ($pos+$wLen >= $Length)} { |
||||||
|
# Hyphenation instructions |
||||||
|
set w2 [textutil::adjust::Hyphenation $w] |
||||||
|
|
||||||
|
set iMax [llength $w2] |
||||||
|
if {$iMax == 1 && [string length $w] > $Length} { |
||||||
|
# word cannot be hyphenated and exceeds linesize |
||||||
|
|
||||||
|
error "Word \"$w2\" can\'t be hyphenated\ |
||||||
|
and exceeds linesize $Length!" |
||||||
|
} else { |
||||||
|
# hyphenating of $w was successfull, but we have to look |
||||||
|
# that every sylable would fit into the line |
||||||
|
|
||||||
|
foreach x $w2 { |
||||||
|
if {[string length $x] >= $Length} { |
||||||
|
error "Word \"$w\" can\'t be hyphenated\ |
||||||
|
to fit into linesize $Length!" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
for {set i 0; set w3 ""} {$i < $iMax} {incr i} { |
||||||
|
set syl [lindex $w2 $i] |
||||||
|
if {($pos+[string length " $w3$syl-"]) > $Length} {break} |
||||||
|
append w3 $syl |
||||||
|
} |
||||||
|
for {set w4 ""} {$i < $iMax} {incr i} { |
||||||
|
set syl [lindex $w2 $i] |
||||||
|
append w4 $syl |
||||||
|
} |
||||||
|
|
||||||
|
if {[string length $w3] && [string length $w4]} { |
||||||
|
# hyphenation was successfull: redefine |
||||||
|
# list of words w => {"$w3-" "$w4"} |
||||||
|
|
||||||
|
set x [lreplace $words $cnt $cnt "$w4"] |
||||||
|
set words [linsert $x $cnt "$w3-"] |
||||||
|
set w [lindex $words $cnt] |
||||||
|
set wLen [string length $w] |
||||||
|
incr numWords |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# the word $w doesn't fit into the present line |
||||||
|
# case #2: we try to cut the word into pieces |
||||||
|
|
||||||
|
if {$StrictLength && ([string length $w] > $Length)} { |
||||||
|
# cut word into two pieces |
||||||
|
set w2 $w |
||||||
|
|
||||||
|
set over [expr {$pos+2+$wLen-$Length}] |
||||||
|
|
||||||
|
incr Length -1 |
||||||
|
set w3 [string range $w2 0 $Length] |
||||||
|
incr Length |
||||||
|
set w4 [string range $w2 $Length end] |
||||||
|
|
||||||
|
set x [lreplace $words $cnt $cnt $w4] |
||||||
|
set words [linsert $x $cnt $w3 ] |
||||||
|
set w [lindex $words $cnt] |
||||||
|
set wLen [string length $w] |
||||||
|
incr numWords |
||||||
|
} |
||||||
|
|
||||||
|
# continuing with the normal procedure |
||||||
|
|
||||||
|
if {($pos+$wLen < $Length)} { |
||||||
|
# append word to current line |
||||||
|
|
||||||
|
if {$pos} {append line " "; incr pos} |
||||||
|
append line $w |
||||||
|
incr pos $wLen |
||||||
|
} else { |
||||||
|
# line full => write buffer and begin a new line |
||||||
|
|
||||||
|
if {[string length $text]} {append text "\n"} |
||||||
|
append text [Justification $line [incr numline]] |
||||||
|
set line $w |
||||||
|
set pos $wLen |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# write buffer and return! |
||||||
|
|
||||||
|
if {[string length $text]} {append text "\n"} |
||||||
|
append text [Justification $line end] |
||||||
|
return $text |
||||||
|
} |
||||||
|
|
||||||
|
# ::textutil::adjust::Justification |
||||||
|
# |
||||||
|
# justify a given line |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# line text for justification |
||||||
|
# index index for line in text |
||||||
|
# |
||||||
|
# Returns: |
||||||
|
# the justified line |
||||||
|
# |
||||||
|
# Remarks: |
||||||
|
# Only lines with size not exceeding the max. linesize provided |
||||||
|
# for text formatting are justified!!! |
||||||
|
|
||||||
|
proc ::textutil::adjust::Justification { line index } { |
||||||
|
variable Justify |
||||||
|
variable Length |
||||||
|
variable FullLine |
||||||
|
|
||||||
|
set len [string length $line]; # length of current line |
||||||
|
|
||||||
|
if { $Length <= $len } then { |
||||||
|
# the length of current line ($len) is equal as or greater than |
||||||
|
# the value provided for text formatting ($Length) => to avoid |
||||||
|
# inifinite loops we leave $line unchanged and return! |
||||||
|
|
||||||
|
return $line |
||||||
|
} |
||||||
|
|
||||||
|
# Special case: |
||||||
|
# for the last line, and if the justification is set to 'plain' |
||||||
|
# the real justification is 'left' if the length of the line |
||||||
|
# is less than 90% (rounded) of the max length allowed. This is |
||||||
|
# to avoid expansion of this line when it is too small: without |
||||||
|
# it, the added spaces will 'unbeautify' the result. |
||||||
|
# |
||||||
|
|
||||||
|
set justify $Justify |
||||||
|
if { ( "$index" == "end" ) && \ |
||||||
|
( "$Justify" == "plain" ) && \ |
||||||
|
( $len < round($Length * 0.90) ) } then { |
||||||
|
set justify left |
||||||
|
} |
||||||
|
|
||||||
|
# For a left justification, nothing to do, but to |
||||||
|
# add some spaces at the end of the line if requested |
||||||
|
|
||||||
|
if { "$justify" == "left" } then { |
||||||
|
set jus "" |
||||||
|
if { $FullLine } then { |
||||||
|
set jus [strRepeat " " [ expr { $Length - $len } ]] |
||||||
|
} |
||||||
|
return "${line}${jus}" |
||||||
|
} |
||||||
|
|
||||||
|
# For a right justification, just add enough spaces |
||||||
|
# at the beginning of the line |
||||||
|
|
||||||
|
if { "$justify" == "right" } then { |
||||||
|
set jus [strRepeat " " [ expr { $Length - $len } ]] |
||||||
|
return "${jus}${line}" |
||||||
|
} |
||||||
|
|
||||||
|
# For a center justification, add half of the needed spaces |
||||||
|
# at the beginning of the line, and the rest at the end |
||||||
|
# only if needed. |
||||||
|
|
||||||
|
if { "$justify" == "center" } then { |
||||||
|
set mr [ expr { ( $Length - $len ) / 2 } ] |
||||||
|
set ml [ expr { $Length - $len - $mr } ] |
||||||
|
set jusl [strRepeat " " $ml] |
||||||
|
set jusr [strRepeat " " $mr] |
||||||
|
if { $FullLine } then { |
||||||
|
return "${jusl}${line}${jusr}" |
||||||
|
} else { |
||||||
|
return "${jusl}${line}" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# For a plain justification, it's a little bit complex: |
||||||
|
# |
||||||
|
# if some spaces are missing, then |
||||||
|
# |
||||||
|
# 1) sort the list of words in the current line by decreasing size |
||||||
|
# 2) foreach word, add one space before it, except if it's the |
||||||
|
# first word, until enough spaces are added |
||||||
|
# 3) rebuild the line |
||||||
|
|
||||||
|
if { "$justify" == "plain" } then { |
||||||
|
set miss [ expr { $Length - [ string length $line ] } ] |
||||||
|
|
||||||
|
# Bugfix tcllib-bugs-860753 (jhv) |
||||||
|
|
||||||
|
set words [split $line] |
||||||
|
set numWords [llength $words] |
||||||
|
|
||||||
|
if {$numWords < 2} { |
||||||
|
# current line consists of less than two words - we can't |
||||||
|
# insert blanks to achieve a plain justification => leave |
||||||
|
# $line unchanged and return! |
||||||
|
|
||||||
|
return $line |
||||||
|
} |
||||||
|
|
||||||
|
for {set i 0; set totalLen 0} {$i < $numWords} {incr i} { |
||||||
|
set w($i) [lindex $words $i] |
||||||
|
if {$i > 0} {set w($i) " $w($i)"} |
||||||
|
set wLen($i) [string length $w($i)] |
||||||
|
set totalLen [expr {$totalLen+$wLen($i)}] |
||||||
|
} |
||||||
|
|
||||||
|
set miss [expr {$Length - $totalLen}] |
||||||
|
|
||||||
|
# len walks through all lengths of words of the line under |
||||||
|
# consideration |
||||||
|
|
||||||
|
for {set len 1} {$miss > 0} {incr len} { |
||||||
|
for {set i 1} {($i < $numWords) && ($miss > 0)} {incr i} { |
||||||
|
if {$wLen($i) == $len} { |
||||||
|
set w($i) " $w($i)" |
||||||
|
incr wLen($i) |
||||||
|
incr miss -1 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set line "" |
||||||
|
for {set i 0} {$i < $numWords} {incr i} { |
||||||
|
set line "$line$w($i)" |
||||||
|
} |
||||||
|
|
||||||
|
# End of bugfix |
||||||
|
|
||||||
|
return "${line}" |
||||||
|
} |
||||||
|
|
||||||
|
error "Illegal justification key \"$justify\"" |
||||||
|
} |
||||||
|
|
||||||
|
proc ::textutil::adjust::SortList { list dir index } { |
||||||
|
|
||||||
|
if { [ catch { lsort -integer -$dir -index $index $list } sl ] != 0 } then { |
||||||
|
error "$sl" |
||||||
|
} |
||||||
|
|
||||||
|
return $sl |
||||||
|
} |
||||||
|
|
||||||
|
# Hyphenation utilities based on Knuth's algorithm |
||||||
|
# |
||||||
|
# Copyright (C) 2001-2003 by Dr.Johannes-Heinrich Vogeler (jhv) |
||||||
|
# These procedures may be used as part of the tcllib |
||||||
|
|
||||||
|
# textutil::adjust::Hyphenation |
||||||
|
# |
||||||
|
# Hyphenate a string using Knuth's algorithm |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# str string to be hyphenated |
||||||
|
# |
||||||
|
# Returns: |
||||||
|
# the hyphenated string |
||||||
|
|
||||||
|
proc ::textutil::adjust::Hyphenation { str } { |
||||||
|
|
||||||
|
# if there are manual set hyphenation marks e.g. "Recht\-schrei\-bung" |
||||||
|
# use these for hyphenation and return |
||||||
|
|
||||||
|
if {[regexp {[^\\-]*[\\-][.]*} $str]} { |
||||||
|
regsub -all {(\\)(-)} $str {-} tmp |
||||||
|
return [split $tmp -] |
||||||
|
} |
||||||
|
|
||||||
|
# Don't hyphenate very short words! Minimum length for hyphenation |
||||||
|
# is set to 3 characters! |
||||||
|
|
||||||
|
if { [string length $str] < 4 } then { return $str } |
||||||
|
|
||||||
|
# otherwise follow Knuth's algorithm |
||||||
|
|
||||||
|
variable HyphPatterns; # hyphenation patterns (TeX) |
||||||
|
|
||||||
|
set w ".[string tolower $str]."; # transform to lower case |
||||||
|
set wLen [string length $w]; # and add delimiters |
||||||
|
|
||||||
|
# Initialize hyphenation weights |
||||||
|
|
||||||
|
set s {} |
||||||
|
for {set i 0} {$i < $wLen} {incr i} { |
||||||
|
lappend s 0 |
||||||
|
} |
||||||
|
|
||||||
|
for {set i 0} {$i < $wLen} {incr i} { |
||||||
|
set kmax [expr {$wLen-$i}] |
||||||
|
for {set k 1} {$k < $kmax} {incr k} { |
||||||
|
set sw [string range $w $i [expr {$i+$k}]] |
||||||
|
if {[info exists HyphPatterns($sw)]} { |
||||||
|
set hw $HyphPatterns($sw) |
||||||
|
set hwLen [string length $hw] |
||||||
|
for {set l1 0; set l2 0} {$l1 < $hwLen} {incr l1} { |
||||||
|
set c [string index $hw $l1] |
||||||
|
if {[string is digit $c]} { |
||||||
|
set sPos [expr {$i+$l2}] |
||||||
|
if {$c > [lindex $s $sPos]} { |
||||||
|
set s [lreplace $s $sPos $sPos $c] |
||||||
|
} |
||||||
|
} else { |
||||||
|
incr l2 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Replace all even hyphenation weigths by zero |
||||||
|
|
||||||
|
for {set i 0} {$i < [llength $s]} {incr i} { |
||||||
|
set c [lindex $s $i] |
||||||
|
if {!($c%2)} { set s [lreplace $s $i $i 0] } |
||||||
|
} |
||||||
|
|
||||||
|
# Don't start with a hyphen! Take also care of words enclosed in quotes |
||||||
|
# or that someone has forgotten to put a blank between a punctuation |
||||||
|
# character and the following word etc. |
||||||
|
|
||||||
|
for {set i 1} {$i < ($wLen-1)} {incr i} { |
||||||
|
set c [string range $w $i end] |
||||||
|
if {[regexp {^[:alpha:][.]*} $c]} { |
||||||
|
for {set k 1} {$k < ($i+1)} {incr k} { |
||||||
|
set s [lreplace $s $k $k 0] |
||||||
|
} |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Don't separate the last character of a word with a hyphen |
||||||
|
|
||||||
|
set max [expr {[llength $s]-2}] |
||||||
|
if {$max} {set s [lreplace $s $max end 0]} |
||||||
|
|
||||||
|
# return the syllabels of the hyphenated word as a list! |
||||||
|
|
||||||
|
set ret "" |
||||||
|
set w ".$str." |
||||||
|
for {set i 1} {$i < ($wLen-1)} {incr i} { |
||||||
|
if {[lindex $s $i]} { append ret - } |
||||||
|
append ret [string index $w $i] |
||||||
|
} |
||||||
|
return [split $ret -] |
||||||
|
} |
||||||
|
|
||||||
|
# textutil::adjust::listPredefined |
||||||
|
# |
||||||
|
# Return the names of the hyphenation files coming with the package. |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# None. |
||||||
|
# |
||||||
|
# Result: |
||||||
|
# List of filenames (without directory) |
||||||
|
|
||||||
|
proc ::textutil::adjust::listPredefined {} { |
||||||
|
variable here |
||||||
|
return [glob -type f -directory $here -tails *.tex] |
||||||
|
} |
||||||
|
|
||||||
|
# textutil::adjust::getPredefined |
||||||
|
# |
||||||
|
# Retrieve the full path for a predefined hyphenation file |
||||||
|
# coming with the package. |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# name Name of the predefined file. |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# Full path to the file, or an error if it doesn't |
||||||
|
# exist or is matching the pattern *.tex. |
||||||
|
|
||||||
|
proc ::textutil::adjust::getPredefined {name} { |
||||||
|
variable here |
||||||
|
|
||||||
|
if {![string match *.tex $name]} { |
||||||
|
return -code error \ |
||||||
|
"Illegal hyphenation file \"$name\"" |
||||||
|
} |
||||||
|
set path [file join $here $name] |
||||||
|
if {![file exists $path]} { |
||||||
|
return -code error \ |
||||||
|
"Unknown hyphenation file \"$path\"" |
||||||
|
} |
||||||
|
return $path |
||||||
|
} |
||||||
|
|
||||||
|
# textutil::adjust::readPatterns |
||||||
|
# |
||||||
|
# Read hyphenation patterns from a file and store them in an array |
||||||
|
# |
||||||
|
# Parameters: |
||||||
|
# filNam name of the file containing the patterns |
||||||
|
|
||||||
|
proc ::textutil::adjust::readPatterns { filNam } { |
||||||
|
|
||||||
|
variable HyphPatterns; # hyphenation patterns (TeX) |
||||||
|
|
||||||
|
# HyphPatterns(_LOADED_) is used as flag for having loaded |
||||||
|
# hyphenation patterns from the respective file (TeX format) |
||||||
|
|
||||||
|
if {[info exists HyphPatterns(_LOADED_)]} { |
||||||
|
unset HyphPatterns(_LOADED_) |
||||||
|
} |
||||||
|
|
||||||
|
# the array xlat provides translation from TeX encoded characters |
||||||
|
# to those of the ISO-8859-1 character set |
||||||
|
|
||||||
|
set xlat(\"s) \337; # 223 := sharp s " |
||||||
|
set xlat(\`a) \340; # 224 := a, grave |
||||||
|
set xlat(\'a) \341; # 225 := a, acute |
||||||
|
set xlat(\^a) \342; # 226 := a, circumflex |
||||||
|
set xlat(\"a) \344; # 228 := a, diaeresis " |
||||||
|
set xlat(\`e) \350; # 232 := e, grave |
||||||
|
set xlat(\'e) \351; # 233 := e, acute |
||||||
|
set xlat(\^e) \352; # 234 := e, circumflex |
||||||
|
set xlat(\`i) \354; # 236 := i, grave |
||||||
|
set xlat(\'i) \355; # 237 := i, acute |
||||||
|
set xlat(\^i) \356; # 238 := i, circumflex |
||||||
|
set xlat(\~n) \361; # 241 := n, tilde |
||||||
|
set xlat(\`o) \362; # 242 := o, grave |
||||||
|
set xlat(\'o) \363; # 243 := o, acute |
||||||
|
set xlat(\^o) \364; # 244 := o, circumflex |
||||||
|
set xlat(\"o) \366; # 246 := o, diaeresis " |
||||||
|
set xlat(\`u) \371; # 249 := u, grave |
||||||
|
set xlat(\'u) \372; # 250 := u, acute |
||||||
|
set xlat(\^u) \373; # 251 := u, circumflex |
||||||
|
set xlat(\"u) \374; # 252 := u, diaeresis " |
||||||
|
|
||||||
|
set fd [open $filNam RDONLY] |
||||||
|
set status 0 |
||||||
|
|
||||||
|
while {[gets $fd line] >= 0} { |
||||||
|
|
||||||
|
switch -exact $status { |
||||||
|
PATTERNS { |
||||||
|
if {[regexp {^\}[.]*} $line]} { |
||||||
|
# End of patterns encountered: set status |
||||||
|
# and ignore that line |
||||||
|
set status 0 |
||||||
|
continue |
||||||
|
} else { |
||||||
|
# This seems to be pattern definition line; to process it |
||||||
|
# we have first to do some editing |
||||||
|
# |
||||||
|
# 1) eat comments in a pattern definition line |
||||||
|
# 2) eat braces and coded linefeeds |
||||||
|
|
||||||
|
set z [string first "%" $line] |
||||||
|
if {$z > 0} { set line [string range $line 0 [expr {$z-1}]] } |
||||||
|
|
||||||
|
regsub -all {(\\n|\{|\})} $line {} tmp |
||||||
|
set line $tmp |
||||||
|
|
||||||
|
# Now $line should consist only of hyphenation patterns |
||||||
|
# separated by white space |
||||||
|
|
||||||
|
# Translate TeX encoded characters to ISO-8859-1 characters |
||||||
|
# using the array xlat defined above |
||||||
|
|
||||||
|
foreach x [array names xlat] { |
||||||
|
regsub -all {$x} $line $xlat($x) tmp |
||||||
|
set line $tmp |
||||||
|
} |
||||||
|
|
||||||
|
# split the line and create a lookup array for |
||||||
|
# the repective hyphenation patterns |
||||||
|
|
||||||
|
foreach item [split $line] { |
||||||
|
if {[string length $item]} { |
||||||
|
if {![string match {\\} $item]} { |
||||||
|
# create index for hyphenation patterns |
||||||
|
|
||||||
|
set var $item |
||||||
|
regsub -all {[0-9]} $var {} idx |
||||||
|
# store hyphenation patterns as elements of an array |
||||||
|
|
||||||
|
set HyphPatterns($idx) $item |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
EXCEPTIONS { |
||||||
|
if {[regexp {^\}[.]*} $line]} { |
||||||
|
# End of patterns encountered: set status |
||||||
|
# and ignore that line |
||||||
|
set status 0 |
||||||
|
continue |
||||||
|
} else { |
||||||
|
# to be done in the future |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
if {[regexp {^\\endinput[.]*} $line]} { |
||||||
|
# end of data encountered, stop processing and |
||||||
|
# ignore all the following text .. |
||||||
|
break |
||||||
|
} elseif {[regexp {^\\patterns[.]*} $line]} { |
||||||
|
# begin of patterns encountered: set status |
||||||
|
# and ignore that line |
||||||
|
set status PATTERNS |
||||||
|
continue |
||||||
|
} elseif {[regexp {^\\hyphenation[.]*} $line]} { |
||||||
|
# some particular cases to be treated separately |
||||||
|
set status EXCEPTIONS |
||||||
|
continue |
||||||
|
} else { |
||||||
|
set status 0 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
close $fd |
||||||
|
set HyphPatterns(_LOADED_) 1 |
||||||
|
|
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
####################################################### |
||||||
|
|
||||||
|
# @c The specified <a text>block is indented |
||||||
|
# @c by <a prefix>ing each line. The first |
||||||
|
# @c <a hang> lines ares skipped. |
||||||
|
# |
||||||
|
# @a text: The paragraph to indent. |
||||||
|
# @a prefix: The string to use as prefix for each line |
||||||
|
# @a prefix: of <a text> with. |
||||||
|
# @a skip: The number of lines at the beginning to leave untouched. |
||||||
|
# |
||||||
|
# @r Basically <a text>, but indented a certain amount. |
||||||
|
# |
||||||
|
# @i indent |
||||||
|
# @n This procedure is not checked by the testsuite. |
||||||
|
|
||||||
|
proc ::textutil::adjust::indent {text prefix {skip 0}} { |
||||||
|
set text [string trimright $text] |
||||||
|
|
||||||
|
set res [list] |
||||||
|
foreach line [split $text \n] { |
||||||
|
if {[string compare "" [string trim $line]] == 0} { |
||||||
|
lappend res {} |
||||||
|
} else { |
||||||
|
set line [string trimright $line] |
||||||
|
if {$skip <= 0} { |
||||||
|
lappend res $prefix$line |
||||||
|
} else { |
||||||
|
lappend res $line |
||||||
|
} |
||||||
|
} |
||||||
|
if {$skip > 0} {incr skip -1} |
||||||
|
} |
||||||
|
return [join $res \n] |
||||||
|
} |
||||||
|
|
||||||
|
# Undent the block of text: Compute LCP (restricted to whitespace!) |
||||||
|
# and remove that from each line. Note that this preverses the |
||||||
|
# shaping of the paragraph (i.e. hanging indent are _not_ flattened) |
||||||
|
# We ignore empty lines !! |
||||||
|
|
||||||
|
proc ::textutil::adjust::undent {text} { |
||||||
|
|
||||||
|
if {$text == {}} {return {}} |
||||||
|
|
||||||
|
set lines [split $text \n] |
||||||
|
set ne [list] |
||||||
|
foreach l $lines { |
||||||
|
if {[string length [string trim $l]] == 0} continue |
||||||
|
lappend ne $l |
||||||
|
} |
||||||
|
set lcp [::textutil::string::longestCommonPrefixList $ne] |
||||||
|
|
||||||
|
if {[string length $lcp] == 0} {return $text} |
||||||
|
|
||||||
|
regexp "^(\[\t \]*)" $lcp -> lcp |
||||||
|
|
||||||
|
if {[string length $lcp] == 0} {return $text} |
||||||
|
|
||||||
|
set len [string length $lcp] |
||||||
|
|
||||||
|
set res [list] |
||||||
|
foreach l $lines { |
||||||
|
if {[string length [string trim $l]] == 0} { |
||||||
|
lappend res {} |
||||||
|
} else { |
||||||
|
lappend res [string range $l $len end] |
||||||
|
} |
||||||
|
} |
||||||
|
return [join $res \n] |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Data structures |
||||||
|
|
||||||
|
namespace eval ::textutil::adjust { |
||||||
|
variable here [file dirname [info script]] |
||||||
|
|
||||||
|
variable Justify left |
||||||
|
variable Length 72 |
||||||
|
variable FullLine 0 |
||||||
|
variable StrictLength 0 |
||||||
|
variable Hyphenate 0 |
||||||
|
variable HyphPatterns |
||||||
|
|
||||||
|
namespace export adjust indent undent |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide textutil::adjust 0.7.3 |
||||||
@ -0,0 +1,902 @@ |
|||||||
|
% This is `dehypht.tex' as of 03 March 1999. |
||||||
|
% |
||||||
|
% Copyright (C) 1988,1991 Rechenzentrum der Ruhr-Universitaet Bochum |
||||||
|
% [german hyphen patterns] |
||||||
|
% Copyright (C) 1993,1994,1999 Bernd Raichle/DANTE e.V. |
||||||
|
% [macros, adaption for TeX 2] |
||||||
|
% |
||||||
|
% ----------------------------------------------------------------- |
||||||
|
% IMPORTANT NOTICE: |
||||||
|
% |
||||||
|
% This program can be redistributed and/or modified under the terms |
||||||
|
% of the LaTeX Project Public License Distributed from CTAN |
||||||
|
% archives in directory macros/latex/base/lppl.txt; either |
||||||
|
% version 1 of the License, or any later version. |
||||||
|
% ----------------------------------------------------------------- |
||||||
|
% |
||||||
|
% |
||||||
|
% This file contains german hyphen patterns following traditional |
||||||
|
% hyphenation rules and includes umlauts and sharp s, but without |
||||||
|
% `c-k' and triple consonants. It is based on hyphen patterns |
||||||
|
% containing 5719 german hyphen patterns with umlauts in the |
||||||
|
% recommended version of September 27, 1990. |
||||||
|
% |
||||||
|
% For use with TeX generated by |
||||||
|
% |
||||||
|
% Norbert Schwarz |
||||||
|
% Rechenzentrum Ruhr-Universitaet Bochum |
||||||
|
% Universitaetsstrasse 150 |
||||||
|
% D-44721 Bochum, FRG |
||||||
|
% |
||||||
|
% |
||||||
|
% Adaption of these patterns for TeX, Version 2.x and 3.x and |
||||||
|
% all fonts in T1/`Cork'/EC/DC and/or OT1/CM encoding by |
||||||
|
% |
||||||
|
% Bernd Raichle |
||||||
|
% Stettener Str. 73 |
||||||
|
% D-73732 Esslingen, FRG |
||||||
|
% Email: raichle@Informatik.Uni-Stuttgart.DE |
||||||
|
% |
||||||
|
% |
||||||
|
% Error reports in case of UNCHANGED versions to |
||||||
|
% |
||||||
|
% DANTE e.V., Koordinator `german.sty' |
||||||
|
% Postfach 10 18 40 |
||||||
|
% D-69008 Heidelberg, FRG |
||||||
|
% Email: german@Dante.DE |
||||||
|
% |
||||||
|
% or one of the addresses given above. |
||||||
|
% |
||||||
|
% |
||||||
|
% Changes: |
||||||
|
% 1990-09-27 First version of `ghyphen3.tex' (Norbert Schwarz) |
||||||
|
% 1991-02-13 PC umlauts changed to ^^xx (Norbert Schwarz) |
||||||
|
% 1993-08-27 Umlauts/\ss changed to "a/\3 macros, added macro |
||||||
|
% definitions and additional logic to select correct |
||||||
|
% patterns/encoding (Bernd Raichle) |
||||||
|
% 1994-02-13 Release of `ghyph31.tex' V3.1a (Bernd Raichle) |
||||||
|
% 1999-03-03 Renamed file to `dehypht.tex' according to the |
||||||
|
% naming scheme using the ISO country code `de', the |
||||||
|
% common part `hyph' for all hyphenation patterns files, |
||||||
|
% and the additional postfix `t' for traditional, |
||||||
|
% removed wrong catcode change of ^^e (the comment |
||||||
|
% character %) and ^^f (the character &), |
||||||
|
% do _not_ change \catcode, \lccode, \uccode to avoid |
||||||
|
% problems with other hyphenation pattern files, |
||||||
|
% changed code to distinguish TeX 2.x/3.x, |
||||||
|
% changed license conditions to LPPL (Bernd Raichle) |
||||||
|
% |
||||||
|
% |
||||||
|
% For more information see the additional documentation |
||||||
|
% at the end of this file. |
||||||
|
% |
||||||
|
% ----------------------------------------------------------------- |
||||||
|
% |
||||||
|
\message{German Traditional Hyphenation Patterns % |
||||||
|
`dehypht' Version 3.2a <1999/03/03>} |
||||||
|
\message{(Formerly known under the name `ghyph31' and `ghyphen'.)} |
||||||
|
% |
||||||
|
% |
||||||
|
% Next we define some commands which are used inside the patterns. |
||||||
|
% To keep them local, we enclose the rest of the file in a group |
||||||
|
% (The \patterns command globally changes the hyphenation trie!). |
||||||
|
% |
||||||
|
\begingroup |
||||||
|
% |
||||||
|
% |
||||||
|
% Make sure that doublequote is not active: |
||||||
|
\catcode`\"=12 |
||||||
|
% |
||||||
|
% |
||||||
|
% Because ^^e4 is used in the following macros which is read by |
||||||
|
% TeX 2.x as ^^e or %, the comment character of TeX, some trick |
||||||
|
% has to be found to avoid this problem. The same is true for the |
||||||
|
% character ^^f or & in the TeX 2.x code. |
||||||
|
% Therefore in the code the exclamationmark ! is used instead of |
||||||
|
% the circumflex ^ and its \catcode is set appropriately |
||||||
|
% (normally \catcode`\!=12, in the code \catcode`\!=7). |
||||||
|
% |
||||||
|
% The following \catcode, \lccode assignments and macro definitions |
||||||
|
% are defined in such a way that the following \pattern{...} list |
||||||
|
% can be used for both, TeX 2.x and TeX 3.x. |
||||||
|
% |
||||||
|
% We first change the \lccode of ^^Y to make sure that we can |
||||||
|
% include this character in the hyphenation patterns. |
||||||
|
% |
||||||
|
\catcode`\^^Y=11 \lccode`\^^Y=`\^^Y |
||||||
|
% |
||||||
|
% Then we have to define some macros depending on the TeX version. |
||||||
|
% Therefore we have to distinguish TeX version 2.x and 3.x: |
||||||
|
% |
||||||
|
\ifnum`\@=`\^^40 % true => TeX 3.x |
||||||
|
% |
||||||
|
% For TeX 3: |
||||||
|
% ---------- |
||||||
|
% |
||||||
|
% Assign appropriate \catcode and \lccode values for all |
||||||
|
% accented characters used in the patterns (\uccode changes are |
||||||
|
% not used within \patterns{...} and thus not necessary): |
||||||
|
% |
||||||
|
\catcode"E4=11 \catcode"C4=11 % \"a \"A |
||||||
|
\catcode"F6=11 \catcode"D6=11 % \"o \"O |
||||||
|
\catcode"FC=11 \catcode"DC=11 % \"u \"U |
||||||
|
\catcode"FF=11 \catcode"DF=11 % \ss SS |
||||||
|
% |
||||||
|
\lccode"C4="E4 \uccode"C4="C4 \lccode"E4="E4 \uccode"E4="C4 |
||||||
|
\lccode"D6="F6 \uccode"D6="D6 \lccode"F6="F6 \uccode"F6="D6 |
||||||
|
\lccode"DC="FC \uccode"DC="DC \lccode"FC="FC \uccode"FC="DC |
||||||
|
\lccode"DF="FF \uccode"DF="DF \lccode"FF="FF \uccode"FF="DF |
||||||
|
% |
||||||
|
% In the following definitions we use ??xy instead of ^^xy |
||||||
|
% to avoid errors when reading the following macro definitions |
||||||
|
% with TeX 2.x (remember ^^e(4) is the comment character): |
||||||
|
% |
||||||
|
\catcode`\?=7 |
||||||
|
% |
||||||
|
% Define the accent macro " in such a way that it |
||||||
|
% expands to single letters in font encoding T1. |
||||||
|
\catcode`\"=13 |
||||||
|
\def"#1{\ifx#1a??e4\else \ifx#1o??f6\else \ifx#1u??fc\else |
||||||
|
\errmessage{Hyphenation pattern file corrupted!}% |
||||||
|
\fi\fi\fi} |
||||||
|
% |
||||||
|
% - patterns with umlauts are ok |
||||||
|
\def\n#1{#1} |
||||||
|
% |
||||||
|
% For \ss which exists in T1 _and_ OT1 encoded fonts but with |
||||||
|
% different glyph codes, duplicated patterns for both encodings |
||||||
|
% are included. Thus you can use these hyphenation patterns for |
||||||
|
% T1 and OT1 encoded fonts: |
||||||
|
% - define \3 to be code `\^^ff (\ss in font encoding T1) |
||||||
|
% - define \9 to be code `\^^Y (\ss in font encoding OT1) |
||||||
|
\def\3{??ff} |
||||||
|
\def\9{??Y} |
||||||
|
% - duplicated patterns to support font encoding OT1 are ok |
||||||
|
\def\c#1{#1} |
||||||
|
% >>>>>> UNCOMMENT the next line, if you do not want |
||||||
|
% >>>>>> to use fonts in font encoding OT1 |
||||||
|
%\def\c#1{} |
||||||
|
% |
||||||
|
\catcode`\?=12 |
||||||
|
% |
||||||
|
\else |
||||||
|
% |
||||||
|
% For TeX 2: |
||||||
|
% ---------- |
||||||
|
% |
||||||
|
% Define the accent macro " to throw an error message. |
||||||
|
\catcode`\"=13 |
||||||
|
\def"#1{\errmessage{Hyphenation pattern file corrupted!}} |
||||||
|
% |
||||||
|
% - ignore all patterns with umlauts |
||||||
|
\def\n#1{} |
||||||
|
% |
||||||
|
% With TeX 2 fonts in encoding T1 can be used, but all glyphs |
||||||
|
% in positions > 127 can not be used in hyphenation patterns. |
||||||
|
% Thus only patterns with glyphs in OT1 positions are included: |
||||||
|
% - define \3 to be code ^^Y (\ss in CM font encoding) |
||||||
|
% - define \9 to throw an error message |
||||||
|
\def\3{^^Y} |
||||||
|
\def\9{\errmessage{Hyphenation pattern file corrupted!}} |
||||||
|
% - ignore all duplicated patterns with \ss in T1 encoding |
||||||
|
\def\c#1{} |
||||||
|
% |
||||||
|
\fi |
||||||
|
% |
||||||
|
% |
||||||
|
\patterns{% |
||||||
|
.aa6l .ab3a4s .ab3ei .abi2 .ab3it .ab1l .ab1r .ab3u .ad3o4r .alti6 |
||||||
|
.ana3c .an5alg .an1e .ang8s .an1s .ap1p .ar6sc .ar6ta .ar6tei .as2z |
||||||
|
.au2f1 .au2s3 .be5erb .be3na .ber6t5r .bie6r5 .bim6s5t .brot3 .bru6s |
||||||
|
.ch6 .che6f5 .da8c .da2r .dar5in .dar5u .den6ka .de5r6en .des6pe |
||||||
|
.de8spo .de3sz .dia3s4 .dien4 .dy2s1 .ehren5 .eine6 .ei6n5eh .ei8nen |
||||||
|
.ein5sa .en6der .en6d5r .en3k4 .en8ta8 .en8tei .en4t3r .epo1 .er6ban |
||||||
|
.er6b5ei .er6bla .er6d5um .er3ei .er5er .er3in .er3o4b .erwi5s .es1p |
||||||
|
.es8t .ex1a2 .ex3em .fal6sc .fe6st5a .flu4g3 .furch8 .ga6ner .ge3n4a |
||||||
|
\n{.ge5r"o} .ges6 .halb5 .halbe6 .hal6br .haup4 .hau4t .heima6 .he4r3e |
||||||
|
.her6za .he5x .hin3 .hir8sc .ho4c .hu3sa .hy5o .ibe5 .ima6ge .in1 |
||||||
|
.ini6 .is5chi .jagd5 .kal6k5o .ka6ph .ki4e .kop6f3 .kraf6 \n{.k"u5ra} |
||||||
|
.lab6br .liie6 .lo6s5k \n{.l"o4s3t} .ma5d .mi2t1 .no6th .no6top |
||||||
|
.obe8ri .ob1l .obs2 .ob6st5e .or3c .ort6s5e .ost3a .oste8r .pe4re |
||||||
|
.pe3ts .ph6 .po8str .rau4m3 .re5an .ro8q .ru5the \n{.r"u5be} |
||||||
|
\n{.r"u8stet} .sch8 .se6e .se5n6h .se5ra .si2e .spi6ke .st4 .sy2n |
||||||
|
.tages5 .tan6kl .ta8th .te6e .te8str .to6der .to8nin .to6we .um1 |
||||||
|
.umpf4 .un1 .une6 .unge5n .ur1c .ur5en .ve6rin .vora8 .wah6l5 .we8ges |
||||||
|
.wo6r .wor3a .wun4s .zi4e .zuch8 \n{."ande8re} \n{."och8} aa1c aa2gr |
||||||
|
aal5e aa6r5a a5arti aa2s1t aat2s 6aba ab3art 1abdr 6abel aben6dr |
||||||
|
ab5erk ab5err ab5esse 1abf 1abg \n{1abh"a} ab1ir 1abko a1bl ab1la |
||||||
|
5ablag a6bla\3 \c{a6bla\9} ab4ler ab1lu \n{a8bl"a} \n{5a6bl"o} abma5c |
||||||
|
1abn ab1ra ab1re 5a6brec ab1ro ab1s ab8sk abs2z 3abtei ab1ur 1abw |
||||||
|
5abze 5abzu \n{ab1"an} \n{ab"au8} a4ce. a5chal ach5art ach5au a1che |
||||||
|
a8chent ach6er. a6ch5erf a1chi ach1l ach3m ach5n a1cho ach3re a1chu |
||||||
|
ach1w a1chy \n{ach5"af} ack1o acks6t ack5sta a1d 8ad. a6d5ac ad3ant |
||||||
|
ad8ar 5addi a8dein ade5o8 adi5en 1adj 1adle ad1op a2dre 3adres adt1 |
||||||
|
1adv \n{a6d"a} a1e2d ae1r a1er. 1aero 8afa a3fal af1an a5far a5fat |
||||||
|
af1au a6fentl a2f1ex af1fr af5rau af1re 1afri af6tent af6tra aft5re |
||||||
|
a6f5um \n{8af"a} ag5abe 5a4gent ag8er ages5e 1aggr ag5las ag1lo a1gn |
||||||
|
ag2ne 1agog a6g5und a1ha a1he ah5ein a4h3erh a1hi ahl1a ah1le ah4m3ar |
||||||
|
ahn1a a5ho ahra6 ahr5ab ah1re ah8rei ahren8s ahre4s3 ahr8ti ah1ru a1hu |
||||||
|
\n{ah8"o} ai3d2s ai1e aif6 a3inse ai4re. a5isch. ais8e a3ismu ais6n |
||||||
|
aiso6 a1j 1akad a4kade a1ke a1ki 1akko 5akro1 a5lal al5ans 3al8arm |
||||||
|
al8beb al8berw alb5la 3album al1c a1le a6l5e6be a4l3ein a8lel a8lerb |
||||||
|
a8lerh a6lert 5a6l5eth 1algi al4gli al3int al4lab al8lan al4l3ar |
||||||
|
alle3g a1lo a4l5ob al6schm al4the altist5 al4t3re 8a1lu alu5i a6lur |
||||||
|
alu3ta \n{a1l"a} a6mate 8ame. 5a6meise am6m5ei am6mum am2n ampf3a |
||||||
|
am6schw am2ta a1mu \n{a1m"a} a3nac a1nad anadi5e an3ako an3alp 3analy |
||||||
|
an3ame an3ara a1nas an5asti a1nat anat5s an8dent ande4s3 an1ec an5eis |
||||||
|
an1e2k 4aner. a6n5erd a8nerf a6n5erke 1anfa 5anfert \n{1anf"a} 3angab |
||||||
|
5angebo an3gli ang6lis an2gn 3angri ang5t6 \n{5anh"a} ani5g ani4ka |
||||||
|
an5i8on an1kl an6kno an4kro 1anl anma5c anmar4 3annah anne4s3 a1no |
||||||
|
5a6n1o2d 5a6n3oma 5a6nord 1anr an1sa 5anschl an4soz an1st 5anstal |
||||||
|
an1s2z 5antenn an1th \n{5anw"a} a5ny an4z3ed 5anzeig 5anzieh 3anzug |
||||||
|
\n{an1"a} \n{5an"as} \n{a1n"o} \n{an"o8d} a1os a1pa 3apfel a2ph1t |
||||||
|
\n{aph5"a6} a1pi 8apl apo1c apo1s a6poste a6poth 1appa ap1pr a1pr |
||||||
|
\n{a5p"a} \n{a3p"u} a1ra a4r3af ar3all 3arbei 2arbt ar1c 2a1re ar3ein |
||||||
|
ar2gl 2a1ri ari5es ar8kers ar6les ar4nan ar5o6ch ar1o2d a1rol ar3ony |
||||||
|
a8ror a3ros ar5ox ar6schl 8artei ar6t5ri a1ru a1ry 1arzt arz1w |
||||||
|
\n{ar8z"a} \n{ar"a8m} \n{ar"o6} \n{ar5"om} \n{ar1"u2} a1sa a6schec |
||||||
|
asch5l asch3m a6schn a3s4hi as1pa asp5l a8steb as5tev 1asth a6stoc |
||||||
|
a1str ast3re 8a1ta ata5c ata3la a6tapf ata5pl a1te a6teli aten5a |
||||||
|
ate5ran 6atf 6atg a1th at3hal 1athl 2a1ti 5atlant 3atlas 8atmus 6atn |
||||||
|
a1to a6t5ops ato6ra a6t5ort. 4a1tr a6t5ru at2t1h \n{at5t6h"a} 6a1tu |
||||||
|
atz1w \n{a1t"a} \n{a1t"u} au1a au6bre auch3a au1e aue4l 5aufent |
||||||
|
\n{3auff"u} 3aufga 1aufn auf1t 3auftr 1aufw 3auge. au4kle aule8s 6aum |
||||||
|
au8mar aum5p 1ausb 3ausd 1ausf 1ausg au8sin 3auss au4sta 1ausw 1ausz |
||||||
|
aut5eng au1th 1auto au\3e8 \c{au\9e8} a1v ave5r6a aver6i a1w a6wes a1x |
||||||
|
a2xia a6xio a1ya a1z azi5er. 8a\3 \c{8a\9} 1ba 8ba8del ba1la ba1na |
||||||
|
ban6k5r ba5ot bardi6n ba1ro basten6 bau3sp 2b1b bb6le b2bli 2b1c 2b1d |
||||||
|
1be be1a be8at. be1ch 8becht 8becke. be5el be1en bee8rei be5eta bef2 |
||||||
|
8beff be1g2 \n{beh"o8} bei1s 6b5eisen bei3tr b8el bel8o belu3t be3nac |
||||||
|
bend6o be6ners be6nerw be4nor ben4se6 bens5el \n{be1n"a} \n{be1n"u} |
||||||
|
be1o2 b8er. be1ra be8rac ber8gab. ber1r \n{be1r"u} bes8c bes5erh |
||||||
|
bes2p be5tha bet5sc be1un be1ur 8bex be6zwec 2b1f8 bfe6st5e 2b1g2 |
||||||
|
bga2s5 bge1 2b1h bhole6 1bi bi1bl b6ie bi1el bi1la \n{bil"a5} bi1na |
||||||
|
bi4nok bi5str bi6stu bi5tr bit4t5r b1j 2b1k2 \n{bk"u6} bl8 b6la. |
||||||
|
6b1lad 6blag 8blam 1blat b8latt 3blau. b6lav 3ble. b1leb b1led |
||||||
|
8b1leg 8b1leh 8bleid 8bleih 6b3lein blei3s ble4m3o 4blich b4lind |
||||||
|
8bling b2lio 5blit b4litz b1loh 8b1los 1blu 5blum 2blun blut3a blut5sc |
||||||
|
\n{3bl"a} \n{bl"as5c} \n{5bl"o} \n{3bl"u} \n{bl"u8sc} 2b1m 2b1n 1bo |
||||||
|
bo1ch bo5d6s boe5 8boff 8bonk bo1ra b1ort 2b1p2 b1q 1br brail6 brast8 |
||||||
|
bre4a b5red 8bref 8b5riem b6riga bro1s b1rup b2ruz \n{8br"oh} |
||||||
|
\n{br"os5c} 8bs b1sa b8sang b2s1ar b1sc bs3erl bs3erz b8sof b1s2p |
||||||
|
bst1h b3stru \n{b5st"a} b6sun 2b1t b2t1h 1bu bu1ie bul6k b8ure bu6sin |
||||||
|
6b1v 2b1w 1by1 by6te. 8b1z bzi1s \n{1b"a} \n{b5"a6s5} \n{1b"u} |
||||||
|
\n{b6"u5bere} \n{b"uge6} \n{b"ugel5e} \n{b"ur6sc} 1ca cag6 ca5la ca6re |
||||||
|
ca5y c1c 1ce celi4c celich5 ce1ro c8h 2ch. 1chae ch1ah ch3akt cha6mer |
||||||
|
8chanz 5chara 3chari 5chato 6chb 1chef 6chei ch3eil ch3eis 6cherkl |
||||||
|
6chf 4chh 5chiad 5chias 6chins 8chj chl6 5chlor 6ch2m 2chn6 ch8nie |
||||||
|
5cho. 8chob choi8d 6chp ch3ren ch6res \n{ch3r"u} 2chs 2cht cht5ha |
||||||
|
cht3hi 5chthon ch6tin 6chuh chu4la 6ch3unt chut6t 8chw 1ci ci5tr c2k |
||||||
|
2ck. ck1ei 4ckh ck3l ck3n ck5o8f ck1r 2cks ck5stra ck6s5u c2l 1c8o |
||||||
|
con6ne 8corb cos6t c3q 1c6r 8c1t 1cu 1cy \n{5c"a1} \n{c"o5} 1da. |
||||||
|
8daas 2dabg 8dabr 6dabt 6dabw 1dac da2gr 6d5alk 8d5amt dan6ce. |
||||||
|
dani5er dan8ker 2danl danla6 6dans 8danzi 6danzu d1ap da2r1a8 2d1arb |
||||||
|
d3arc dar6men 4d3art 8darz 1dat 8datm 2d1auf 2d1aus 2d1b 2d1c 2d1d |
||||||
|
d5de d3d2h \n{dd"amme8} 1de 2deal de5an de3cha de1e defe6 6deff 2d1ehr |
||||||
|
5d4eic de5isc de8lar del6s5e del6spr de4mag de8mun de8nep dene6r |
||||||
|
8denge. 8dengen de5o6d 2deol de5ram 8derdb der5ein de1ro der1r d8ers |
||||||
|
der5um de4s3am de4s3an de4sau de6sil de4sin de8sor de4spr de2su 8deul |
||||||
|
de5us. 2d1f df2l 2d1g 2d1h 1di dia5c di5ara dice5 di3chr di5ena di1gn |
||||||
|
di1la dil8s di1na 8dind 6dinf 4d3inh 2d1ins di5o6d di3p4t di8sen dis1p |
||||||
|
di5s8per di6s5to dis5tra di8tan di8tin d1j 6dje 2dju 2d1k 2d1l 2d1m |
||||||
|
2d1n6 dni6 dnje6 1do 6d5obe do6berf 6d5ony do3ran 6dord 2d1org dor4t3h |
||||||
|
do6ste 6doth dott8e 2d1p d5q dr4 1drah 8drak d5rand 6dre. 4drech |
||||||
|
d6reck 4d3reg 8d3reic d5reife 8drem 8d1ren 2drer 8dres. 6d5rh 1dria |
||||||
|
d1ric 8drind droi6 dro5x 1dru 8drut \n{dr"os5c} \n{1dr"u} \n{dr"u5b} |
||||||
|
\n{dr"u8sc} 2ds d1sa d6san dsat6 d1sc 5d6scha. 5dschik dse8e d8serg |
||||||
|
8dsl d1sp d4spak ds2po \n{d8sp"a} d1st \n{d1s"u} 2dt d1ta d1te d1ti |
||||||
|
d1to dt1s6 d1tu \n{d5t"a} 1du du5als du1b6 du1e duf4t3r 4d3uh du5ie |
||||||
|
8duml 8dumw 2d1und du8ni 6d5unt dur2c durch3 6durl 6dursa 8durt du1s |
||||||
|
du8schr 2d1v 2d1w dwa8l 2d1z \n{1d"a} \n{6d"ah} \n{8d"and} \n{d"a6r} |
||||||
|
\n{d"o8bl} \n{d5"ol} \n{d"or6fl} \n{d"o8sc} \n{d5"o4st} \n{d"os3te} |
||||||
|
\n{1d"u} ea4ben e1ac e1ah e1akt e1al. e5alf e1alg e5a8lin e1alk e1all |
||||||
|
e5alp e1alt e5alw e1am e1and ea6nim e1ar. e5arf e1ark e5arm e3art |
||||||
|
e5at. e6ate e6a5t6l e8ats e5att e6au. e1aus e1b e6b5am ebens5e |
||||||
|
eb4lie eb4ser eb4s3in e1che e8cherz e1chi ech3m 8ech3n ech1r ech8send |
||||||
|
ech4su e1chu eck5an e5cl e1d ee5a ee3e ee5g e1ei ee5isc eei4s3t |
||||||
|
ee6lend e1ell \n{ee5l"o} e1erd ee3r4e ee8reng eere6s5 \n{ee5r"a} |
||||||
|
ee6tat e1ex e1f e6fau e8fe8b 3effek ef3rom ege6ra eglo6si 1egy e1ha |
||||||
|
e6h5ach eh5ans e6hap eh5auf e1he e1hi ehl3a eh1le ehl5ein eh1mu ehn5ec |
||||||
|
e1ho ehr1a eh1re ehre6n eh1ri eh1ru ehr5um e1hu eh1w e1hy \n{e1h"a} |
||||||
|
\n{e1h"o} \n{e3h"ut} ei1a eia6s ei6bar eich3a eich5r ei4dar ei6d5ei |
||||||
|
ei8derf ei3d4sc ei1e 8eifen 3eifri 1eign eil1d ei6mab ei8mag ein1a4 |
||||||
|
ei8nat ei8nerh ei8ness ei6nete ein1g e8ini ein1k ei6n5od ei8nok ei4nor |
||||||
|
\n{e3ins"a} ei1o e1irr ei5ru ei8sab ei5schn ei6s5ent ei8sol ei4t3al |
||||||
|
eit3ar eit1h ei6thi ei8tho eit8samt ei6t5um e1j 1ekd e1ke e1ki e1k2l |
||||||
|
e1kn ekni4 e1la e2l1al 6elan e6lanf e8lanl e6l5ans el3arb el3arm |
||||||
|
e6l3art 5e6lasti e6lauge elbst5a e1le 6elef ele6h e6l5ehe e8leif |
||||||
|
e6l5einh 1elek e8lel 3eleme e6lemen e6lente el5epi e4l3err e6l5ersc |
||||||
|
elf2l elg2 e6l5ins ell8er 4e1lo e4l3ofe el8soh el8tent 5eltern e1lu |
||||||
|
elut2 \n{e1l"a} \n{e1l"u} em8dei em8meis 4emo emo5s 1emp1f 1empt 1emto |
||||||
|
e1mu emurk4 emurks5 \n{e1m"a} en5a6ben en5achs en5ack e1nad en5af |
||||||
|
en5all en3alt en1am en3an. en3ant en3anz en1a6p en1ar en1a6s 6e1nat |
||||||
|
en3auf en3aus en2ce enda6l end5erf end5erg en8dess 4ene. en5eck |
||||||
|
e8neff e6n5ehr e6n5eim en3eis 6enem. 6enen e4nent 4ener. e8nerd |
||||||
|
e6n3erf e4nerg 5energi e6n5erla en5ers e6nerst en5erw 6enes e6n5ess |
||||||
|
e2nex en3glo 2eni enni6s5 ennos4 enns8 e1no e6nober eno8f en5opf |
||||||
|
e4n3ord en8sers ens8kl en1sp ens6por en5t6ag enta5go en8terbu en6tid |
||||||
|
3entla ent5ric 5entwic 5entwu 1entz enu5i e3ny en8zan \n{en1"of} |
||||||
|
\n{e1n"os} \n{e1n"ug} eo1c e5o6fe e5okk e1on. e3onf e5onk e5onl e5onr |
||||||
|
e5opf e5ops e5or. e1ord e1org eo5r6h eo1t e1pa e8pee e6p5e6g ep5ent |
||||||
|
e1p2f e1pi 5epid e6pidem e1pl 5epos e6pos. ep4p3a e1pr \n{e1p"a} e1q |
||||||
|
e1ra. er5aal 8eraba e5rabel er5a6ben e5rabi er3abs er3ach era5e |
||||||
|
era5k6l er3all er3amt e3rand e3rane er3ans e5ranz. e1rap er3arc |
||||||
|
e3rari er3a6si e1rat erat3s er3auf e3raum 3erbse er1c e1re 4e5re. |
||||||
|
er3eck er5egg er5e2h 2erei e3rei. e8reine er5einr 6eren. e4r3enm |
||||||
|
4erer. e6r5erm er5ero er5erst e4r3erz er3ess \n{5erf"ul} er8gan. |
||||||
|
5ergebn er2g5h \n{5erg"anz} \n{5erh"ohu} 2e1ri eri5ak e6r5iat e4r3ind |
||||||
|
e6r5i6n5i6 er5ins e6r5int er5itio er1kl \n{3erkl"a} \n{5erl"os.} |
||||||
|
ermen6s er6nab 3ernst 6e1ro. e1rod er1o2f e1rog 6e3roi ero8ide e3rol |
||||||
|
e1rom e1ron e3rop8 e2r1or e1ros e1rot er5ox ersch4 5erstat er6t5ein |
||||||
|
er2t1h er5t6her 2e1ru eruf4s3 e4r3uhr er3ums e5rus 5erwerb e1ry er5zwa |
||||||
|
er3zwu \n{er"a8m} \n{er5"as} \n{er"o8} \n{e3r"os.} \n{e6r1"u2b} e1sa |
||||||
|
esa8b e8sap e6s5a6v e1sc esch4l ese1a es5ebe eserve5 e8sh es5ill |
||||||
|
es3int es4kop e2sl eso8b e1sp espei6s5 es2po es2pu 5essenz e6stabs |
||||||
|
e6staf e6st5ak est3ar e8stob e1str est5res es3ur e2sz \n{e1s"u} e1ta |
||||||
|
et8ag etari5e eta8ta e1te eten6te et5hal e5thel e1ti 1etn e1to e1tr |
||||||
|
et3rec e8tscha et8se et6tei et2th et2t1r e1tu etu1s et8zent et8zw |
||||||
|
\n{e1t"a} \n{e1t"o} \n{e1t"u} eu1a2 eu1e eue8rei eu5fe euin5 euk2 |
||||||
|
e1um. eu6nio e5unter eu1o6 eu5p 3europ eu1sp eu5str eu8zo e1v eval6s |
||||||
|
eve5r6en ever4i e1w e2wig ex1or 1exp 1extr ey3er. e1z \n{e1"a2} |
||||||
|
\n{e5"o8} \n{e1"u} e8\3es \c{e8\9es} fa6ch5i fade8 fa6del fa5el. |
||||||
|
fal6lo falt8e fa1na fan4gr 6fanl 6fap far6ba far4bl far6r5a 2f1art |
||||||
|
fa1sc fau8str fa3y 2f1b2 6f1c 2f1d 1fe 2f1eck fe6dr feh6lei f6eim |
||||||
|
8feins f5eis fel5en 8feltern 8femp fe5rant 4ferd. ferri8 fe8stof |
||||||
|
fe6str fe6stum fe8tag fet6ta fex1 2ff f1fa f6f5arm f5fe ffe5in ffe6la |
||||||
|
ffe8ler ff1f f1fla ff3lei ff4lie ff8sa ff6s5ta 2f1g2 fgewen6 4f1h 1fi |
||||||
|
fid4 fi3ds fieb4 fi1la fi8lei fil4m5a f8in. fi1na 8finf fi8scho fi6u |
||||||
|
6f1j 2f1k2 f8lanz fl8e 4f3lein 8flib 4fling f2lix 6f3lon 5flop 1flor |
||||||
|
\n{5f8l"ac} \n{3fl"ot} 2f1m 2f1n 1fo foh1 f2on fo6na 2f1op fo5ra |
||||||
|
for8mei for8str for8th for6t5r fo5ru 6f5otte 2f1p8 f1q fr6 f5ram |
||||||
|
1f8ran f8ra\3 \c{f8ra\9} f8re. frei1 5frei. f3reic f3rest f1rib |
||||||
|
8f1ric 6frig 1fris fro8na \n{fr"as5t} 2fs f1sc f2s1er f5str |
||||||
|
\n{fs3t"at} 2ft f1tak f1te ft5e6h ftere6 ft1h f1ti f5to f1tr ft5rad |
||||||
|
ft1sc ft2so f1tu ftwi3d4 ft1z 1fu 6f5ums 6funf fun4ka fu8\3end |
||||||
|
\c{fu8\9end} 6f1v 2f1w 2f1z \n{1f"a} \n{f"a1c} \n{8f"arm} \n{6f"aug} |
||||||
|
\n{f"a8\3} \n{\c{f"a8\9}} \n{f"ode3} \n{8f"of} \n{3f"or} \n{1f"u} |
||||||
|
\n{f"un4f3u} 1ga ga6bl 6gabw 8gabz g3a4der ga8ho ga5isc 4gak ga1la |
||||||
|
6g5amt ga1na gan5erb gan6g5a ga5nj 6ganl 8gansc 6garb 2g1arc 2g1arm |
||||||
|
ga5ro 6g3arti ga8sa ga8sc ga6stre 2g1atm 6g5auf gau5fr g5aus 2g1b g5c |
||||||
|
6gd g1da 1ge ge1a2 ge6an ge8at. ge1e2 ge6es gef2 8geff ge1g2l ge1im |
||||||
|
4g3eise geist5r gel8bra gelt8s \n{ge5l"o} ge8nin gen3k 6g5entf |
||||||
|
\n{ge3n"a} ge1or ge1ra ge6rab ger8au \n{8gerh"o} ger8ins ge1ro 6g5erz. |
||||||
|
\n{ge1r"a} \n{ge1r"u} ge1s ges2p ge5unt 4g3ex3 2g1f8 2g1g g1ha 6g1hei |
||||||
|
5ghel. g5henn 6g1hi g1ho 1ghr \n{g1h"o} 1gi gi5la gi8me. gi1na |
||||||
|
4g3ins gi3str g1j 2g1k 8gl. 1glad g5lag glan4z3 1glas 6glass 5glaub |
||||||
|
g3lauf 1gle. g5leb 3gleic g3lein 5gleis 1glem 2gler 8g3leu gli8a |
||||||
|
g2lie 3glied 1g2lik 1g2lim g6lio 1gloa 5glom 1glon 1glop g1los g4loss |
||||||
|
g5luf 1g2ly \n{1gl"u} 2g1m gn8 6gn. 1gna 8gnach 2gnah g1nas g8neu |
||||||
|
g2nie g3nis 1gno 8gnot 1go goe1 8gof 2gog 5gogr 6g5oh goni5e 6gonist |
||||||
|
go1ra 8gord 2g1p2 g1q 1gr4 g5rahm gra8m gra4s3t 6g1rec gre6ge 4g3reic |
||||||
|
g5reit 8grenn gri4e g5riem 5grif 2grig g5ring 6groh 2grot gro6\3 |
||||||
|
\c{gro6\9} 4grut 2gs gs1ab g5sah gs1ak gs1an gs8and gs1ar gs1au g1sc |
||||||
|
gs1ef g5seil gs5ein g2s1er gs1in g2s1o gso2r gs1pr g2s1u 2g1t g3te |
||||||
|
g2t1h 1gu gu5as gu2e 2gue. 6gued 4g3uh 8gums 6g5unt gu1s gut3h gu2tu |
||||||
|
4g1v 2g1w gy1n g1z \n{1g"a} \n{8g"a8m} \n{6g"arm} \n{1g"o} \n{1g"u} |
||||||
|
\n{6g"ub} 1haa hab8r ha8del hade4n 8hae ha5el. haf6tr 2hal. ha1la |
||||||
|
hal4b5a 6hale 8han. ha1na han6dr han6ge. 2hani h5anth 6hanz 6harb |
||||||
|
h3arbe h3arme ha5ro ha2t1h h1atm hau6san ha8\3 \c{ha8\9} h1b2 h1c h1d |
||||||
|
he2bl he3cho h3echt he5d6s 5heft h5e6he. hei8ds h1eif 2hein he3ism |
||||||
|
he5ist. heit8s3 hek6ta hel8lau 8helt he6mer 1hemm 6h1emp hen5end |
||||||
|
hen5klo hen6tri he2nu 8heo he8q her3ab he5rak her3an 4herap her3au |
||||||
|
h3erbi he1ro he8ro8b he4r3um her6z5er he4spe he1st heta6 het5am he5th |
||||||
|
heu3sc he1xa hey5e h1f2 h1g hgol8 h1h h1iat hie6r5i hi5kt hil1a2 |
||||||
|
hil4fr hi5nak hin4ta hi2nu hi5ob hirn5e hir6ner hi1sp hi1th hi5tr |
||||||
|
5hitz h1j h6jo h1k2 hlabb4 hla4ga hla6gr h5lai hl8am h1las h1la\3 |
||||||
|
\c{h1la\9} hl1c h1led h3lein h5ler. h2lif h2lim h8linf hl5int h2lip |
||||||
|
h2lit h4lor h3lose \n{h1l"as} hme5e h2nee h2nei hn3eig h2nel hne8n |
||||||
|
hne4p3f hn8erz h6netz h2nip h2nit h1nol hn5sp h2nuc h2nud h2nul hoch1 |
||||||
|
1hoh hoh8lei 2hoi ho4l3ar 1holz h2on ho1ra 6horg 5horn. ho3sl hos1p |
||||||
|
ho4spi h1p hpi6 h1q 6hr h1rai h8rank h5raum hr1c hrcre8 h1red h3reg |
||||||
|
h8rei. h4r3erb h8rert hrg2 h1ric hr5ins h2rom hr6t5erl hr2t1h hr6t5ra |
||||||
|
hr8tri h6rum hr1z hs3ach h6s5amt h1sc h6s5ec h6s5erl hs8erle h4sob |
||||||
|
h1sp h8spa\3 \c{h8spa\9} h8spel hs6po h4spun h1str h4s3tum hs3und |
||||||
|
\n{h1s"u} h5ta. h5tab ht3ac ht1ak ht3ang h5tanz ht1ar ht1at h5taub |
||||||
|
h1te h2t1ec ht3eff ht3ehe h4t3eif h8teim h4t3ein ht3eis h6temp h8tentf |
||||||
|
hte8ren \n{h6terf"u} h8tergr h4t3erh h6t5ersc h8terst h8tese h8tess |
||||||
|
h2t1eu h4t3ex ht1he ht5hu h1ti ht5rak hts3ah ht1sc ht6sex ht8sk ht8so |
||||||
|
h1tu htz8 \n{h5t"um} hub5l hu6b5r huh1l h5uhr. huld5a6 hu8lent |
||||||
|
\n{hu8l"a} h5up. h1v h5weib h3weis h1z \n{h"a8kl} \n{h"al8s} |
||||||
|
\n{h"ama8tu8} \n{h"a8sche.} \n{h"at1s} \n{h"au4s3c} \n{2h"o.} |
||||||
|
\n{2h"oe} \n{8h"oi} \n{h"o6s} \n{h"os5c} \n{h"uhne6} \n{h"ul4s3t} |
||||||
|
\n{h"utte8re} i5adn i1af i5ak. i1al. i1al1a i1alb i1ald i5alei i1alf |
||||||
|
i1alg i3alh i1alk i1all i1alp i1alr i1als i1alt i1alv i5alw i3alz |
||||||
|
i1an. ia5na i3and ian8e ia8ne8b i1ang i3ank i5ann i1ant i1anz i6apo |
||||||
|
i1ar. ia6rab i5arr i1as. i1asm i1ass i5ast. i1at. i5ats i1au i5azz |
||||||
|
i6b5eig i6b5eis ib2le i4blis i6brig i6b5unt \n{i6b"ub} i1che ich5ei |
||||||
|
i6cherb i1chi ich5ins ich1l ich3m ich1n i1cho icht5an icht3r i1chu |
||||||
|
ich1w ick6s5te ic5l i1d id3arm 3ideal ide8na 3ideol \n{ide5r"o} i6diot |
||||||
|
id5rec id1t ie1a ie6b5ar iebe4s3 ie2bl ieb1r ie8bra ie4bre \n{ie8b"a} |
||||||
|
ie2dr ie1e8 ie6f5ad ief5f ie2f1l ie4fro ief1t i1ei ie4l3ec ie8lei |
||||||
|
ie4lek i3ell i1en. i1end ien6e i3enf i5enn ien6ne. i1enp i1enr |
||||||
|
i5ensa ien8stal i5env i1enz ie5o ier3a4b ie4rap i2ere ie4rec ie6r5ein |
||||||
|
ie6r5eis ier8er i3ern. ie8rum ie8rund ie6s5che ie6tau ie8tert ie5the |
||||||
|
ie6t5ri i1ett ie5un iex5 2if i1fa if5ang i6fau if1fr if5lac i5f6lie |
||||||
|
i1fre ift5a if6t5r ig3art 2ige i8gess ig5he i5gla ig2ni i5go ig3rot |
||||||
|
ig3s2p i1ha i8ham i8hans i1he i1hi ih1n ih1r i1hu i8hum ih1w 8i1i ii2s |
||||||
|
ii2t i1j i1k i6kak i8kerz i6kes ik4ler i6k5unt 2il i5lac i1lag il3ans |
||||||
|
i5las i1lau il6auf i1le ile8h i8lel il2fl il3ipp il6l5enn i1lo ilt8e |
||||||
|
i1lu \n{i1l"a} i8mart imb2 i8mele i8mid imme6l5a i1mu \n{i1m"a} |
||||||
|
\n{i5m"o} ina5he i1nat in1au inau8s 8ind. in4d3an 5index ind2r 3indus |
||||||
|
i5nec i2n1ei i8nerw 3infek 1info 5ingeni ing5s6o 5inhab ini5er. 5inj |
||||||
|
\n{in8k"at} in8nan i1no inoi8d in3o4ku in5sau in1sp 5inspe 5instit |
||||||
|
5instru ins4ze 5intere 5interv in3the in5t2r i5ny \n{in"a2} \n{i1n"ar} |
||||||
|
\n{in1"as} \n{in"o8} \n{in5"od} \n{i1n"os} 2io io1a8 io1c iode4 io2di |
||||||
|
ioi8 i1ol. i1om. i1on. i5onb ion2s1 i1ont i5ops i5o8pt i1or. |
||||||
|
i3oral io3rat i5orc i1os. i1ot. i1o8x 2ip i1pa i1pi i1p2l i1pr i1q |
||||||
|
i1ra ir6bl i1re i1ri ir8me8d ir2m1o2 ir8nak i1ro ir5rho ir6schl |
||||||
|
ir6sch5r i5rus i5ry \n{i5r"a} i1sa i8samt i6sar i2s1au i8scheh i8schei |
||||||
|
isch5m isch3r \n{isch"a8} is8ele ise3ra i4s3erh is3err isi6de i8sind |
||||||
|
is4kop ison5e is6por i8s5tum i5sty \n{i5s"o} i1ta it5ab. i2t1a2m |
||||||
|
i8tax i1te i8tersc i1thi i1tho i5thr \n{it8h"a} i1ti i8ti8d iti6kl |
||||||
|
itmen4 i1to i8tof it3ran it3rau i1tri itri5o it1sc it2se it5spa it8tru |
||||||
|
i1tu it6z5erg it6z1w \n{i1t"a} \n{it"a6r5e} \n{it"at2} \n{it"ats5} |
||||||
|
\n{i1t"u} i1u iu6r 2i1v i6vad iva8tin i8vei i6v5ene i8verh i2vob i8vur |
||||||
|
i1w iwi2 i5xa i1xe i1z ize8n i8zir i6z5w \n{i"a8m} \n{i1"a6r} |
||||||
|
\n{i5"at.} \n{i5"av} \n{i1"o8} \n{i"u8} i6\35ers \c{i6\95ers} ja5la |
||||||
|
je2t3r 6jm 5jo jo5as jo1ra jou6l ju5cha jugen4 jugend5 jung5s6 ju1s |
||||||
|
\n{3j"a} 1ka 8kachs 8kakz ka1la kal5d kam5t ka1na 2kanl 8kapf ka6pl |
||||||
|
ka5r6a 6k3arbe ka1ro kar6p5f 4k3arti 8karz \n{ka1r"a} kasi5e ka6teb |
||||||
|
kat8ta kauf6s kau3t2 2k1b 2k1c 4k1d kehr6s kehrs5a 8keic 2k1eig 6k5ein |
||||||
|
6k5eis ke6lar ke8leis ke8lo 8kemp k5ente. k3entf 8k5ents 6kentz ke1ra |
||||||
|
k5erlau 2k1f8 2k1g 2k1h ki5fl 8kik king6s5 6kinh ki5os ki5sp ki5th |
||||||
|
\n{8ki8"o} 2k1k2 kl8 1kla 8klac k5lager kle4br k3leib 3kleid kle5isc |
||||||
|
4k3leit k3lek 6k5ler. 5klet 2klic 8klig k2lim k2lin 5klip 5klop k3lor |
||||||
|
\n{1kl"a} 2k1m kmani5e kn8 6kner k2ni \n{kn"a8} 1k2o ko1a2 ko6de. |
||||||
|
ko1i koi8t ko6min ko1op ko1or ko6pht ko3ra kor6d5er ko5ru ko5t6sc k3ou |
||||||
|
3kow 6k5ox 2k1p2 k1q 1kr8 4k3rad 2k1rec 4k3reic kre5ie 2krib 6krig |
||||||
|
2krip 6kroba 2ks k1sa k6sab ksal8s k8samt k6san k1sc k2s1ex k5spat |
||||||
|
k5spe k8spil ks6por k1spr kst8 k2s1uf 2k1t kta8l kt5a6re k8tein kte8re |
||||||
|
k2t1h k8tinf kt3rec kt1s 1ku ku1ch kuck8 k3uhr ku5ie kum2s1 kunfts5 |
||||||
|
kun2s kunst3 ku8rau ku4ro kurz1 ku1st 4kusti ku1ta ku8\3 \c{ku8\9} |
||||||
|
6k1v 2k1w ky5n 2k1z \n{1k"a} \n{k"a4m} \n{4k3"ami} \n{k"ase5} \n{1k"o} |
||||||
|
\n{k"o1c} \n{k"o1s} \n{1k"u} \n{k"u1c} \n{k"ur6sc} \n{k"u1s} 1la. |
||||||
|
8labf 8labh lab2r 2l1abs lach3r la8dr 5ladu 8ladv 6laff laf5t la2gn |
||||||
|
5laken 8lamb la6mer 5lampe. 2l1amt la1na 1land lan4d3a lan4d3r lan4gr |
||||||
|
8lanme 6lann 8lanw \n{6lan"a} 8lappa lap8pl lap6pr l8ar. la5ra lar4af |
||||||
|
la8rag la8ran la6r5a6s l3arbe la8rei 6larm. la8sa la1sc la8sta lat8i |
||||||
|
6l5atm 4lauss 4lauto 1law 2lb l8bab l8bauf l8bede l4b3ins l5blo |
||||||
|
lbst5an lbst3e 8lc l1che l8chert l1chi lch3m l5cho lch5w 6ld l4d3ei |
||||||
|
ld1re \n{l6d"ub} le2bl le8bre lecht6s5 led2r 6leff le4gas 1lehr lei6br |
||||||
|
le8inf 8leinn 5leistu 4lektr le6l5ers lemo2 8lemp l8en. 8lends |
||||||
|
6lendun le8nend len8erw 6l5ents 4l3entw 4lentz 8lenzy 8leoz 6lepi |
||||||
|
le6pip 8lepo 1ler l6er. 8lerbs 6l5erde le8reis le8rend le4r3er 4l3erg |
||||||
|
l8ergr 6lerkl 6l5erzie \n{8ler"o} 8lesel lesi5e le3sko le3tha let1s |
||||||
|
5leuc 4leuro leu4s3t le5xe 6lexp l1f 2l1g lgend8 l8gh lglie3 lglied6 |
||||||
|
6l1h 1li li1ar li1as 2lick li8dr li1en lien6n li8ers li8ert 2lie\3 |
||||||
|
\c{2lie\9} 3lig li8ga8b li1g6n li1l8a 8limb li1na 4l3indu lings5 |
||||||
|
4l3inh 6linj link4s3 4linkt 2lint 8linv lion5s6t 4lipp 5lipt 4lisam |
||||||
|
livi5e 6l1j 6l1k l8keim l8kj lk2l lko8f lkor8 lk2sa lk2se 6ll l1la |
||||||
|
ll3a4be l8labt ll8anl ll1b ll1c ll1d6 l1le l4l3eim l6l5eise ller3a |
||||||
|
l4leti l5lip l1lo ll3ort ll5ov ll6spr llte8 l1lu ll3urg \n{l1l"a} |
||||||
|
\n{l5l"u} \n{l6l"ub} 2l1m l6m5o6d 6ln l1na l1no 8lobl lo6br 3loch. |
||||||
|
l5o4fen 5loge. 5lohn 4l3ohr 1lok l2on 4l3o4per lo1ra 2l1ord 6lorg |
||||||
|
4lort lo1ru 1los. lo8sei 3losig lo6ve lowi5 6l1p lp2f l8pho l8pn |
||||||
|
lp4s3te l2pt l1q 8l1r 2ls l1sa l6sarm l1sc l8sec l6s5erg l4s3ers l8sh |
||||||
|
l5s6la l1sp ls4por ls2pu l1str l8suni \n{l1s"u} 2l1t lt5amp l4t3ein |
||||||
|
l5ten l6t5eng l6t5erp l4t3hei lt3her l2t1ho l6t5i6b lti1l \n{l8tr"o} |
||||||
|
lt1sc lt6ser lt4s3o lt5ums lu8br lu2dr lu1en8 8lu8fe luft3a luf8tr |
||||||
|
lu6g5r 2luh l1uhr lu5it 5luk 2l1umf 2l1umw 1lun 6l5u6nio 4l3unte lu5ol |
||||||
|
4lurg 6lurs l3urt lu4sto lu3str lu6st5re lu8su lu6tal lu6t5e6g lu8terg |
||||||
|
lu3the lu6t5or lu2t1r lu6\35 \c{lu6\95} l1v lve5r6u 2l1w 1ly lya6 |
||||||
|
6lymp ly1no l8zess l8zo8f l3zwei lz5wu \n{3l"and} \n{l"a5on} |
||||||
|
\n{l"a6sc} \n{l"at1s} \n{5l"auf} \n{2l"aug} \n{l"au6s5c} \n{l"a5v} |
||||||
|
\n{l1"ol} \n{1l"os} \n{l"o1\36t} \n{\c{l"o1\96t}} \n{6l1"ube} 1ma |
||||||
|
8mabg ma5chan mad2 ma5el 4magg mag8n ma1la ma8lau mal5d 8malde mali5e |
||||||
|
malu8 ma8lut 2m1amp 3man mand2 man3ds 8mangr mani5o 8m5anst 6mappa |
||||||
|
4m3arbe mar8kr ma1r4o mar8schm 3mas ma1sc \n{ma1t"o} 4m5auf ma5yo 2m1b |
||||||
|
mb6r 2m1c 2m1d \n{md6s"a} 1me me1ch me5isc 5meld mel8sa 8memp me5nal |
||||||
|
men4dr men8schl men8schw 8mentsp me1ra mer4gl me1ro 3mes me6s5ei me1th |
||||||
|
me8\3 \c{me8\9} 2m1f6 2m1g 2m1h 1mi mi1a mi6ale mi1la 2m1imm mi1na |
||||||
|
\n{mi5n"u} mi4s3an mit1h mi5t6ra 3mitt mitta8 mi6\35 \c{mi6\95} 6mj |
||||||
|
2m1k8 2m1l 2m1m m6mad m6m5ak m8menth m8mentw mme6ra m2mn mm5sp mm5ums |
||||||
|
mmut5s \n{m8m"an} m1n8 m5ni 1mo mo5ar mo4dr 8mof mo8gal mo4kla mol5d |
||||||
|
m2on mon8do mo4n3od mont8a 6m5ony mopa6 mo1ra mor8d5a mo1sc mo1sp 5mot |
||||||
|
moy5 2mp m1pa mpfa6 mpf3l mphe6 m1pi mpin6 m1pl mp2li m2plu mpo8ste |
||||||
|
m1pr \n{mpr"a5} mp8th mput6 mpu5ts \n{m1p"o} 8m1q 2m1r 2ms ms5au m1sc |
||||||
|
msch4l ms6po m3spri m1str 2m1t mt1ar m8tein m2t1h mt6se \n{mt8s"a} |
||||||
|
mu5e 6m5uh mumi1 1mun mun6dr muse5e mu1ta 2m1v mvol2 mvoll3 2m1w 1my |
||||||
|
2m1z \n{m"a6kl} \n{1m"an} \n{m"a1s} \n{m"a5tr} \n{m"au4s3c} \n{3m"a\3} |
||||||
|
\n{\c{3m"a\9}} \n{m"ob2} \n{6m"ol} \n{1m"u} \n{5m"un} \n{3m"ut} 1na. |
||||||
|
n5ab. 8nabn n1abs n1abz \n{na6b"a} na2c nach3e 3nacht 1nae na5el |
||||||
|
n1afr 1nag 1n2ah na8ha na8ho 1nai 6nair na4kol n1akt nal1a 8naly 1nama |
||||||
|
na4mer na1mn n1amp 8n1amt 5nanc nan6ce n1and n6and. 2n1ang 1nani |
||||||
|
1nann n1ans 8nanw 5napf. 1n2ar. na2ra 2n1arc n8ard 1nari n8ark |
||||||
|
6n1arm 5n6ars 2n1art n8arv 6natm nat6s5e 1naue 4nauf n3aug 5naui n5auk |
||||||
|
na5um 6nausb 6nauto 1nav 2nax 3naz 1na\3 \c{1na\9} n1b2 nbau5s n1c |
||||||
|
nche5e nch5m 2n1d nda8d n2d1ak nd5ans n2d1ei nde8lac ndel6sa n8derhi |
||||||
|
nde4se nde8stal n2dj ndnis5 n6d5or6t nd3rec nd3rot nd8samt nd6sau |
||||||
|
ndt1h n8dumd 1ne ne5as ne2bl 6n5ebn 2nec 5neei ne5en ne1g4l 2negy |
||||||
|
4n1ein 8neis 4n3e4lem 8nemb 2n1emp nen1a 6n5energ nen3k 8nentb |
||||||
|
4n3en3th 8nentl 8n5entn 8n5ents ne1ra ne5r8al ne8ras 8nerbi 6n5erde. |
||||||
|
nere5i6d nerfor6 \n{6n5erh"o} \n{8nerl"o} 2n1err n8ers. 6n5ertra |
||||||
|
2n1erz nesi3e net1h neu4ra neu5sc 8neu\3 \c{8neu\9} n1f nf5f nf2l |
||||||
|
nflei8 nf5lin nft8st n8g5ac ng5d ng8en nge8ram ngg2 ng1h n6glic ng3rip |
||||||
|
ng8ru ng2se4 ng2si n2g1um n1gy \n{n8g"al} n1h nhe6r5e 1ni ni1bl |
||||||
|
\n{ni5ch"a} ni8dee n6ie ni1en nie6s5te niet5h ni8etn 4n3i6gel n6ik |
||||||
|
ni1la 2n1imp ni5na 2n1ind 8ninf 6n5inh ni8nit 6n5inn 2n1ins 4n1int |
||||||
|
n6is ni3str ni1th ni1tr n1j n6ji n8kad nk5ans n1ke n8kerla n1ki nk5inh |
||||||
|
\n{n5kl"o} n1k2n n8k5not nk3rot \n{n8kr"u} nk5spo nk6t5r n8kuh |
||||||
|
\n{n6k"ub} n5l6 nli4mi n1m nmen4s n1na n8nerg nni5o n1no nn4t3ak nnt1h |
||||||
|
nnu1e n1ny \n{n1n"a} \n{n1n"o} \n{n1n"u} no5a no4b3la 4n3obs 2nobt |
||||||
|
noche8 no6die no4dis no8ia no5isc 6n5o6leu no4mal noni6er 2n1onk n1ony |
||||||
|
4n3o4per 6nopf 6nopti no3ra no4ram nor6da 4n1org 2n1ort n6os no1st |
||||||
|
8nost. no8tan no8ter noty6pe 6n5ox n1p2 n1q n1r \n{nr"os3} 6ns n1sac |
||||||
|
ns3ang n1sc n8self n8s5erf n8serg n6serk ns5erw n8sint n1s2pe n1spr |
||||||
|
n6s5tat. n5s6te. n6stob n1str n1ta n4t3a4go nt5anh nt3ark nt3art |
||||||
|
n1te nt3eis nte5n6ar nte8nei nter3a nte6rei nt1ha nt6har n3ther nt5hie |
||||||
|
n3thus n1ti nti1c n8tinh nti1t ntlo6b ntmen8 n1to nt3o4ti n1tr ntra5f |
||||||
|
ntra5ut nt8rea nt3rec nt8rep n4t3rin nt8rop n4t3rot \n{n4tr"u} nt1s |
||||||
|
nts6an nt2sk n1tu nt1z \n{n1t"a} \n{n1t"o} \n{n8t"ol} \n{n1t"u} 1nu |
||||||
|
nu1a nu5el nu5en 4n1uhr nu5ie 8numl 6n5ums 6n5umw 2n1und 6nuni 6n5unr |
||||||
|
2n1unt 2nup 2nu6r n5uri nu3skr nu5ta n1v 8n1w 1nys n1za n6zab n2z1ar |
||||||
|
n6zaus nzi4ga n8zof n6z5unt n1zw n6zwir \n{1n"ac} \n{5n"ae} \n{5n"ai} |
||||||
|
\n{n8"al} \n{n"a6m} \n{n"a6re} \n{n5"arz} \n{5n"aus} \n{n1"ol} |
||||||
|
\n{1n"ot} \n{n5"oz} \n{5n"u.} \n{6n1"u2b} \n{5n"u\3} \n{\c{5n"u\9}} |
||||||
|
o5ab. oa2l o8ala o1a2m o1an ob1ac obe4ra o6berh 5o4bers o4beru |
||||||
|
obe6ser 1obj o1bl o2bli ob5sk 3obst. ob8sta obst5re ob5sz o1che |
||||||
|
oche8b o8chec o3chi och1l och3m ocho8f o3chro och3to o3chu och1w o1d |
||||||
|
o2d1ag od2dr ode5i ode6n5e od1tr o5e6b o5e6der. oe8du o1ef o1e2l |
||||||
|
o1e2p o1er. o5e8x o1fa of8fan 1offi of8fin of6f5la o5fla o1fr 8o1g |
||||||
|
og2n o1ha o1he o6h5eis o1hi ohl1a oh1le oh4l3er 5ohm. oh2ni o1ho |
||||||
|
oh1re oh1ru o1hu oh1w o1hy \n{o1h"a} o5ia o1id. o8idi oi8dr o5ids |
||||||
|
o5isch. oiset6 o1ism o3ist. o5i6tu o1j o1k ok2l ok3lau \n{o8kl"a} |
||||||
|
1okta o1la old5am old5r o1le ole5in ole1r ole3u ol6gl ol2kl olk4s1 |
||||||
|
ol8lak ol8lauf. ol6lel ol8less o1lo ol1s ol6sk o1lu oly1e2 5olym |
||||||
|
o2mab om6an o8mau ombe4 o8merz om5sp o1mu o8munt \n{o1m"a} \n{o1m"o} |
||||||
|
o1na ona8m on1ax on8ent o6n5erb 8oni oni5er. on1k on6n5a6b o1no ono1c |
||||||
|
o4nokt 1ons onts8 \n{o1n"a} oo8f 1oog oo2pe oo2sa o1pa 3o4pera o3pfli |
||||||
|
opf3lo opf3r o1pi o1pl o2pli o5p6n op8pa op6pl o1pr o3p4ter 1opti |
||||||
|
\n{o1p"a} \n{o5p"o} o1q o1ra. o3rad o8radd 1oram o6rang o5ras o8rauf |
||||||
|
or5cha or4d3a4m or8dei or8deu 1ordn or4dos o1re o5re. ore2h o8r5ein |
||||||
|
ore5isc or6enn or8fla or8fli 1orga 5orgel. or2gl o1ri 5o6rient or8nan |
||||||
|
\n{or8n"a} o1ro or1r2h or6t5an or8tau or8tere o1rus o1ry \n{o1r"a} |
||||||
|
\n{or1"u2} o1sa osa3i 6ose o8serk o1sk o6ske o6ski os2kl os2ko os2kr |
||||||
|
osni5e o2s1o2d o3s4per o4stam o6stau o3stra ost3re osu6 o6s5ur o5s6ze |
||||||
|
o1ta ot3auf o6taus o1te o6terw o1th othe5u o2th1r o1ti o1to oto1a |
||||||
|
ot1re o1tri o1tro ot1sc o3tsu ot6t5erg ot2t3h ot2t5r \n{ot8t"o} o1tu |
||||||
|
ou3e ouf1 ou5f6l o5u6gr ou5ie ou6rar ou1t6a o1v o1wa o1we o6wer. o1wi |
||||||
|
owid6 o1wo o5wu o1xe oy5al. oy1e oy1i o5yo o1z oza2r 1o2zea ozo3is |
||||||
|
\n{o"o8} o\35elt \c{o\95elt} o\31t \c{o\91t} 3paa pa6ce 5pad pag2 1pak |
||||||
|
pa1la pa8na8t pani5el pa4nor pan1s2 1pap pap8s pa8rei par8kr paro8n |
||||||
|
par5o6ti part8e 5partei 3partn pas6sep pa4tha 1pau 6paug pau3sc p1b |
||||||
|
8p5c 4p1d 1pe 4peic pe5isc 2pek pen3k pen8to8 p8er pe1ra pere6 per5ea |
||||||
|
per5eb pe4rem 2perr per8ran 3pers 4persi \n{pe3r"u} pe4sta pet2s |
||||||
|
p2f1ec p4fei pf1f pf2l 5pflanz pf8leg pf3lei 2pft pf3ta p1g 1ph 2ph. |
||||||
|
2p1haf 6phb 8phd 6p5heit ph5eme 6phg phi6e 8phk 6phn p5holl pht2 |
||||||
|
ph3tha 4ph3the phu6 6phz pi1en pi5err pi1la pi1na 5pinse pioni8e 1pis |
||||||
|
pi1s2k pi1th p1k pl8 5pla p2lau 4plei p3lein 2pler 6p5les 2plig p6lik |
||||||
|
6p5ling p2liz plo8min 6p1m p1n 1p2o 8poh 5pol po8lan poly1 po3ny po1ra |
||||||
|
2porn por4t3h \n{po5r"o} 5poti p1pa p6p5ei ppe6la pp5f p2p1h p1pi pp1l |
||||||
|
ppp6 pp5ren pp1s \n{p5p"o} pr6 3preis 1pres 2p3rig 5prinz 1prob 1prod |
||||||
|
5prog pro8pt pro6t5a prote5i 8pro\3 \c{8pro\9} \n{pr"a3l} \n{1pr"as} |
||||||
|
\n{pr"ate4} \n{1pr"uf} p5schl 2pst 1p2sy p1t p8to8d pt1s 5p6ty 1pu |
||||||
|
pu1b2 2puc pu2dr puf8fr 6p5uh pun8s pu8rei pu5s6h pu1ta p1v p3w 5py |
||||||
|
py5l p1z \n{p"a6der} \n{p5"a6m} \n{p"a8nu} \n{8p"ar} \n{p"at5h} |
||||||
|
\n{p"at1s} qu6 1qui 8rabk ra6bla 3rable ra2br r1abt 6rabz ra4dan ra2dr |
||||||
|
5rafal ra4f3er ra5gla ra2g3n 6raha ral5am 5rald 4ralg ra8lins 2rall |
||||||
|
ral5t 8ramei r3anal r6and ran8der ran4dr 8ranf 6ranga 5rangi ran8gli |
||||||
|
r3angr rans5pa 8ranw r8anz. ra5or 6rapf ra5pl rap6s5er 2r1arb 1rarh |
||||||
|
r1arm ra5ro 2r1art 6r1arz ra8tei ra6t5he 6ratl ra4t3ro r5atta raue4n |
||||||
|
6raus. r5austa rau8tel raut5s ray1 r1b rb5lass r6bler rb4lie rbon6n |
||||||
|
r8brecht \n{rb6s5t"a} r8ces r1che rch1l rch3m rch3re rch3tr rch1w 8rd |
||||||
|
r1da r8dachs r8dap rda5ro rde5ins rdio5 r8dir rd3ost r1dr r8drau 1re. |
||||||
|
re1ak 3reakt re3als re6am. re1as 4reben re6bl rech5a r8edi re3er |
||||||
|
8reff 3refl 2reh 5reha r4ei. reich6s5 8reier 6reign re5imp 4r3eina |
||||||
|
6r3einb 6reing 6r5einn 6reinr 4r3eins r3eint reli3e 8r5elt 6rempf |
||||||
|
2remt ren5a6b ren8gl r3enni 1reno 5rente 4r3enth 8rentl 4r3entw 8rentz |
||||||
|
ren4zw re1on requi5 1rer rer4bl 6rerbs 4r3erd \n{8rerh"o} 8rerkl |
||||||
|
4r3erla \n{8rerl"o} 4r3erns \n{6r5ern"a} rer5o 6r5erreg r5ertr r5erwec |
||||||
|
\n{r5er"o} re2sa re8schm 2ress re5u8ni 6rewo 2r1ex r1f r8ferd rf4lie |
||||||
|
8r1g r8gah rge4bl rge5na rgest4 rg6ne r2gni2 r8gob r4g3ret rg8sel r1h8 |
||||||
|
r2hy 5rhyt ri1ar ri5cha rid2g r2ie rieg4s5 ri8ei ri1el ri6ele ri1en |
||||||
|
ri3er. ri5ers. ri6fan ri8fer ri8fr 1r2ig ri8kn ri5la \n{rim"a8} |
||||||
|
ri1na r8inde rin4ga rin6gr 1rinn 6rinner rino1 r8insp 4rinst |
||||||
|
\n{ri1n"a} ri5o6ch ri1o2d ri3o6st 2r1ir r2is ri3sko ri8spr \n{ri8st"u} |
||||||
|
ri5sv r2it 6r5i6tal ri5tr ri6ve. 8r1j 6rk r1ke rkehrs5 r1ki r3klin |
||||||
|
r1k2n rk3str rk4t3an rk6to r6kuh \n{rk"a4s3t} r1l r5li rline5a 6r1m |
||||||
|
r6manl rma4p r4m3aph r8minf r8mob rm5sa 2rn r1na rna8be r5ne rn2ei |
||||||
|
r6neif r6nex r6nh rn1k r1no r6n5oc rn1sp \n{r1n"a} \n{r1n"u} ro6bern |
||||||
|
6robs ro1ch 3rock. ro5de ro1e 4rofe ro8hert 1rohr ro5id ro1in ro5isc |
||||||
|
6rolym r2on 6roog ro6phan r3ort ro1s2p ro5s6w ro4tau ro1tr ro6ts 5rout |
||||||
|
r1p rpe8re rp2f r2ps r2pt r1q 2rr r1ra r1re rrer6 rr6hos \n{r5rh"o} |
||||||
|
r1ri r1ro rro8f rr8or rror5a r1ru r3ry \n{r1r"a} \n{r1r"o} \n{r1r"u} |
||||||
|
2r1s r6sab r4sanf rse6e rse5na r2sh r6ska r6ski rs2kl r8sko r2sl rs2p |
||||||
|
r6stauf r8sterw r8stran rswi3d4 r2sz 2r1t rt3art r8taut r5tei rt5eige |
||||||
|
r8tepe r4t3erh r8terla r4t3hei r5t6hu r4t3int rt5reif rt1sc rt6ser |
||||||
|
rt6s5o rt6s5u rt5und r8turt rube6 ru1en 1r4uf ruf4st ru1ie 2r1umg |
||||||
|
2r1uml 2rums run8der run4d5r 6rundz 6runf 8runs 2r1unt 2r1ur r6us |
||||||
|
ru6sta ru3str ru6tr 1ruts r1v rven1 rvi2c r1w r1x r1za rz5ac r6z5al |
||||||
|
r8z1ar r8zerd r6z5erf rz8erh rz4t3h r8zum \n{r"a4ste} \n{r"au8sc} |
||||||
|
\n{r1"of} \n{5r"ohr} \n{r"o5le} \n{3r"oll} \n{5r"omis} \n{r1"or} |
||||||
|
\n{r"o2sc} \n{3r"ump} 1sa. 1saa s3a4ben sa2bl 2s1abs 6s1abt 6sabw |
||||||
|
3sack. 6s3a4der 1saf sa1fa 4s1aff sa5fr 1sag 1sai sa1i2k1 4s1akt 1sal |
||||||
|
sa1la 4s3alpi 6salter salz3a 1sam s5anb san2c 1sand s5angeh 6sanl |
||||||
|
2s1ans 6s3antr 8s1anw s1ap s6aph 8sapo sap5p6 s8ar. 2s1arb 3sarg |
||||||
|
s1arm sa5ro 2s1art 6s1arz 1sas 1sat sat8a 2s1atl sa8tom 3s8aue s5auff |
||||||
|
sau5i s6aur 2s1aus 5s6ause 2s1b2 2sca s4ce 8sch. 3scha. 5schade |
||||||
|
3schaf 3schal sch5ame 8schanc 8schb 1sche 6schef 8schex 2schf 2schg |
||||||
|
2schh 1schi 2schk 5schlag 5schlu \n{6schm"a\3} \n{\c{6schm"a\9}} |
||||||
|
6schna\3 \c{6schna\9} 1scho 6schord 6schp 3schri 8schric 8schrig |
||||||
|
8schrou 6schs 2scht sch3ta sch3tr 1schu 8schunt 6schv 2schz \n{5sch"o} |
||||||
|
\n{5sch"u} 2sco scre6 6scu 2s1d 1se se5an se1ap se6ben se5ec see5i6g |
||||||
|
se3erl 8seff se6han se8hi \n{se8h"o} 6s5eid. 2s1eig s8eil 5sein. |
||||||
|
sei5n6e 6s5einh 3s8eit 3sel. se4lar selb4 6s3e4lem se8lerl 2s1emp |
||||||
|
sen3ac se5nec 6s5ents 4sentz s8er. se8reim ser5inn \n{8serm"a} |
||||||
|
8s5erzi \n{6ser"of} se1um 8sexa 6sexp 2s1f2 sfal8ler 2s3g2 sge5b2 s1h |
||||||
|
s8hew 5s6hip 5s4hop 1si 2siat si1b sicht6s 6s5i6dee siege6s5 si1en |
||||||
|
si5err si1f2 si1g2n si6g5r si8kau sik1i si4kin si2kl \n{si8k"u} si1la |
||||||
|
sil6br si1na 2s1inf sin5gh 2s1inh sinne6s5 2s1ins si5ru si5str 4s1j |
||||||
|
s1k2 6sk. 2skau skel6c skelch5 s6kele 1s2ki. 3s4kin. s6kiz s8kj |
||||||
|
6skn 2skow 3skrib 3skrip 2sku \n{8sk"u} s1l s8lal slei3t s4low 2s1m |
||||||
|
s1n 6sna 6snot 1so so1ch 2s1odo so4dor 6s5o4fen solo3 s2on so5of 4sope |
||||||
|
so1ra 2s1ord 4sorga sou5c so3un 4s3ox sp2 8spaa 5spal 1span 2spap |
||||||
|
s2pec s4peis 1spek s6perg 4spers s6pes 2s1pf 8sphi \n{1s2ph"a} 1spi |
||||||
|
spi4e 6s5pig 6spinse 2spis 2spla 2spol 5s6pom 6s5pos 6spoti 1spra |
||||||
|
3s8prec 6spreis 5spring 6sprob 1spru s2pul 1s2pur 6spy \n{5sp"an} |
||||||
|
\n{1sp"u} s1q 2s1r 2s1s2 sse8nu ssini6s ssoi6r 2st. 1sta 4stafe 2stag |
||||||
|
sta3la 6stale 4stalg 8stalk 8stamt 6st5anf 4stans 6stanw 6starb sta4te |
||||||
|
6staus 2stb 6stc 6std 1ste 4steil 3s2tel st3elb 8stemb 6steppi 8stese |
||||||
|
8stesse 6stf 2stg 2sth st1ha st3hei s8t1hi st1ho st5hu 1sti sti4el |
||||||
|
4stigm sti3na 6stind 4stinf sti8r 2stk 2stl 2stm 1sto 6stoll. 4st3ope |
||||||
|
6stopf. 6stord 6stp 5stra. 4strai 3s4tral 6s5traum 3stra\3 |
||||||
|
\c{3stra\9} 3strec 6s3tref 8streib 5streif 6streno 6stres 6strev |
||||||
|
5s6tria 6strig 5strik 8strisi 3s4troa s8troma st5rose 4struf 3strum |
||||||
|
\n{6str"ag} 2st1s6 2stt 1stu stu5a 4stuc 2stue 8stun. 2stv 2stw s2tyl |
||||||
|
6stz \n{1st"a} \n{8st"ag} \n{1st"o} \n{1st"u} \n{8st"uch} \n{4st"ur.} |
||||||
|
1su su2b1 3suc su1e su2fe su8mar 6sumfa 8sumk 2s1unt sup1p2 6s5u6ran |
||||||
|
6surte 2s1v 2s1w 1sy 8syl. sy5la syn1 sy2na syne4 s1z s4zend 5s6zene. |
||||||
|
8szu \n{1s"a} \n{6s5"and} \n{6s"augi} \n{6s"au\3} \n{\c{6s"au\9}} |
||||||
|
\n{5s"om} \n{2s1"u2b} \n{1s"uc} \n{s"u8di} \n{1s"un} \n{5s"u\3} |
||||||
|
\n{\c{5s"u\9}} taats3 4tab. taba6k ta8ban tab2l ta6bre 4tabs t3absc |
||||||
|
8tabz 6t3acht ta6der 6tadr tad6s tad2t 1tafe4 1tag ta6ga6 ta8gei |
||||||
|
tage4s tag6s5t tah8 tahl3 tai6ne. ta5ir. tak8ta tal3au 1tale ta8leng |
||||||
|
tal5ert 6t5a6mer 6tamp tampe6 2t1amt tan5d6a tan8dr tands5a tani5e |
||||||
|
6tanl 2tanr t3ans 8t5antr tanu6 t5anw 8tanwa tan8zw ta8rau 6tarbe |
||||||
|
1tari 2tark 2t1arm ta1ro 2tart t3arti 6tarz ta1sc ta6sien ta8stem |
||||||
|
ta8sto t5aufb 4taufn 8taus. 5tause 8tausf 6tausg t5ausl 2t1b2 2t1c |
||||||
|
t6chu 2t1d te2am tea4s te8ben 5techn 4teff te4g3re te6hau 2tehe te4hel |
||||||
|
2t1ehr te5id. teig5l 6teign tei8gr 1teil 4teinh t5einhe 4teis t5eisen |
||||||
|
8teiw te8lam te4lar 4telek 8telem te6man te6n5ag ten8erw ten5k tens4p |
||||||
|
ten8tro 4t3entw 8tentz te6pli 5teppi ter5a6b te3ral ter5au 8terbar |
||||||
|
t5erbe. 6terben 8terbs 4t3erbt t5erde. ter5ebe ter5ein te8rers terf4 |
||||||
|
\n{8terh"o} \n{6terkl"a} ter8nor ter6re. t8erscha t5e6sel te8stau |
||||||
|
t3euro te1xa tex3e 8texp tex6ta 2t1f2 2t1g2 2th. th6a 5tha. 2thaa |
||||||
|
6t1hab 6t5haf t5hah 8thak 3thal. 6thals 6t3hand 2t1hau 1the. 3t4hea |
||||||
|
t1heb t5heil t3heit t3helf 1theo 5therap 5therf 6t5herz 1thes 1thet |
||||||
|
5thi. 2t1hil t3him 8thir 3this t5hj 2th1l 2th1m th1n t5hob t5hof |
||||||
|
4tholz 6thopti 1thr6 4ths t1hum 1thy \n{4t1h"a} \n{2t1h"o} \n{t1h"u} |
||||||
|
ti1a2m ti1b tie6fer ti1en ti8gerz tig3l ti8kin ti5lat 1tilg t1ind |
||||||
|
tin4k3l ti3spa ti5str 5tite ti5tr ti8vel ti8vr 2t1j 2t1k2 2t1l tl8a |
||||||
|
2t1m8 2t1n 3tobe 8tobj to3cha 5tocht 8tock tode4 to8del to8du to1e |
||||||
|
6t5o6fen to1in toi6r 5toll. to8mene t2ons 2t1ony to4per 5topf. 6topt |
||||||
|
to1ra to1s to6ska tos2l 2toti to1tr t8ou 2t1p2 6t1q tr6 tra5cha |
||||||
|
tra8far traf5t 1trag tra6gl tra6gr t3rahm 1trai t6rans tra3sc tra6st |
||||||
|
3traue t4re. 2trec t3rech t8reck 6t1red t8ree 4t1reg 3treib 4treif |
||||||
|
8t3reis 8trepo tre6t5r t3rev 4t3rez 1trib t6rick tri6er 2trig t8rink |
||||||
|
tri6o5d trizi5 tro1a 3troc trocke6 troi8d tro8man. tro3ny 5tropf |
||||||
|
6t5rosa t5ro\3 \c{t5ro\9} 5trub 5trup trut5 \n{1tr"ag} \n{6t1r"oh} |
||||||
|
\n{5tr"ub} \n{tr"u3bu} \n{t1r"uc} \n{t1r"us} 2ts ts1ab t1sac tsa8d |
||||||
|
ts1ak t6s5alt ts1an ts1ar ts3auf t3schr \n{t5sch"a} tse6e tsee5i |
||||||
|
tsein6s ts3ent ts1er t8serf t4serk t8sh 5t6sik t4s3int ts5ort. |
||||||
|
t5s6por t6sprei t1st t6s5tanz ts1th t6stit t4s3tor 1t2sua t2s1uf |
||||||
|
t8sum. t2s1u8n t2s1ur 2t1t tt5eif tte6sa tt1ha tt8ret tt1sc tt8ser |
||||||
|
tt5s6z 1tuc tuch5a 1tu1e 6tuh t5uhr tu1i tu6it 1tumh 6t5umr 1tums |
||||||
|
8tumt 6tund 6tunf 2t1unt tu5ra tu6rau tu6re. tu4r3er 2t1v 2t1w 1ty1 |
||||||
|
ty6a ty8la 8tym 6ty6o 2tz tz5al tz1an tz1ar t8zec tzeh6 tzehn5 t6z5ei. |
||||||
|
t6zor t4z3um \n{t6z"au} \n{5t"ag} \n{6t"ah} \n{t5"alt} \n{t8"an} |
||||||
|
\n{t"are8} \n{8t"a8st} \n{6t"au\3} \n{\c{6t"au\9}} \n{t5"offen} |
||||||
|
\n{8t"o8k} \n{1t"on} \n{4t"ub} \n{t6"u5ber.} \n{5t"uch} \n{1t"ur.} |
||||||
|
u3al. u5alb u5alf u3alh u5alk u3alp u3an. ua5na u3and u5ans u5ar. |
||||||
|
ua6th u1au ua1y u2bab ubi5er. u6b5rit ubs2k \n{u5b"o} \n{u8b"ub} 2uc |
||||||
|
u1che u6ch5ec u1chi uch1l uch3m uch5n uch1r uch5to ucht5re u1chu uch1w |
||||||
|
uck1a uck5in u1d ud4a u1ei u6ela uene8 u6ep u1er uer1a ue8rerl uer5o |
||||||
|
u8esc u2est u8ev u1fa u2f1ei u4f3ent u8ferh uf1fr uf1l uf1ra uf1re |
||||||
|
\n{uf1r"a} \n{uf1r"u} uf1s2p uf1st uft1s u8gabt u8gad u6gap ugeb8 u8gn |
||||||
|
ugo3s4 u1ha u1he u1hi uh1le u1ho uh1re u1hu uh1w \n{u1h"a} \n{u1h"o} |
||||||
|
6ui ui5en u1ig u3ins uin8tes u5isch. u1j 6uk u1ke u1ki u1kl u8klu |
||||||
|
u1k6n u5ky u1la uld8se u1le ul8lac ul6lau ul6le6l ul6lo ulni8 u1lo |
||||||
|
ulo6i ult6a ult8e u1lu ul2vr \n{u1l"a} \n{u1l"o} 3umfan 5umlau umo8f |
||||||
|
um8pho u1mu umu8s \n{u5m"o} u1n1a un2al un6at unau2 6und. 5undein |
||||||
|
un4d3um 3undzw \n{und"u8} \n{un8d"ub} une2b un1ec une2h un3eis 3unfal |
||||||
|
\n{1unf"a} 5ungea \n{3ungl"u} ung2s1 \n{un8g"a} 1u2nif un4it un8kro |
||||||
|
unk5s u1no unpa2 uns2p unvol4 unvoll5 u5os. u1pa u1pi u1p2l u1pr |
||||||
|
up4s3t up2t1a u1q u1ra ur5abs ura8d ur5ah u6rak ur3alt u6rana u6r5ans |
||||||
|
u8rap ur5a6ri u8ratt u1re ur3eig ur8gri u1ri ur5ins 3urlau urmen6 |
||||||
|
ur8nan u1ro 3ursac ur8sau ur8sei ur4sk 3urtei u1ru uru5i6 uru6r u1ry |
||||||
|
ur2za \n{ur6z"a} \n{ur5"a6m} \n{u5r"o} \n{u1r"u} \n{ur"uck3} u1sa |
||||||
|
usa4gi u2s1ar u2s1au u8schec usch5wi u2s1ei use8kel u8sl u4st3a4b |
||||||
|
us3tau u3s4ter u2s1uf u8surn ut1ac u1tal uta8m u1tan ut1ar u1tas ut1au |
||||||
|
u1te u8teic u4tent u8terf u6terin u4t3hei ut5ho ut1hu u1ti utine5 |
||||||
|
uti6q u1to uto5c u1tr ut1sa ut1s6p ut6stro u1tu utz5w u1u u1v uve5n |
||||||
|
\n{uve3r4"a} u1w u1xe u5ya uy5e6 u1yi u2z1eh u8zerh \n{u5"o} u\3e6n |
||||||
|
\c{u\9e6n} u\3en5e \c{u\9en5e} 8vanb 6vang 6varb var8d va6t5a va8tei |
||||||
|
va2t1r 2v1b 6v5c 6vd 1ve 6ve5g6 ver1 ver5b verb8l ve2re2 verg8 ve2ru8 |
||||||
|
ve1s ve2s3p ve3xe 2v1f 2v1g 6v5h vi6el vie6w5 vi1g4 vi8leh vil6le. |
||||||
|
8vint vi1ru vi1tr 2v1k 2v1l 2v1m 4v5n 8vo8f voi6le vol8lend vol8li |
||||||
|
v2or1 vo2re vo8rin vo2ro 2v1p 8vra v6re 2v1s 2v1t 2v1v 4v3w 2v1z |
||||||
|
waffe8 wa6g5n 1wah wah8n wa5la wal8din wal6ta wan4dr 5ware wa8ru |
||||||
|
war4za 1was w5c w1d 5wech we6fl 1weg we8geng weg5h weg3l we2g1r |
||||||
|
weh6r5er 5weise weit3r wel2t welt3r we6rat 8werc 5werdu wer4fl 5werk. |
||||||
|
wer4ka wer8ku wer4ta wer8term we2sp we8stend we6steu we8str |
||||||
|
\n{we8st"o} wet8ta wich6s5t 1wid wi2dr wiede4 wieder5 wik6 wim6ma |
||||||
|
win4d3r 5wirt wisch5l 1wj 6wk 2w1l 8w1n wo1c woche6 wol6f wor6t5r 6ws2 |
||||||
|
w1sk 6w5t 5wunde. wun6gr wu1sc wu2t1 6w5w wy5a \n{w"arme5} \n{w"a1sc} |
||||||
|
1xag x1ak x3a4men 8xamt x1an 8x1b x1c 1xe. x3e4g 1xen xe1ro x1erz |
||||||
|
1xes 8xf x1g 8x1h 1xi 8xid xi8so 4xiste x1k 6x1l x1m 8xn 1xo 8x5o6d |
||||||
|
8x3p2 x1r x1s6 8x1t x6tak x8terf x2t1h 1xu xu1e x5ul 6x3w x1z 5ya. |
||||||
|
y5an. y5ank y1b y1c y6cha y4chia y1d yen6n y5ern y1g y5h y5in y1j |
||||||
|
y1k2 y1lak yl1al yla8m y5lax y1le y1lo y5lu y8mn ym1p2 y3mu y1na yno2d |
||||||
|
yn1t y1on. y1o4p y5ou ypo1 y1pr y8ps y1r yri3e yr1r2 y1s ys5iat ys8ty |
||||||
|
y1t y3w y1z \n{y"a8m} z5a6b zab5l 8za6d 1zah za5is 4z3ak 6z1am 5zange. |
||||||
|
8zanl 2z1ara 6z5as z5auf 3zaun 2z1b 6z1c 6z1d 1ze ze4dik 4z3eff 8zein |
||||||
|
zei4ta zei8ters ze6la ze8lec zel8th 4zemp 6z5engel zen8zin \n{8zerg"a} |
||||||
|
zer8i ze1ro zers8 zerta8 zer8tab zer8tag 8zerz ze8ste zeu6gr 2z1ex |
||||||
|
2z1f8 z1g 4z1h 1zi zi1en zi5es. 4z3imp zi1na 6z5inf 6z5inni zin6s5er |
||||||
|
8zinsuf zist5r zi5th zi1tr 6z1j 2z1k 2z1l 2z1m 6z1n 1zo zo6gl 4z3oh |
||||||
|
zo1on zor6na8 4z1p z5q 6z1r 2z1s8 2z1t z4t3end z4t3hei z8thi 1zu zu3al |
||||||
|
zu1b4 zu1f2 6z5uhr zun2a 8zunem zunf8 8zungl zu1o zup8fi zu1s8 zu1z |
||||||
|
2z1v zw8 z1wal 5zweck zwei3s z1wel z1wer z6werg 8z5wes 1zwi zwi1s |
||||||
|
6z1wo 1zy 2z1z zz8a zzi1s \n{1z"a} \n{1z"o} \n{6z"ol.} \n{z"o1le} |
||||||
|
\n{1z"u} \n{2z1"u2b} \n{"a1a6} \n{"ab1l} \n{"a1che} \n{"a3chi} |
||||||
|
\n{"ach8sc} \n{"ach8sp} \n{"a5chu} \n{"ack5a} \n{"ad1a} \n{"ad5era} |
||||||
|
\n{"a6d5ia} \n{"a1e} \n{"a5fa} \n{"af1l} \n{"aft6s} \n{"ag1h} |
||||||
|
\n{"ag3le} \n{"a6g5nan} \n{"ag5str} \n{"a1he} \n{"a1hi} \n{"ah1le} |
||||||
|
\n{"ah5ne} \n{1"ahnl} \n{"ah1re} \n{"ah5ri} \n{"ah1ru} \n{"a1hu} |
||||||
|
\n{"ah1w} \n{6"ai} \n{"a1isc} \n{"a6ische} \n{"a5ism} \n{"a5j} |
||||||
|
\n{"a1k} \n{"al1c} \n{"a1le} \n{"a8lei} \n{"al6schl} \n{"ami1e} |
||||||
|
\n{"am8n} \n{"am8s} \n{"a5na} \n{5"anderu} \n{"ane5i8} \n{"ang3l} |
||||||
|
\n{"ank5l} \n{"a1no} \n{"an6s5c} \n{"a1pa} \n{"ap6s5c} \n{3"aq} |
||||||
|
\n{"ar1c} \n{"a1re} \n{"are8m} \n{5"argern} \n{"ar6gl} \n{"a1ri} |
||||||
|
\n{3"armel} \n{"a1ro} \n{"art6s5} \n{"a1ru} \n{3"arztl} \n{"a5r"o} |
||||||
|
\n{"a6s5chen} \n{"asen8s} \n{"as1th} \n{"ata8b} \n{"a1te} \n{"ateri4} |
||||||
|
\n{"ater5it} \n{"a6thy} \n{"a1ti} \n{3"atk} \n{"a1to} \n{"at8schl} |
||||||
|
\n{"ats1p} \n{"a5tu} \n{"aub1l} \n{"au1e} \n{1"aug} \n{"au8ga} |
||||||
|
\n{"au5i} \n{"a1um.} \n{"a1us.} \n{1"au\3} \n{\c{1"au\9}} \n{"a1z} |
||||||
|
\n{"o1b} \n{"o1che} \n{"o5chi} \n{"och8stei} \n{"och8str} \n{"ocht6} |
||||||
|
\n{5"o6dem} \n{5"offn} \n{"o1he} \n{"oh1l8} \n{"oh1re} \n{"o1hu} |
||||||
|
\n{"o1is} \n{"o1ke} \n{1"o2ko} \n{1"ol.} \n{"ol6k5l} \n{"ol8pl} |
||||||
|
\n{"o1mu} \n{"o5na} \n{"onig6s3} \n{"o1no} \n{"o5o6t} \n{"opf3l} |
||||||
|
\n{"op6s5c} \n{"o1re} \n{"or8gli} \n{"o1ri} \n{"or8tr} \n{"o1ru} |
||||||
|
\n{5"osterr} \n{"o1te} \n{"o5th} \n{"o1ti} \n{"o1tu} \n{"o1v} \n{"o1w} |
||||||
|
\n{"owe8} \n{"o2z} \n{"ub6e2} \n{3"u4ber1} \n{"ub1l} \n{"ub1r} |
||||||
|
\n{5"u2bu} \n{"u1che} \n{"u1chi} \n{"u8ch3l} \n{"uch6s5c} \n{"u8ck} |
||||||
|
\n{"uck1a} \n{"uck5ers} \n{"ud1a2} \n{"u6deu} \n{"udi8t} \n{"u2d1o4} |
||||||
|
\n{"ud5s6} \n{"uge4l5a} \n{"ug1l} \n{"uh5a} \n{"u1he} \n{"u8heh} |
||||||
|
\n{"u6h5erk} \n{"uh1le} \n{"uh1re} \n{"uh1ru} \n{"u1hu} \n{"uh1w} |
||||||
|
\n{"u3k} \n{"u1le} \n{"ul4l5a} \n{"ul8lo} \n{"ul4ps} \n{"ul6s5c} |
||||||
|
\n{"u1lu} \n{"un8da} \n{"un8fei} \n{"unk5l} \n{"un8za} \n{"un6zw} |
||||||
|
\n{"u5pi} \n{"u1re} \n{"u8rei} \n{"ur8fl} \n{"ur8fr} \n{"ur8geng} |
||||||
|
\n{"u1ri} \n{"u1ro} \n{"ur8sta} \n{"ur8ster} \n{"u1ru} \n{"use8n} |
||||||
|
\n{"u8sta} \n{"u8stes} \n{"u6s5tete} \n{"u3ta} \n{"u1te} \n{"u1ti} |
||||||
|
\n{"ut8tr} \n{"u1tu} \n{"ut8zei} \n{"u1v} \31a8 \c{\91a8} 5\3a. |
||||||
|
\c{5\9a.} \38as \c{\98as} \31b8 \c{\91b8} \31c \c{\91c} \31d \c{\91d} |
||||||
|
1\3e \c{1\9e} \35ec \c{\95ec} 8\3e8g \c{8\9e8g} 8\3e8h \c{8\9e8h} |
||||||
|
2\31ei \c{2\91ei} 8\3em \c{8\9em} \31f8 \c{\91f8} \31g \c{\91g} \31h |
||||||
|
\c{\91h} 1\3i \c{1\9i} \31k \c{\91k} \31l \c{\91l} \31m \c{\91m} |
||||||
|
\3mana8 \c{\9mana8} \31n \c{\91n} \31o \c{\91o} \31p8 \c{\91p8} \35q |
||||||
|
\c{\95q} \31r \c{\91r} \31s2 \c{\91s2} \3st8 \c{\9st8} \31ta \c{\91ta} |
||||||
|
\31te \c{\91te} \3t3hei \c{\9t3hei} \31ti \c{\91ti} \35to \c{\95to} |
||||||
|
\31tr \c{\91tr} 1\3u8 \c{1\9u8} 6\35um \c{6\95um} \31v \c{\91v} \31w |
||||||
|
\c{\91w} \31z \c{\91z} |
||||||
|
}% |
||||||
|
\endgroup |
||||||
|
\relax\endinput |
||||||
|
% |
||||||
|
% ----------------------------------------------------------------- |
||||||
|
% |
||||||
|
% =============== Additional Documentation =============== |
||||||
|
% |
||||||
|
% |
||||||
|
% Older Versions of German Hyphenation Patterns: |
||||||
|
% ---------------------------------------------- |
||||||
|
% |
||||||
|
% All older versions of `ghyphen.tex' distributed as |
||||||
|
% |
||||||
|
% ghyphen.tex/germhyph.tex as of 1986/11/01 |
||||||
|
% ghyphen.min/ghyphen.max as of 1988/10/10 |
||||||
|
% ghyphen3.tex as of 1990/09/27 & 1991/02/13 |
||||||
|
% ghyph31.tex as of 1994/02/13 |
||||||
|
% |
||||||
|
% are out of date and it is recommended to replace them |
||||||
|
% with the new version `dehypht.tex' as of 1999/03/03. |
||||||
|
% |
||||||
|
% If you are using `ghyphen.min' (a minor version of `ghyphen') |
||||||
|
% because of limited trie memory space, try this version and if |
||||||
|
% the space is exceeded get a newer TeX implementation with |
||||||
|
% larger or configurable trie memory sizes. |
||||||
|
% |
||||||
|
% |
||||||
|
% |
||||||
|
% Trie Memory Requirements/Space for Hyphenation Patterns: |
||||||
|
% -------------------------------------------------------- |
||||||
|
% |
||||||
|
% To load this set of german hyphenation patterns the parameters |
||||||
|
% of TeX has to have at least these values: |
||||||
|
% |
||||||
|
% TeX 3.x: |
||||||
|
% IniTeX: trie_size >= 9733 trie_op_size >= 207 |
||||||
|
% VirTeX: trie_size >= 8375 trie_op_size >= 207 |
||||||
|
% |
||||||
|
% TeX 2.x: |
||||||
|
% IniTeX: trie_size >= 8675 trie_op_size >= 198 |
||||||
|
% VirTeX: trie_size >= 7560 trie_op_size >= 198 |
||||||
|
% |
||||||
|
% If you want to load more than one set of hyphenation patterns |
||||||
|
% (in TeX 3.x), the parameters have to be set to a value larger |
||||||
|
% than or equal to the sum of all required values for each set. |
||||||
|
% |
||||||
|
% |
||||||
|
% Setting Trie Memory Parameters: |
||||||
|
% ------------------------------- |
||||||
|
% |
||||||
|
% Some implementations allow the user to change the default value |
||||||
|
% of a set of the internal TeX parameters including the trie memory |
||||||
|
% size parameter specifying the used memory for the hyphenation |
||||||
|
% patterns. |
||||||
|
% |
||||||
|
% Web2c 7.x (Source), teTeX 0.9 (Unix, Amiga), fpTeX (Win32) |
||||||
|
% and newer: |
||||||
|
% The used memory size of the true is usually set high enough. |
||||||
|
% If needed set the size of the trie using the keyword `trie_size' |
||||||
|
% in the configuration file `texmf/web2c/texmf.cnf'. For details |
||||||
|
% see the included documentation. |
||||||
|
% |
||||||
|
% emTeX (OS/2, MS-DOS, Windows 3.x/9x/NT): |
||||||
|
% You can set the used memory size of the trie using the |
||||||
|
% `-mt<number>' option on the command line or in the |
||||||
|
% TEXOPTIONS environment variable. |
||||||
|
% |
||||||
|
% PasTeX (Amiga): |
||||||
|
% The values for the parameters can be set using the keywords |
||||||
|
% `triesize', `itriesize' and `trieopsize' in the configuration |
||||||
|
% file. |
||||||
|
% |
||||||
|
% others (binaries only): |
||||||
|
% See the documentation of the implementation if it is possible |
||||||
|
% and how to change these values without recompilation. |
||||||
|
% |
||||||
|
% others (with sources) |
||||||
|
% If the trie memory is too small, you have to recompile TeX |
||||||
|
% using larger values for `trie_size' and `trie_op_size'. |
||||||
|
% Modify the change file `tex.ch' and recompile TeX. |
||||||
|
% For details see the documentation included in the sources. |
||||||
|
% |
||||||
|
% |
||||||
|
% |
||||||
|
% Necessary Settings in TeX macro files: |
||||||
|
% -------------------------------------- |
||||||
|
% |
||||||
|
% \lefthyphenmin, \righthyphenmin: |
||||||
|
% You can set both parameters to 2. |
||||||
|
% |
||||||
|
% \lccode <char>: |
||||||
|
% To get correct hyphenation points within words containing |
||||||
|
% umlauts or \ss, it's necessary to assign values > 0 to the |
||||||
|
% appropriate \lccode <char> positions. |
||||||
|
% |
||||||
|
% These changes are _not_ done when reading this file and have to |
||||||
|
% be included in the language switching mechanism as is done in, |
||||||
|
% for example, `german.sty' (\lccode change for ^^Y = \ss in OT1, |
||||||
|
% \left-/\righthyphenmin settings). |
||||||
|
% |
||||||
|
% |
||||||
|
%% \CharacterTable |
||||||
|
%% {Upper-case \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 |
||||||
|
%% Lower-case \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 |
||||||
|
%% Digits \0\1\2\3\4\5\6\7\8\9 |
||||||
|
%% Exclamation \! Double quote \" Hash (number) \# |
||||||
|
%% Dollar \$ Percent \% Ampersand \& |
||||||
|
%% Acute accent \' Left paren \( Right paren \) |
||||||
|
%% Asterisk \* Plus \+ Comma \, |
||||||
|
%% Minus \- Point \. Solidus \/ |
||||||
|
%% Colon \: Semicolon \; Less than \< |
||||||
|
%% Equals \= Greater than \> Question mark \? |
||||||
|
%% Commercial at \@ Left bracket \[ Backslash \\ |
||||||
|
%% Right bracket \] Circumflex \^ Underscore \_ |
||||||
|
%% Grave accent \` Left brace \{ Vertical bar \| |
||||||
|
%% Right brace \} Tilde \~} |
||||||
|
%% |
||||||
|
\endinput |
||||||
|
%% |
||||||
|
%% End of file `dehypht.tex'. |
||||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,223 @@ |
|||||||
|
|
||||||
|
%%%%%%%%%%%%%%%%%%%% file ithyph.tex |
||||||
|
|
||||||
|
%%%%%%%%%%%%%%%%%%%%%%%%%%% file ithyph.tex %%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
||||||
|
% |
||||||
|
% Prepared by Claudio Beccari e-mail beccari@polito.it |
||||||
|
% |
||||||
|
% Dipartimento di Elettronica |
||||||
|
% Politecnico di Torino |
||||||
|
% Corso Duca degli Abruzzi, 24 |
||||||
|
% 10129 TORINO |
||||||
|
% |
||||||
|
% Copyright 1998, 2001 Claudio Beccari |
||||||
|
% |
||||||
|
% This program can be redistributed and/or modified under the terms |
||||||
|
% of the LaTeX Project Public License Distributed from CTAN |
||||||
|
% archives in directory macros/latex/base/lppl.txt; either |
||||||
|
% version 1 of the License, or any later version. |
||||||
|
% |
||||||
|
% \versionnumber{4.8d} \versiondate{2001/11/21} |
||||||
|
% |
||||||
|
% These hyphenation patterns for the Italian language are supposed to comply |
||||||
|
% with the Reccomendation UNI 6461 on hyphenation issued by the Italian |
||||||
|
% Standards Institution (Ente Nazionale di Unificazione UNI). No guarantee |
||||||
|
% or declaration of fitness to any particular purpose is given and any |
||||||
|
% liability is disclaimed. |
||||||
|
% |
||||||
|
% See comments and loading instructions at the end of the file after the |
||||||
|
% \endinput line |
||||||
|
% |
||||||
|
{\lccode`\'=`\' % Apostrophe has its own lccode so that it is treated |
||||||
|
% as a letter |
||||||
|
%>> 1998/04/14 inserted grouping |
||||||
|
% |
||||||
|
%\lccode23=23 % Compound word mark is a letter in encoding T1 |
||||||
|
%\def\W{^^W} % ^^W =\char23 = \char"17 =\char'27 |
||||||
|
% |
||||||
|
\patterns{ |
||||||
|
.a3p2n % After the Garzanti dictionary: a-pnea, a-pnoi-co,... |
||||||
|
.anti1 .anti3m2n |
||||||
|
.bio1 |
||||||
|
.ca4p3s |
||||||
|
.circu2m1 |
||||||
|
.di2s3cine |
||||||
|
%.e2x |
||||||
|
.fran2k3 |
||||||
|
.free3 |
||||||
|
.narco1 |
||||||
|
.opto1 |
||||||
|
.orto3p2 |
||||||
|
.para1 |
||||||
|
.poli3p2 |
||||||
|
.pre1 |
||||||
|
.p2s |
||||||
|
%.ri1a2 .ri1e2 .re1i2 .ri1o2 .ri1u2 |
||||||
|
.sha2re3 |
||||||
|
.tran2s3c .tran2s3d .tran2s3f .tran2s3l .tran2s3n .tran2s3p .tran2s3r .tran2s3t |
||||||
|
.su2b3lu .su2b3r |
||||||
|
.wa2g3n |
||||||
|
.wel2t1 |
||||||
|
a1ia a1ie a1io a1iu a1uo a1ya 2at. |
||||||
|
e1iu e2w |
||||||
|
o1ia o1ie o1io o1iu |
||||||
|
%u1u |
||||||
|
% |
||||||
|
%1\W0a2 1\W0e2 1\W0i2 1\W0o2 1\W0u2 |
||||||
|
'2 |
||||||
|
1b 2bb 2bc 2bd 2bf 2bm 2bn 2bp 2bs 2bt 2bv |
||||||
|
b2l b2r 2b. 2b'. 2b'' |
||||||
|
1c 2cb 2cc 2cd 2cf 2ck 2cm 2cn 2cq 2cs 2ct 2cz |
||||||
|
2chh c2h 2chb ch2r 2chn c2l c2r 2c. 2c'. 2c'' .c2 |
||||||
|
1d 2db 2dd 2dg 2dl 2dm 2dn 2dp d2r 2ds 2dt 2dv 2dw |
||||||
|
2d. 2d'. 2d'' .d2 |
||||||
|
1f 2fb 2fg 2ff 2fn f2l f2r 2fs 2ft 2f. 2f'. 2f'' |
||||||
|
1g 2gb 2gd 2gf 2gg g2h g2l 2gm g2n 2gp g2r 2gs 2gt |
||||||
|
2gv 2gw 2gz 2gh2t 2g. 2g'. 2g'' |
||||||
|
1h 2hb 2hd 2hh hi3p2n h2l 2hm 2hn 2hr 2hv 2h. 2h'. 2h'' |
||||||
|
1j 2j. 2j'. 2j'' |
||||||
|
1k 2kg 2kf k2h 2kk k2l 2km k2r 2ks 2kt 2k. 2k'. 2k'' |
||||||
|
1l 2lb 2lc 2ld 2l3f2 2lg l2h 2lk 2ll 2lm 2ln 2lp |
||||||
|
2lq 2lr 2ls 2lt 2lv 2lw 2lz 2l. 2l'. 2l'' |
||||||
|
1m 2mb 2mc 2mf 2ml 2mm 2mn 2mp 2mq 2mr 2ms 2mt 2mv 2mw |
||||||
|
2m. 2m'. 2m'' |
||||||
|
1n 2nb 2nc 2nd 2nf 2ng 2nk 2nl 2nm 2nn 2np 2nq 2nr |
||||||
|
2ns 2nt 2nv 2nz n2g3n 2nheit. 2n. 2n' 2n'' |
||||||
|
1p 2pd p2h p2l 2pn 3p2ne 2pp p2r 2ps 3p2sic 2pt 2pz 2p. 2p'. 2p'' |
||||||
|
1q 2qq 2q. 2q'. 2q'' |
||||||
|
1r 2rb 2rc 2rd 2rf r2h 2rg 2rk 2rl 2rm 2rn 2rp |
||||||
|
2rq 2rr 2rs 2rt rt2s3 2rv 2rx 2rw 2rz 2r. 2r'. 2r'' |
||||||
|
1s2 2shm 2s3s s4s3m 2s3p2n 2stb 2stc 2std 2stf 2stg 2stm 2stn |
||||||
|
2stp 2sts 2stt 2stv 2sz 4s. 4s'. 4s'' |
||||||
|
1t 2tb 2tc 2td 2tf 2tg t2h t2l 2tm 2tn 2tp t2r 2ts |
||||||
|
3t2sch 2tt 2tv 2tw t2z 2tzk 2tzs 2t. 2t'. 2t'' |
||||||
|
1v 2vc v2l v2r 2vv 2v. 2v'. 2v'' |
||||||
|
1w w2h wa2r 2w1y 2w. 2w'. 2w'' |
||||||
|
1x 2xt 2xw 2x. 2x'. 2x'' |
||||||
|
y1ou y1i |
||||||
|
1z 2zb 2zd 2zl 2zn 2zp 2zt 2zs 2zv 2zz 2z. 2z'. 2z'' .z2 |
||||||
|
}} % Pattern end |
||||||
|
|
||||||
|
\endinput |
||||||
|
|
||||||
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Information %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
||||||
|
|
||||||
|
|
||||||
|
LOADING THESE PATTERNS |
||||||
|
|
||||||
|
These patterns, as well as those for any other language, do not become |
||||||
|
effective until they are loaded in a special form into a format file; this |
||||||
|
task is performed by the TeX initializer; any TeX system has its own |
||||||
|
initializer with its special way of being activated. Before loading these |
||||||
|
patterns, then, it is necessary to read very carefully the instructions that |
||||||
|
come with your TeX system. |
||||||
|
|
||||||
|
Here I describe how to load the patterns with the freeware TeX system named |
||||||
|
MiKTeX version 2.x for Windows 9x, NT, 2000, XP; with minor changes the |
||||||
|
whole procedure is applicable with other TeX systems, but the details must |
||||||
|
be deduced from your TeX system documentation at the section/chapter "How to |
||||||
|
build or to rebuild a format file". |
||||||
|
|
||||||
|
With MikTeX: |
||||||
|
|
||||||
|
a) copy this file and replace the existing file ithyph.tex in the directory |
||||||
|
\texmf\tex\generic\hyphen if the existing one has an older version date |
||||||
|
and number. |
||||||
|
b) select Start|Programs|MiKTeX|MiKTeX options. |
||||||
|
c) in the Language tab add a check mark to the line concerning the Italian |
||||||
|
language. |
||||||
|
d) in the Geneal tab click "Update format files". |
||||||
|
e) That's all! |
||||||
|
|
||||||
|
For the activation of these patterns with the specific Italian typesetting |
||||||
|
features, use the babel package as this: |
||||||
|
|
||||||
|
\documentclass{article} % Or whatever other class |
||||||
|
\usepackage[italian]{babel} |
||||||
|
... |
||||||
|
\begin{document} |
||||||
|
... |
||||||
|
\end{document} |
||||||
|
|
||||||
|
|
||||||
|
ON ITALIAN HYPHENATION |
||||||
|
|
||||||
|
I have been working on patterns for the Italian language since 1987; in 1992 |
||||||
|
I published |
||||||
|
|
||||||
|
C. Beccari, "Computer aided hyphenation for Italian and Modern |
||||||
|
Latin", TUG vol. 13, n. 1, pp. 23-33 (1992) |
||||||
|
|
||||||
|
which contained a set of patterns that allowed hyphenation for both Italian |
||||||
|
and Latin; a slightly modified version of the patterns published in the |
||||||
|
above paper is contained in LAHYPH.TEX available on the CTAN archives. |
||||||
|
|
||||||
|
From the above patterns I extracted the minimum set necessary for |
||||||
|
hyphenating Italian that was made available on the CTAN archives with the |
||||||
|
name ITHYPH.tex the version number 3.5 on the 16th of August 1994. |
||||||
|
|
||||||
|
The original pattern set required 37 ops; being interested in a local |
||||||
|
version of TeX/LaTeX capable of dealing with half a dozen languages, I |
||||||
|
wanted to reduce memory occupation and therefore the number of ops. |
||||||
|
|
||||||
|
Th new version (4.0 released in 1996) of ITHYPH.TEX is much simpler than |
||||||
|
version 3.5 and requires just 29 ops while it retains all the power of |
||||||
|
version 3.5; it contains many more new patterns that allow to hyphenate |
||||||
|
unusual words that generally have a root borrowed from a foreign language. |
||||||
|
Updated versions 4.x contain minor additions and the number of ops is |
||||||
|
increased to 30 (version 4.7 of 1998/06/01). |
||||||
|
|
||||||
|
This new pattern set has been tested with the same set of difficult Italian |
||||||
|
words that was used to test version 3.5 and it yields the same results (a |
||||||
|
part a minor change that was deliberately introduced so as to reduce the |
||||||
|
typographical hyphenation with hyathi, since hyphenated hyathi are not |
||||||
|
appreciated by Italian readers). A new enlarged word set for testing |
||||||
|
purposes gets correct hyphen points that were missed or wrongly placed with |
||||||
|
version 3.5, although no error had been reported, because such words are of |
||||||
|
very specialized nature and are seldom used. |
||||||
|
|
||||||
|
As the previous version, this new set of patterns does not contain any |
||||||
|
accented character so that the hyphenation algorithm behaves properly in |
||||||
|
both cases, that is with cm and with dc/ec fonts. With LaTeXe terminology |
||||||
|
the difference is between OT1 and T1 encodings; with the former encoding |
||||||
|
fonts do not contain accented characters, while with the latter accented |
||||||
|
characters are present and sequences such as \`a map directly to slot "E0 |
||||||
|
that contains "agrave". |
||||||
|
|
||||||
|
Of course if you use dc/ec fonts (or any other real or virtual font with T1 |
||||||
|
encoding) you get the full power of the hyphenation algorithm, while if you |
||||||
|
use cm fonts (or any other real or virtual font with OT1 encoding) you miss |
||||||
|
some possible break points; this is not a big inconvenience in Italian |
||||||
|
because: |
||||||
|
|
||||||
|
1) The Regulation UNI 6015 on accents specifies that compulsory accents |
||||||
|
appear only on the ending vowel of oxitone words; this means that it is |
||||||
|
almost indifferent to have or to miss the dc/ec fonts because the only |
||||||
|
difference consists in how TeX evaluates the end of the word; in practice |
||||||
|
if you have these special facilities you get "qua-li-t\`a", while if you |
||||||
|
miss them, you get "qua-lit\`a" (assuming that \righthyphenmin > 1). |
||||||
|
|
||||||
|
2) Optional accents are so rare in Italian, that if you absolutely want to |
||||||
|
use them in those rare instances, and you miss the T1 encoding |
||||||
|
facilities, you should also provide explicit discretionary hyphens as in |
||||||
|
"s\'e\-gui\-to". |
||||||
|
|
||||||
|
There is no explicit hyphenation exception list because these patterns |
||||||
|
proved to hyphenate correctly a very large set of words suitably chosen in |
||||||
|
order to test them in the most heavy circumstances; these patterns were used |
||||||
|
in the preparation of a number of books and no errors were discovered. |
||||||
|
|
||||||
|
Nevertheless if you frequently use technical terms that you want hyphenated |
||||||
|
differently from what is normally done (for example if you prefer |
||||||
|
etymological hyphenation of prefixed and/or suffixed words) you should |
||||||
|
insert a specific hyphenation list in the preamble of your document, for |
||||||
|
example: |
||||||
|
|
||||||
|
\hyphenation{su-per-in-dut-to-re su-per-in-dut-to-ri} |
||||||
|
|
||||||
|
Should you find any word that gets hyphenated in a wrong way, please, AFTER |
||||||
|
CHECKING ON A RELIABLE MODERN DICTIONARY, report to the author, preferably |
||||||
|
by e-mail. |
||||||
|
|
||||||
|
|
||||||
|
Happy multilingual typesetting ! |
||||||
@ -0,0 +1,180 @@ |
|||||||
|
# patch.tcl -- |
||||||
|
# |
||||||
|
# Application of a diff -ruN patch to a directory tree. |
||||||
|
# |
||||||
|
# Copyright (c) 2019 Christian Gollwitzer <auriocus@gmx.de> |
||||||
|
# with tweaks by Andreas Kupries |
||||||
|
# - Factored patch parsing into a helper |
||||||
|
# - Replaced `puts` with report callback. |
||||||
|
|
||||||
|
package require Tcl 8.5 |
||||||
|
package provide textutil::patch 0.1 |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
|
||||||
|
namespace eval ::textutil::patch { |
||||||
|
namespace export apply |
||||||
|
namespace ensemble create |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
|
||||||
|
proc ::textutil::patch::apply {dir striplevel patch reportcmd} { |
||||||
|
set patchdict [Parse $dir $striplevel $patch] |
||||||
|
|
||||||
|
# Apply, now that we have parsed the patch. |
||||||
|
dict for {fn hunks} $patchdict { |
||||||
|
Report apply $fn |
||||||
|
if {[catch {open $fn} fd]} { |
||||||
|
set orig {} |
||||||
|
} else { |
||||||
|
set orig [split [read $fd] \n] |
||||||
|
} |
||||||
|
close $fd |
||||||
|
|
||||||
|
set patched $orig |
||||||
|
|
||||||
|
set fail false |
||||||
|
set already_applied false |
||||||
|
set hunknr 1 |
||||||
|
foreach hunk $hunks { |
||||||
|
dict with hunk { |
||||||
|
set oldend [expr {$oldstart+[llength $oldcode]-1}] |
||||||
|
set newend [expr {$newstart+[llength $newcode]-1}] |
||||||
|
# check if the hunk matches |
||||||
|
set origcode [lrange $orig $oldstart $oldend] |
||||||
|
if {$origcode ne $oldcode} { |
||||||
|
set fail true |
||||||
|
# check if the patch is already applied |
||||||
|
set origcode_applied [lrange $orig $newstart $newend] |
||||||
|
if {$origcode_applied eq $newcode} { |
||||||
|
set already_applied true |
||||||
|
Report fail-already $fn $hunknr |
||||||
|
} else { |
||||||
|
Report fail $fn $hunknr $oldcode $origcode |
||||||
|
} |
||||||
|
break |
||||||
|
} |
||||||
|
# apply patch |
||||||
|
set patched [list \ |
||||||
|
{*}[lrange $patched 0 $newstart-1] \ |
||||||
|
{*}$newcode \ |
||||||
|
{*}[lrange $orig $oldend+1 end]] |
||||||
|
} |
||||||
|
incr hunknr |
||||||
|
} |
||||||
|
|
||||||
|
if {!$fail} { |
||||||
|
# success - write the result back |
||||||
|
set fd [open $fn w] |
||||||
|
puts -nonewline $fd [join $patched \n] |
||||||
|
close $fd |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
|
||||||
|
proc ::textutil::patch::Report args { |
||||||
|
upvar 1 reportcmd reportcmd |
||||||
|
uplevel #0 [list {*}$reportcmd {*}$args] |
||||||
|
## |
||||||
|
# apply $fname |
||||||
|
# fail-already $fname $hunkno |
||||||
|
# fail $fname $hunkno $expected $seen |
||||||
|
## |
||||||
|
} |
||||||
|
|
||||||
|
proc ::textutil::patch::Parse {dir striplevel patch} { |
||||||
|
set patchlines [split $patch \n] |
||||||
|
set inhunk false |
||||||
|
set oldcode {} |
||||||
|
set newcode {} |
||||||
|
set n [llength $patchlines] |
||||||
|
|
||||||
|
set patchdict {} |
||||||
|
for {set lineidx 0} {$lineidx < $n} {incr lineidx} { |
||||||
|
set line [lindex $patchlines $lineidx] |
||||||
|
if {[string match ---* $line]} { |
||||||
|
# a diff block starts. Current line should be |
||||||
|
# --- oldfile date time TZ |
||||||
|
# Next line should be |
||||||
|
# +++ newfile date time TZ |
||||||
|
set in $line |
||||||
|
incr lineidx |
||||||
|
set out [lindex $patchlines $lineidx] |
||||||
|
|
||||||
|
if {![string match ---* $in] || ![string match +++* $out]} { |
||||||
|
#puts $in |
||||||
|
#puts $out |
||||||
|
return -code error "Patch not in unified diff format, line $lineidx $in $out" |
||||||
|
} |
||||||
|
|
||||||
|
# the quoting is compatible with list |
||||||
|
lassign $in -> oldfile |
||||||
|
lassign $out -> newfile |
||||||
|
|
||||||
|
set fntopatch [file join $dir {*}[lrange [file split $oldfile] $striplevel end]] |
||||||
|
set inhunk false |
||||||
|
#puts "Found diffline for $fntopatch" |
||||||
|
continue |
||||||
|
} |
||||||
|
|
||||||
|
# state machine for parsing the hunks |
||||||
|
set typechar [string index $line 0] |
||||||
|
set codeline [string range $line 1 end] |
||||||
|
switch $typechar { |
||||||
|
@ { |
||||||
|
if {![regexp {@@\s+\-(\d+),(\d+)\s+\+(\d+),(\d+)\s+@@} $line \ |
||||||
|
-> oldstart oldlen newstart newlen]} { |
||||||
|
return code -error "Erroneous hunk in line $lindeidx, $line" |
||||||
|
} |
||||||
|
# adjust line numbers for 0-based indexing |
||||||
|
incr oldstart -1 |
||||||
|
incr newstart -1 |
||||||
|
#puts "New hunk" |
||||||
|
set newcode {} |
||||||
|
set oldcode {} |
||||||
|
set inhunk true |
||||||
|
} |
||||||
|
- { # line only in old code |
||||||
|
if {$inhunk} { |
||||||
|
lappend oldcode $codeline |
||||||
|
} |
||||||
|
} |
||||||
|
+ { # line only in new code |
||||||
|
if {$inhunk} { |
||||||
|
lappend newcode $codeline |
||||||
|
} |
||||||
|
} |
||||||
|
" " { # common line |
||||||
|
if {$inhunk} { |
||||||
|
lappend oldcode $codeline |
||||||
|
lappend newcode $codeline |
||||||
|
} |
||||||
|
} |
||||||
|
default { |
||||||
|
# puts "Junk: $codeline"; |
||||||
|
continue |
||||||
|
} |
||||||
|
} |
||||||
|
# test if the hunk is complete |
||||||
|
if {[llength $oldcode]==$oldlen && [llength $newcode]==$newlen} { |
||||||
|
set hunk [dict create \ |
||||||
|
oldcode $oldcode \ |
||||||
|
newcode $newcode \ |
||||||
|
oldstart $oldstart \ |
||||||
|
newstart $newstart] |
||||||
|
#puts "hunk complete: $hunk" |
||||||
|
set inhunk false |
||||||
|
dict lappend patchdict $fntopatch $hunk |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
return $patchdict |
||||||
|
} |
||||||
|
|
||||||
|
# # ## ### ##### ######## ############# ##################### |
||||||
|
return |
||||||
@ -0,0 +1,91 @@ |
|||||||
|
# repeat.tcl -- |
||||||
|
# |
||||||
|
# Emulation of string repeat for older |
||||||
|
# revisions of Tcl. |
||||||
|
# |
||||||
|
# Copyright (c) 2000 by Ajuba Solutions. |
||||||
|
# Copyright (c) 2001-2006 by Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||||
|
# |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: repeat.tcl,v 1.1 2006/04/21 04:42:28 andreas_kupries Exp $ |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requirements |
||||||
|
|
||||||
|
package require Tcl 8.2- |
||||||
|
|
||||||
|
namespace eval ::textutil::repeat {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
|
||||||
|
namespace eval ::textutil::repeat { |
||||||
|
variable HaveBuiltin [expr {![catch {string repeat a 1}]}] |
||||||
|
} |
||||||
|
|
||||||
|
if {0} { |
||||||
|
# Problems with the deactivated code: |
||||||
|
# - Linear in 'num'. |
||||||
|
# - Tests for 'string repeat' in every call! |
||||||
|
# (Ok, just the variable, still a test every call) |
||||||
|
# - Fails for 'num == 0' because of undefined 'str'. |
||||||
|
|
||||||
|
proc textutil::repeat::StrRepeat { char num } { |
||||||
|
variable HaveBuiltin |
||||||
|
if { $HaveBuiltin == 0 } then { |
||||||
|
for { set i 0 } { $i < $num } { incr i } { |
||||||
|
append str $char |
||||||
|
} |
||||||
|
} else { |
||||||
|
set str [ string repeat $char $num ] |
||||||
|
} |
||||||
|
return $str |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {$::textutil::repeat::HaveBuiltin} { |
||||||
|
proc ::textutil::repeat::strRepeat {char num} { |
||||||
|
return [string repeat $char $num] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::textutil::repeat::blank {n} { |
||||||
|
return [string repeat " " $n] |
||||||
|
} |
||||||
|
} else { |
||||||
|
proc ::textutil::repeat::strRepeat {char num} { |
||||||
|
if {$num <= 0} { |
||||||
|
# No replication required |
||||||
|
return "" |
||||||
|
} elseif {$num == 1} { |
||||||
|
# Quick exit for recursion |
||||||
|
return $char |
||||||
|
} elseif {$num == 2} { |
||||||
|
# Another quick exit for recursion |
||||||
|
return $char$char |
||||||
|
} elseif {0 == ($num % 2)} { |
||||||
|
# Halving the problem results in O (log n) complexity. |
||||||
|
set result [strRepeat $char [expr {$num / 2}]] |
||||||
|
return "$result$result" |
||||||
|
} else { |
||||||
|
# Uneven length, reduce problem by one |
||||||
|
return "$char[strRepeat $char [incr num -1]]" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::textutil::repeat::blank {n} { |
||||||
|
return [strRepeat " " $n] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Data structures |
||||||
|
|
||||||
|
namespace eval ::textutil::repeat { |
||||||
|
namespace export strRepeat blank |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide textutil::repeat 0.7 |
||||||
@ -0,0 +1,176 @@ |
|||||||
|
# split.tcl -- |
||||||
|
# |
||||||
|
# Various ways of splitting a string. |
||||||
|
# |
||||||
|
# Copyright (c) 2000 by Ajuba Solutions. |
||||||
|
# Copyright (c) 2000 by Eric Melski <ericm@ajubasolutions.com> |
||||||
|
# Copyright (c) 2001 by Reinhard Max <max@suse.de> |
||||||
|
# Copyright (c) 2003 by Pat Thoyts <patthoyts@users.sourceforge.net> |
||||||
|
# Copyright (c) 2001-2006 by Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||||
|
# |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: split.tcl,v 1.7 2006/04/21 04:42:28 andreas_kupries Exp $ |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requirements |
||||||
|
|
||||||
|
package require Tcl 8.2- |
||||||
|
|
||||||
|
namespace eval ::textutil::split {} |
||||||
|
|
||||||
|
######################################################################## |
||||||
|
# This one was written by Bob Techentin (RWT in Tcl'ers Wiki): |
||||||
|
# http://www.techentin.net |
||||||
|
# mailto:techentin.robert@mayo.edu |
||||||
|
# |
||||||
|
# Later, he send me an email stated that I can use it anywhere, because |
||||||
|
# no copyright was added, so the code is defacto in the public domain. |
||||||
|
# |
||||||
|
# You can found it in the Tcl'ers Wiki here: |
||||||
|
# http://mini.net/cgi-bin/wikit/460.html |
||||||
|
# |
||||||
|
# Bob wrote: |
||||||
|
# If you need to split string into list using some more complicated rule |
||||||
|
# than builtin split command allows, use following function. It mimics |
||||||
|
# Perl split operator which allows regexp as element separator, but, |
||||||
|
# like builtin split, it expects string to split as first arg and regexp |
||||||
|
# as second (optional) By default, it splits by any amount of whitespace. |
||||||
|
# Note that if you add parenthesis into regexp, parenthesed part of separator |
||||||
|
# would be added into list as additional element. Just like in Perl. -- cary |
||||||
|
# |
||||||
|
# Speed improvement by Reinhard Max: |
||||||
|
# Instead of repeatedly copying around the not yet matched part of the |
||||||
|
# string, I use [regexp]'s -start option to restrict the match to that |
||||||
|
# part. This reduces the complexity from something like O(n^1.5) to |
||||||
|
# O(n). My test case for that was: |
||||||
|
# |
||||||
|
# foreach i {1 10 100 1000 10000} { |
||||||
|
# set s [string repeat x $i] |
||||||
|
# puts [time {splitx $s .}] |
||||||
|
# } |
||||||
|
# |
||||||
|
|
||||||
|
if {[package vsatisfies [package provide Tcl] 8.3]} { |
||||||
|
|
||||||
|
proc ::textutil::split::splitx {str {regexp {[\t \r\n]+}}} { |
||||||
|
# Bugfix 476988 |
||||||
|
if {[string length $str] == 0} { |
||||||
|
return {} |
||||||
|
} |
||||||
|
if {[string length $regexp] == 0} { |
||||||
|
return [::split $str ""] |
||||||
|
} |
||||||
|
if {[regexp $regexp {}]} { |
||||||
|
return -code error \ |
||||||
|
"splitting on regexp \"$regexp\" would cause infinite loop" |
||||||
|
} |
||||||
|
|
||||||
|
set list {} |
||||||
|
set start 0 |
||||||
|
while {[regexp -start $start -indices -- $regexp $str match submatch]} { |
||||||
|
foreach {subStart subEnd} $submatch break |
||||||
|
foreach {matchStart matchEnd} $match break |
||||||
|
incr matchStart -1 |
||||||
|
incr matchEnd |
||||||
|
lappend list [string range $str $start $matchStart] |
||||||
|
if {$subStart >= $start} { |
||||||
|
lappend list [string range $str $subStart $subEnd] |
||||||
|
} |
||||||
|
set start $matchEnd |
||||||
|
} |
||||||
|
lappend list [string range $str $start end] |
||||||
|
return $list |
||||||
|
} |
||||||
|
|
||||||
|
} else { |
||||||
|
# For tcl <= 8.2 we do not have regexp -start... |
||||||
|
proc ::textutil::split::splitx [list str [list regexp "\[\t \r\n\]+"]] { |
||||||
|
|
||||||
|
if {[string length $str] == 0} { |
||||||
|
return {} |
||||||
|
} |
||||||
|
if {[string length $regexp] == 0} { |
||||||
|
return [::split $str {}] |
||||||
|
} |
||||||
|
if {[regexp $regexp {}]} { |
||||||
|
return -code error \ |
||||||
|
"splitting on regexp \"$regexp\" would cause infinite loop" |
||||||
|
} |
||||||
|
|
||||||
|
set list {} |
||||||
|
while {[regexp -indices -- $regexp $str match submatch]} { |
||||||
|
lappend list [string range $str 0 [expr {[lindex $match 0] -1}]] |
||||||
|
if {[lindex $submatch 0] >= 0} { |
||||||
|
lappend list [string range $str [lindex $submatch 0] \ |
||||||
|
[lindex $submatch 1]] |
||||||
|
} |
||||||
|
set str [string range $str [expr {[lindex $match 1]+1}] end] |
||||||
|
} |
||||||
|
lappend list $str |
||||||
|
return $list |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# splitn -- |
||||||
|
# |
||||||
|
# splitn splits the string $str into chunks of length $len. These |
||||||
|
# chunks are returned as a list. |
||||||
|
# |
||||||
|
# If $str really contains a ByteArray object (as retrieved from binary |
||||||
|
# encoded channels) splitn must honor this by splitting the string |
||||||
|
# into chunks of $len bytes. |
||||||
|
# |
||||||
|
# It is an error to call splitn with a nonpositive $len. |
||||||
|
# |
||||||
|
# If splitn is called with an empty string, it returns the empty list. |
||||||
|
# |
||||||
|
# If the length of $str is not an entire multiple of the chunk length, |
||||||
|
# the last chunk in the generated list will be shorter than $len. |
||||||
|
# |
||||||
|
# The implementation presented here was given by Bryan Oakley, as |
||||||
|
# part of a ``contest'' I staged on c.l.t in July 2004. I selected |
||||||
|
# this version, as it does not rely on runtime generated code, is |
||||||
|
# very fast for chunk size one, not too bad in all the other cases, |
||||||
|
# and uses [split] or [string range] which have been around for quite |
||||||
|
# some time. |
||||||
|
# |
||||||
|
# -- Robert Suetterlin (robert@mpe.mpg.de) |
||||||
|
# |
||||||
|
proc ::textutil::split::splitn {str {len 1}} { |
||||||
|
|
||||||
|
if {$len <= 0} { |
||||||
|
return -code error "len must be > 0" |
||||||
|
} |
||||||
|
|
||||||
|
if {$len == 1} { |
||||||
|
return [split $str {}] |
||||||
|
} |
||||||
|
|
||||||
|
set result [list] |
||||||
|
set max [string length $str] |
||||||
|
set i 0 |
||||||
|
set j [expr {$len -1}] |
||||||
|
while {$i < $max} { |
||||||
|
lappend result [string range $str $i $j] |
||||||
|
incr i $len |
||||||
|
incr j $len |
||||||
|
} |
||||||
|
|
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Data structures |
||||||
|
|
||||||
|
namespace eval ::textutil::split { |
||||||
|
namespace export splitx splitn |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide textutil::split 0.8 |
||||||
@ -0,0 +1,144 @@ |
|||||||
|
# string.tcl -- |
||||||
|
# |
||||||
|
# Utilities for manipulating strings, words, single lines, |
||||||
|
# paragraphs, ... |
||||||
|
# |
||||||
|
# Copyright (c) 2000 by Ajuba Solutions. |
||||||
|
# Copyright (c) 2000 by Eric Melski <ericm@ajubasolutions.com> |
||||||
|
# Copyright (c) 2002 by Joe English <jenglish@users.sourceforge.net> |
||||||
|
# Copyright (c) 2001-2014 by Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||||
|
# |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: string.tcl,v 1.2 2008/03/22 16:03:11 mic42 Exp $ |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requirements |
||||||
|
|
||||||
|
package require Tcl 8.2- |
||||||
|
|
||||||
|
namespace eval ::textutil::string {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## API implementation |
||||||
|
|
||||||
|
# @c Removes the last character from the given <a string>. |
||||||
|
# |
||||||
|
# @a string: The string to manipulate. |
||||||
|
# |
||||||
|
# @r The <a string> without its last character. |
||||||
|
# |
||||||
|
# @i chopping |
||||||
|
|
||||||
|
proc ::textutil::string::chop {string} { |
||||||
|
return [string range $string 0 [expr {[string length $string]-2}]] |
||||||
|
} |
||||||
|
|
||||||
|
# @c Removes the first character from the given <a string>. |
||||||
|
# @c Convenience procedure. |
||||||
|
# |
||||||
|
# @a string: string to manipulate. |
||||||
|
# |
||||||
|
# @r The <a string> without its first character. |
||||||
|
# |
||||||
|
# @i tail |
||||||
|
|
||||||
|
proc ::textutil::string::tail {string} { |
||||||
|
return [string range $string 1 end] |
||||||
|
} |
||||||
|
|
||||||
|
# @c Capitalizes first character of the given <a string>. |
||||||
|
# @c Complementary procedure to <p ::textutil::uncap>. |
||||||
|
# |
||||||
|
# @a string: string to manipulate. |
||||||
|
# |
||||||
|
# @r The <a string> with its first character capitalized. |
||||||
|
# |
||||||
|
# @i capitalize |
||||||
|
|
||||||
|
proc ::textutil::string::cap {string} { |
||||||
|
return [string toupper [string index $string 0]][string range $string 1 end] |
||||||
|
} |
||||||
|
|
||||||
|
# @c unCapitalizes first character of the given <a string>. |
||||||
|
# @c Complementary procedure to <p ::textutil::cap>. |
||||||
|
# |
||||||
|
# @a string: string to manipulate. |
||||||
|
# |
||||||
|
# @r The <a string> with its first character uncapitalized. |
||||||
|
# |
||||||
|
# @i uncapitalize |
||||||
|
|
||||||
|
proc ::textutil::string::uncap {string} { |
||||||
|
return [string tolower [string index $string 0]][string range $string 1 end] |
||||||
|
} |
||||||
|
|
||||||
|
# @c Capitalizes first character of each word of the given <a sentence>. |
||||||
|
# |
||||||
|
# @a sentence: string to manipulate. |
||||||
|
# |
||||||
|
# @r The <a sentence> with the first character of each word capitalized. |
||||||
|
# |
||||||
|
# @i capitalize |
||||||
|
|
||||||
|
proc ::textutil::string::capEachWord {sentence} { |
||||||
|
regsub -all {\S+} [string map {\\ \\\\ \$ \\$} $sentence] {[string toupper [string index & 0]][string range & 1 end]} cmd |
||||||
|
return [subst -nobackslashes -novariables $cmd] |
||||||
|
} |
||||||
|
|
||||||
|
# Compute the longest string which is common to all strings given to |
||||||
|
# the command, and at the beginning of said strings, i.e. a prefix. If |
||||||
|
# only one argument is specified it is treated as a list of the |
||||||
|
# strings to look at. If more than one argument is specified these |
||||||
|
# arguments are the strings to be looked at. If only one string is |
||||||
|
# given, in either form, the string is returned, as it is its own |
||||||
|
# longest common prefix. |
||||||
|
|
||||||
|
proc ::textutil::string::longestCommonPrefix {args} { |
||||||
|
return [longestCommonPrefixList $args] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::textutil::string::longestCommonPrefixList {list} { |
||||||
|
if {[llength $list] <= 1} { |
||||||
|
return [lindex $list 0] |
||||||
|
} |
||||||
|
|
||||||
|
set list [lsort $list] |
||||||
|
set min [lindex $list 0] |
||||||
|
set max [lindex $list end] |
||||||
|
|
||||||
|
# Min and max are the two strings which are most different. If |
||||||
|
# they have a common prefix, it will also be the common prefix for |
||||||
|
# all of them. |
||||||
|
|
||||||
|
# Fast bailouts for common cases. |
||||||
|
|
||||||
|
set n [string length $min] |
||||||
|
if {$n == 0} {return ""} |
||||||
|
if {0 == [string compare $min $max]} {return $min} |
||||||
|
|
||||||
|
set prefix "" |
||||||
|
set i 0 |
||||||
|
while {[string index $min $i] == [string index $max $i]} { |
||||||
|
append prefix [string index $min $i] |
||||||
|
if {[incr i] > $n} {break} |
||||||
|
} |
||||||
|
set prefix |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Data structures |
||||||
|
|
||||||
|
namespace eval ::textutil::string { |
||||||
|
# Export the imported commands |
||||||
|
|
||||||
|
namespace export chop tail cap uncap capEachWord |
||||||
|
namespace export longestCommonPrefix |
||||||
|
namespace export longestCommonPrefixList |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide textutil::string 0.8 |
||||||
@ -0,0 +1,289 @@ |
|||||||
|
# |
||||||
|
# As the author of the procs 'tabify2' and 'untabify2' I suggest that the |
||||||
|
# comments explaining their behaviour be kept in this file. |
||||||
|
# 1) Beginners in any programming language (I am new to Tcl so I know what I |
||||||
|
# am talking about) can profit enormously from studying 'correct' code. |
||||||
|
# Of course comments will help a lot in this regard. |
||||||
|
# 2) Many problems newbies face can be solved by directing them towards |
||||||
|
# available libraries - after all, libraries have been written to solve |
||||||
|
# recurring problems. Then they can just use them, or have a closer look |
||||||
|
# to see and to discover how things are done the 'Tcl way'. |
||||||
|
# 3) And if ever a proc from a library should be less than perfect, having |
||||||
|
# comments explaining the behaviour of the code will surely help. |
||||||
|
# |
||||||
|
# This said, I will welcome any error reports or suggestions for improvements |
||||||
|
# (especially on the 'doing things the Tcl way' aspect). |
||||||
|
# |
||||||
|
# Use of these sources is licensed under the same conditions as is Tcl. |
||||||
|
# |
||||||
|
# June 2001, Helmut Giese (hgiese@ratiosoft.com) |
||||||
|
# |
||||||
|
# ---------------------------------------------------------------------------- |
||||||
|
# |
||||||
|
# The original procs 'tabify' and 'untabify' each work with complete blocks |
||||||
|
# of $num spaces ('num' holding the tab size). While this is certainly useful |
||||||
|
# in some circumstances, it does not reflect the way an editor works: |
||||||
|
# Counting columns from 1, assuming a tab size of 8 and entering '12345' |
||||||
|
# followed by a tab, you expect to advance to column 9. Your editor might |
||||||
|
# put a tab into the file or 3 spaces, depending on its configuration. |
||||||
|
# Now, on 'tabifying' you will expect to see those 3 spaces converted to a |
||||||
|
# tab (and on the other hand expect the tab *at this position* to be |
||||||
|
# converted to 3 spaces). |
||||||
|
# |
||||||
|
# This behaviour is mimicked by the new procs 'tabify2' and 'untabify2'. |
||||||
|
# Both have one feature in common: They accept multi-line strings (a whole |
||||||
|
# file if you want to) but in order to make life simpler for the programmer, |
||||||
|
# they split the incoming string into individual lines and hand each line to |
||||||
|
# a proc that does the real work. |
||||||
|
# |
||||||
|
# One design decision worth mentioning here: |
||||||
|
# A single space is never converted to a tab even if its position would |
||||||
|
# allow to do so. |
||||||
|
# Single spaces occur very often, say in arithmetic expressions like |
||||||
|
# [expr (($a + $b) * $c) < $d]. If we didn't follow the above rule we might |
||||||
|
# need to replace one or more of them to tabs. However if the tab size gets |
||||||
|
# changed, this expression would be formatted quite differently - which is |
||||||
|
# probably not a good idea. |
||||||
|
# |
||||||
|
# 'untabifying' on the other hand might need to replace a tab with a single |
||||||
|
# space: If the current position requires it, what else to do? |
||||||
|
# As a consequence those two procs are unsymmetric in this aspect, but I |
||||||
|
# couldn't think of a better solution. Could you? |
||||||
|
# |
||||||
|
# ---------------------------------------------------------------------------- |
||||||
|
# |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requirements |
||||||
|
|
||||||
|
package require Tcl 8.2- |
||||||
|
package require textutil::repeat |
||||||
|
|
||||||
|
namespace eval ::textutil::tabify {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## API implementation |
||||||
|
|
||||||
|
namespace eval ::textutil::tabify { |
||||||
|
namespace import -force ::textutil::repeat::strRepeat |
||||||
|
} |
||||||
|
|
||||||
|
proc ::textutil::tabify::tabify { string { num 8 } } { |
||||||
|
return [string map [list [MakeTabStr $num] \t] $string] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::textutil::tabify::untabify { string { num 8 } } { |
||||||
|
return [string map [list \t [MakeTabStr $num]] $string] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::textutil::tabify::MakeTabStr { num } { |
||||||
|
variable TabStr |
||||||
|
variable TabLen |
||||||
|
|
||||||
|
if { $TabLen != $num } then { |
||||||
|
set TabLen $num |
||||||
|
set TabStr [strRepeat " " $num] |
||||||
|
} |
||||||
|
|
||||||
|
return $TabStr |
||||||
|
} |
||||||
|
|
||||||
|
# ---------------------------------------------------------------------------- |
||||||
|
# |
||||||
|
# tabifyLine: Works on a single line of text, replacing 'spaces at correct |
||||||
|
# positions' with tabs. $num is the requested tab size. |
||||||
|
# Returns the (possibly modified) line. |
||||||
|
# |
||||||
|
# 'spaces at correct positions': Only spaces which 'fill the space' between |
||||||
|
# an arbitrary position and the next tab stop can be replaced. |
||||||
|
# Example: With tab size 8, spaces at positions 11 - 13 will *not* be replaced, |
||||||
|
# because an expansion of a tab at position 11 will jump up to 16. |
||||||
|
# See also the comment at the beginning of this file why single spaces are |
||||||
|
# *never* replaced by a tab. |
||||||
|
# |
||||||
|
# The proc works backwards, from the end of the string up to the beginning: |
||||||
|
# - Set the position to start the search from ('lastPos') to 'end'. |
||||||
|
# - Find the last occurrence of ' ' in 'line' with respect to 'lastPos' |
||||||
|
# ('currPos' below). This is a candidate for replacement. |
||||||
|
# - Find to 'currPos' the following tab stop using the expression |
||||||
|
# set nextTab [expr ($currPos + $num) - ($currPos % $num)] |
||||||
|
# and get the previous tab stop as well (this will be the starting |
||||||
|
# point for the next iteration). |
||||||
|
# - The ' ' at 'currPos' is only a candidate for replacement if |
||||||
|
# 1) it is just one position before a tab stop *and* |
||||||
|
# 2) there is at least one space at its left (see comment above on not |
||||||
|
# touching an isolated space). |
||||||
|
# Continue, if any of these conditions is not met. |
||||||
|
# - Determine where to put the tab (that is: how many spaces to replace?) |
||||||
|
# by stepping up to the beginning until |
||||||
|
# -- you hit a non-space or |
||||||
|
# -- you are at the previous tab position |
||||||
|
# - Do the replacement and continue. |
||||||
|
# |
||||||
|
# This algorithm only works, if $line does not contain tabs. Otherwise our |
||||||
|
# interpretation of any position beyond the tab will be wrong. (Imagine you |
||||||
|
# find a ' ' at position 4 in $line. If you got 3 leading tabs, your *real* |
||||||
|
# position might be 25 (tab size of 8). Since in real life some strings might |
||||||
|
# already contain tabs, we test for it (and eventually call untabifyLine). |
||||||
|
# |
||||||
|
|
||||||
|
proc ::textutil::tabify::tabifyLine { line num } { |
||||||
|
if { [string first \t $line] != -1 } { |
||||||
|
# assure array 'Spaces' is set up 'comme il faut' |
||||||
|
checkArr $num |
||||||
|
# remove existing tabs |
||||||
|
set line [untabifyLine $line $num] |
||||||
|
} |
||||||
|
|
||||||
|
set lastPos end |
||||||
|
|
||||||
|
while { $lastPos > 0 } { |
||||||
|
set currPos [string last " " $line $lastPos] |
||||||
|
if { $currPos == -1 } { |
||||||
|
# no more spaces |
||||||
|
break; |
||||||
|
} |
||||||
|
|
||||||
|
set nextTab [expr {($currPos + $num) - ($currPos % $num)}] |
||||||
|
set prevTab [expr {$nextTab - $num}] |
||||||
|
|
||||||
|
# prepare for next round: continue at 'previous tab stop - 1' |
||||||
|
set lastPos [expr {$prevTab - 1}] |
||||||
|
|
||||||
|
if { ($currPos + 1) != $nextTab } { |
||||||
|
continue ;# crit. (1) |
||||||
|
} |
||||||
|
|
||||||
|
if { [string index $line [expr {$currPos - 1}]] != " " } { |
||||||
|
continue ;# crit. (2) |
||||||
|
} |
||||||
|
|
||||||
|
# now step backwards while there are spaces |
||||||
|
for {set pos [expr {$currPos - 2}]} {$pos >= $prevTab} {incr pos -1} { |
||||||
|
if { [string index $line $pos] != " " } { |
||||||
|
break; |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# ... and replace them |
||||||
|
set line [string replace $line [expr {$pos + 1}] $currPos \t] |
||||||
|
} |
||||||
|
return $line |
||||||
|
} |
||||||
|
|
||||||
|
# |
||||||
|
# Helper proc for 'untabifyLine': Checks if all needed elements of array |
||||||
|
# 'Spaces' exist and creates the missing ones if needed. |
||||||
|
# |
||||||
|
|
||||||
|
proc ::textutil::tabify::checkArr { num } { |
||||||
|
variable TabLen2 |
||||||
|
variable Spaces |
||||||
|
|
||||||
|
if { $num > $TabLen2 } { |
||||||
|
for { set i [expr {$TabLen2 + 1}] } { $i <= $num } { incr i } { |
||||||
|
set Spaces($i) [strRepeat " " $i] |
||||||
|
} |
||||||
|
set TabLen2 $num |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# untabifyLine: Works on a single line of text, replacing tabs with enough |
||||||
|
# spaces to get to the next tab position. |
||||||
|
# Returns the (possibly modified) line. |
||||||
|
# |
||||||
|
# The procedure is straight forward: |
||||||
|
# - Find the next tab. |
||||||
|
# - Calculate the next tab position following it. |
||||||
|
# - Delete the tab and insert as many spaces as needed to get there. |
||||||
|
# |
||||||
|
|
||||||
|
proc ::textutil::tabify::untabifyLine { line num } { |
||||||
|
variable Spaces |
||||||
|
|
||||||
|
set currPos 0 |
||||||
|
while { 1 } { |
||||||
|
set currPos [string first \t $line $currPos] |
||||||
|
if { $currPos == -1 } { |
||||||
|
# no more tabs |
||||||
|
break |
||||||
|
} |
||||||
|
|
||||||
|
# how far is the next tab position ? |
||||||
|
set dist [expr {$num - ($currPos % $num)}] |
||||||
|
# replace '\t' at $currPos with $dist spaces |
||||||
|
set line [string replace $line $currPos $currPos $Spaces($dist)] |
||||||
|
|
||||||
|
# set up for next round (not absolutely necessary but maybe a trifle |
||||||
|
# more efficient) |
||||||
|
incr currPos $dist |
||||||
|
} |
||||||
|
return $line |
||||||
|
} |
||||||
|
|
||||||
|
# tabify2: Replace all 'appropriate' spaces as discussed above with tabs. |
||||||
|
# 'string' might hold any number of lines, 'num' is the requested tab size. |
||||||
|
# Returns (possibly modified) 'string'. |
||||||
|
# |
||||||
|
proc ::textutil::tabify::tabify2 { string { num 8 } } { |
||||||
|
|
||||||
|
# split string into individual lines |
||||||
|
set inLst [split $string \n] |
||||||
|
|
||||||
|
# now work on each line |
||||||
|
set outLst [list] |
||||||
|
foreach line $inLst { |
||||||
|
lappend outLst [tabifyLine $line $num] |
||||||
|
} |
||||||
|
|
||||||
|
# return all as one string |
||||||
|
return [join $outLst \n] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# untabify2: Replace all tabs with the appropriate number of spaces. |
||||||
|
# 'string' might hold any number of lines, 'num' is the requested tab size. |
||||||
|
# Returns (possibly modified) 'string'. |
||||||
|
# |
||||||
|
proc ::textutil::tabify::untabify2 { string { num 8 } } { |
||||||
|
|
||||||
|
# assure array 'Spaces' is set up 'comme il faut' |
||||||
|
checkArr $num |
||||||
|
|
||||||
|
set inLst [split $string \n] |
||||||
|
|
||||||
|
set outLst [list] |
||||||
|
foreach line $inLst { |
||||||
|
lappend outLst [untabifyLine $line $num] |
||||||
|
} |
||||||
|
|
||||||
|
return [join $outLst \n] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Data structures |
||||||
|
|
||||||
|
namespace eval ::textutil::tabify { |
||||||
|
variable TabLen 8 |
||||||
|
variable TabStr [strRepeat " " $TabLen] |
||||||
|
|
||||||
|
namespace export tabify untabify tabify2 untabify2 |
||||||
|
|
||||||
|
# The proc 'untabify2' uses the following variables for efficiency. |
||||||
|
# Since a tab can be replaced by one up to 'tab size' spaces, it is handy |
||||||
|
# to have the appropriate 'space strings' available. This is the use of |
||||||
|
# the array 'Spaces', where 'Spaces(n)' contains just 'n' spaces. |
||||||
|
# The variable 'TabLen2' remembers the biggest tab size used. |
||||||
|
|
||||||
|
variable TabLen2 0 |
||||||
|
variable Spaces |
||||||
|
array set Spaces {0 ""} |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide textutil::tabify 0.7 |
||||||
@ -0,0 +1,112 @@ |
|||||||
|
# trim.tcl -- |
||||||
|
# |
||||||
|
# Various ways of trimming a string. |
||||||
|
# |
||||||
|
# Copyright (c) 2000 by Ajuba Solutions. |
||||||
|
# Copyright (c) 2000 by Eric Melski <ericm@ajubasolutions.com> |
||||||
|
# Copyright (c) 2001-2006 by Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||||
|
# |
||||||
|
# See the file "license.terms" for information on usage and redistribution |
||||||
|
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||||
|
# |
||||||
|
# RCS: @(#) $Id: trim.tcl,v 1.5 2006/04/21 04:42:28 andreas_kupries Exp $ |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Requirements |
||||||
|
|
||||||
|
package require Tcl 8.2- |
||||||
|
|
||||||
|
namespace eval ::textutil::trim {} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## API implementation |
||||||
|
|
||||||
|
proc ::textutil::trim::trimleft {text {trim "[ \t]+"}} { |
||||||
|
regsub -line -all -- [MakeStr $trim left] $text {} text |
||||||
|
return $text |
||||||
|
} |
||||||
|
|
||||||
|
proc ::textutil::trim::trimright {text {trim "[ \t]+"}} { |
||||||
|
regsub -line -all -- [MakeStr $trim right] $text {} text |
||||||
|
return $text |
||||||
|
} |
||||||
|
|
||||||
|
proc ::textutil::trim::trim {text {trim "[ \t]+"}} { |
||||||
|
regsub -line -all -- [MakeStr $trim left] $text {} text |
||||||
|
regsub -line -all -- [MakeStr $trim right] $text {} text |
||||||
|
return $text |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# @c Strips <a prefix> from <a text>, if found at its start. |
||||||
|
# |
||||||
|
# @a text: The string to check for <a prefix>. |
||||||
|
# @a prefix: The string to remove from <a text>. |
||||||
|
# |
||||||
|
# @r The <a text>, but without <a prefix>. |
||||||
|
# |
||||||
|
# @i remove, prefix |
||||||
|
|
||||||
|
proc ::textutil::trim::trimPrefix {text prefix} { |
||||||
|
if {[string first $prefix $text] == 0} { |
||||||
|
return [string range $text [string length $prefix] end] |
||||||
|
} else { |
||||||
|
return $text |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# @c Removes the Heading Empty Lines of <a text>. |
||||||
|
# |
||||||
|
# @a text: The text block to manipulate. |
||||||
|
# |
||||||
|
# @r The <a text>, but without heading empty lines. |
||||||
|
# |
||||||
|
# @i remove, empty lines |
||||||
|
|
||||||
|
proc ::textutil::trim::trimEmptyHeading {text} { |
||||||
|
regsub -- "^(\[ \t\]*\n)*" $text {} text |
||||||
|
return $text |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Helper commands. Internal |
||||||
|
|
||||||
|
proc ::textutil::trim::MakeStr { string pos } { |
||||||
|
variable StrU |
||||||
|
variable StrR |
||||||
|
variable StrL |
||||||
|
|
||||||
|
if { "$string" != "$StrU" } { |
||||||
|
set StrU $string |
||||||
|
set StrR "(${StrU})\$" |
||||||
|
set StrL "^(${StrU})" |
||||||
|
} |
||||||
|
if { "$pos" == "left" } { |
||||||
|
return $StrL |
||||||
|
} |
||||||
|
if { "$pos" == "right" } { |
||||||
|
return $StrR |
||||||
|
} |
||||||
|
|
||||||
|
return -code error "Panic, illegal position key \"$pos\"" |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Data structures |
||||||
|
|
||||||
|
namespace eval ::textutil::trim { |
||||||
|
variable StrU "\[ \t\]+" |
||||||
|
variable StrR "(${StrU})\$" |
||||||
|
variable StrL "^(${StrU})" |
||||||
|
|
||||||
|
namespace export \ |
||||||
|
trim trimright trimleft \ |
||||||
|
trimPrefix trimEmptyHeading |
||||||
|
} |
||||||
|
|
||||||
|
# ### ### ### ######### ######### ######### |
||||||
|
## Ready |
||||||
|
|
||||||
|
package provide textutil::trim 0.7 |
||||||
@ -0,0 +1,773 @@ |
|||||||
|
### |
||||||
|
# This file is automatically generated by the build/build.tcl file |
||||||
|
# based on information in the following database: |
||||||
|
# http://www.unicode.org/Public/UCD/latest/ucd/EastAsianWidth.txt |
||||||
|
# |
||||||
|
# (This is the 35th edition, thus version 35 for our package) |
||||||
|
# |
||||||
|
# Author: Sean Woods <yoda@etoyoc.com> |
||||||
|
### |
||||||
|
package provide textutil::wcswidth 35.1 |
||||||
|
namespace eval ::textutil {} |
||||||
|
proc ::textutil::wcswidth_type char { |
||||||
|
if {$char == 161} { return A } |
||||||
|
if {$char == 164} { return A } |
||||||
|
if {$char == 167} { return A } |
||||||
|
if {$char == 168} { return A } |
||||||
|
if {$char == 170} { return A } |
||||||
|
if {$char == 173} { return A } |
||||||
|
if {$char == 174} { return A } |
||||||
|
if {$char == 176} { return A } |
||||||
|
if {$char == 177} { return A } |
||||||
|
if {$char >= 178 && $char <= 179 } { return A } |
||||||
|
if {$char == 180} { return A } |
||||||
|
if {$char >= 182 && $char <= 183 } { return A } |
||||||
|
if {$char == 184} { return A } |
||||||
|
if {$char == 185} { return A } |
||||||
|
if {$char == 186} { return A } |
||||||
|
if {$char >= 188 && $char <= 190 } { return A } |
||||||
|
if {$char == 191} { return A } |
||||||
|
if {$char == 198} { return A } |
||||||
|
if {$char == 208} { return A } |
||||||
|
if {$char == 215} { return A } |
||||||
|
if {$char == 216} { return A } |
||||||
|
if {$char >= 222 && $char <= 225 } { return A } |
||||||
|
if {$char == 230} { return A } |
||||||
|
if {$char >= 232 && $char <= 234 } { return A } |
||||||
|
if {$char >= 236 && $char <= 237 } { return A } |
||||||
|
if {$char == 240} { return A } |
||||||
|
if {$char >= 242 && $char <= 243 } { return A } |
||||||
|
if {$char == 247} { return A } |
||||||
|
if {$char >= 248 && $char <= 250 } { return A } |
||||||
|
if {$char == 252} { return A } |
||||||
|
if {$char == 254} { return A } |
||||||
|
if {$char == 257} { return A } |
||||||
|
if {$char == 273} { return A } |
||||||
|
if {$char == 275} { return A } |
||||||
|
if {$char == 283} { return A } |
||||||
|
if {$char >= 294 && $char <= 295 } { return A } |
||||||
|
if {$char == 299} { return A } |
||||||
|
if {$char >= 305 && $char <= 307 } { return A } |
||||||
|
if {$char == 312} { return A } |
||||||
|
if {$char >= 319 && $char <= 322 } { return A } |
||||||
|
if {$char == 324} { return A } |
||||||
|
if {$char >= 328 && $char <= 331 } { return A } |
||||||
|
if {$char == 333} { return A } |
||||||
|
if {$char >= 338 && $char <= 339 } { return A } |
||||||
|
if {$char >= 358 && $char <= 359 } { return A } |
||||||
|
if {$char == 363} { return A } |
||||||
|
if {$char == 462} { return A } |
||||||
|
if {$char == 464} { return A } |
||||||
|
if {$char == 466} { return A } |
||||||
|
if {$char == 468} { return A } |
||||||
|
if {$char == 470} { return A } |
||||||
|
if {$char == 472} { return A } |
||||||
|
if {$char == 474} { return A } |
||||||
|
if {$char == 476} { return A } |
||||||
|
if {$char == 593} { return A } |
||||||
|
if {$char == 609} { return A } |
||||||
|
if {$char == 708} { return A } |
||||||
|
if {$char == 711} { return A } |
||||||
|
if {$char >= 713 && $char <= 715 } { return A } |
||||||
|
if {$char == 717} { return A } |
||||||
|
if {$char == 720} { return A } |
||||||
|
if {$char >= 728 && $char <= 731 } { return A } |
||||||
|
if {$char == 733} { return A } |
||||||
|
if {$char == 735} { return A } |
||||||
|
if {$char >= 768 && $char <= 879 } { return A } |
||||||
|
if {$char >= 913 && $char <= 929 } { return A } |
||||||
|
if {$char >= 931 && $char <= 937 } { return A } |
||||||
|
if {$char >= 945 && $char <= 961 } { return A } |
||||||
|
if {$char >= 963 && $char <= 969 } { return A } |
||||||
|
if {$char == 1025} { return A } |
||||||
|
if {$char >= 1040 && $char <= 1103 } { return A } |
||||||
|
if {$char == 1105} { return A } |
||||||
|
if {$char >= 4352 && $char <= 4447 } { return W } |
||||||
|
if {$char == 8208} { return A } |
||||||
|
if {$char >= 8211 && $char <= 8213 } { return A } |
||||||
|
if {$char == 8214} { return A } |
||||||
|
if {$char == 8216} { return A } |
||||||
|
if {$char == 8217} { return A } |
||||||
|
if {$char == 8220} { return A } |
||||||
|
if {$char == 8221} { return A } |
||||||
|
if {$char >= 8224 && $char <= 8226 } { return A } |
||||||
|
if {$char >= 8228 && $char <= 8231 } { return A } |
||||||
|
if {$char == 8240} { return A } |
||||||
|
if {$char >= 8242 && $char <= 8243 } { return A } |
||||||
|
if {$char == 8245} { return A } |
||||||
|
if {$char == 8251} { return A } |
||||||
|
if {$char == 8254} { return A } |
||||||
|
if {$char == 8308} { return A } |
||||||
|
if {$char == 8319} { return A } |
||||||
|
if {$char >= 8321 && $char <= 8324 } { return A } |
||||||
|
if {$char == 8361} { return H } |
||||||
|
if {$char == 8364} { return A } |
||||||
|
if {$char == 8451} { return A } |
||||||
|
if {$char == 8453} { return A } |
||||||
|
if {$char == 8457} { return A } |
||||||
|
if {$char == 8467} { return A } |
||||||
|
if {$char == 8470} { return A } |
||||||
|
if {$char >= 8481 && $char <= 8482 } { return A } |
||||||
|
if {$char == 8486} { return A } |
||||||
|
if {$char == 8491} { return A } |
||||||
|
if {$char >= 8531 && $char <= 8532 } { return A } |
||||||
|
if {$char >= 8539 && $char <= 8542 } { return A } |
||||||
|
if {$char >= 8544 && $char <= 8555 } { return A } |
||||||
|
if {$char >= 8560 && $char <= 8569 } { return A } |
||||||
|
if {$char == 8585} { return A } |
||||||
|
if {$char >= 8592 && $char <= 8596 } { return A } |
||||||
|
if {$char >= 8597 && $char <= 8601 } { return A } |
||||||
|
if {$char >= 8632 && $char <= 8633 } { return A } |
||||||
|
if {$char == 8658} { return A } |
||||||
|
if {$char == 8660} { return A } |
||||||
|
if {$char == 8679} { return A } |
||||||
|
if {$char == 8704} { return A } |
||||||
|
if {$char >= 8706 && $char <= 8707 } { return A } |
||||||
|
if {$char >= 8711 && $char <= 8712 } { return A } |
||||||
|
if {$char == 8715} { return A } |
||||||
|
if {$char == 8719} { return A } |
||||||
|
if {$char == 8721} { return A } |
||||||
|
if {$char == 8725} { return A } |
||||||
|
if {$char == 8730} { return A } |
||||||
|
if {$char >= 8733 && $char <= 8736 } { return A } |
||||||
|
if {$char == 8739} { return A } |
||||||
|
if {$char == 8741} { return A } |
||||||
|
if {$char >= 8743 && $char <= 8748 } { return A } |
||||||
|
if {$char == 8750} { return A } |
||||||
|
if {$char >= 8756 && $char <= 8759 } { return A } |
||||||
|
if {$char >= 8764 && $char <= 8765 } { return A } |
||||||
|
if {$char == 8776} { return A } |
||||||
|
if {$char == 8780} { return A } |
||||||
|
if {$char == 8786} { return A } |
||||||
|
if {$char >= 8800 && $char <= 8801 } { return A } |
||||||
|
if {$char >= 8804 && $char <= 8807 } { return A } |
||||||
|
if {$char >= 8810 && $char <= 8811 } { return A } |
||||||
|
if {$char >= 8814 && $char <= 8815 } { return A } |
||||||
|
if {$char >= 8834 && $char <= 8835 } { return A } |
||||||
|
if {$char >= 8838 && $char <= 8839 } { return A } |
||||||
|
if {$char == 8853} { return A } |
||||||
|
if {$char == 8857} { return A } |
||||||
|
if {$char == 8869} { return A } |
||||||
|
if {$char == 8895} { return A } |
||||||
|
if {$char == 8978} { return A } |
||||||
|
if {$char >= 8986 && $char <= 8987 } { return W } |
||||||
|
if {$char == 9001} { return W } |
||||||
|
if {$char == 9002} { return W } |
||||||
|
if {$char >= 9193 && $char <= 9196 } { return W } |
||||||
|
if {$char == 9200} { return W } |
||||||
|
if {$char == 9203} { return W } |
||||||
|
if {$char >= 9312 && $char <= 9371 } { return A } |
||||||
|
if {$char >= 9372 && $char <= 9449 } { return A } |
||||||
|
if {$char >= 9451 && $char <= 9471 } { return A } |
||||||
|
if {$char >= 9472 && $char <= 9547 } { return A } |
||||||
|
if {$char >= 9552 && $char <= 9587 } { return A } |
||||||
|
if {$char >= 9600 && $char <= 9615 } { return A } |
||||||
|
if {$char >= 9618 && $char <= 9621 } { return A } |
||||||
|
if {$char >= 9632 && $char <= 9633 } { return A } |
||||||
|
if {$char >= 9635 && $char <= 9641 } { return A } |
||||||
|
if {$char >= 9650 && $char <= 9651 } { return A } |
||||||
|
if {$char == 9654} { return A } |
||||||
|
if {$char == 9655} { return A } |
||||||
|
if {$char >= 9660 && $char <= 9661 } { return A } |
||||||
|
if {$char == 9664} { return A } |
||||||
|
if {$char == 9665} { return A } |
||||||
|
if {$char >= 9670 && $char <= 9672 } { return A } |
||||||
|
if {$char == 9675} { return A } |
||||||
|
if {$char >= 9678 && $char <= 9681 } { return A } |
||||||
|
if {$char >= 9698 && $char <= 9701 } { return A } |
||||||
|
if {$char == 9711} { return A } |
||||||
|
if {$char >= 9725 && $char <= 9726 } { return W } |
||||||
|
if {$char >= 9733 && $char <= 9734 } { return A } |
||||||
|
if {$char == 9737} { return A } |
||||||
|
if {$char >= 9742 && $char <= 9743 } { return A } |
||||||
|
if {$char >= 9748 && $char <= 9749 } { return W } |
||||||
|
if {$char == 9756} { return A } |
||||||
|
if {$char == 9758} { return A } |
||||||
|
if {$char == 9792} { return A } |
||||||
|
if {$char == 9794} { return A } |
||||||
|
if {$char >= 9800 && $char <= 9811 } { return W } |
||||||
|
if {$char >= 9824 && $char <= 9825 } { return A } |
||||||
|
if {$char >= 9827 && $char <= 9829 } { return A } |
||||||
|
if {$char >= 9831 && $char <= 9834 } { return A } |
||||||
|
if {$char >= 9836 && $char <= 9837 } { return A } |
||||||
|
if {$char == 9839} { return A } |
||||||
|
if {$char == 9855} { return W } |
||||||
|
if {$char == 9875} { return W } |
||||||
|
if {$char >= 9886 && $char <= 9887 } { return A } |
||||||
|
if {$char == 9889} { return W } |
||||||
|
if {$char >= 9898 && $char <= 9899 } { return W } |
||||||
|
if {$char >= 9917 && $char <= 9918 } { return W } |
||||||
|
if {$char == 9919} { return A } |
||||||
|
if {$char >= 9924 && $char <= 9925 } { return W } |
||||||
|
if {$char >= 9926 && $char <= 9933 } { return A } |
||||||
|
if {$char == 9934} { return W } |
||||||
|
if {$char >= 9935 && $char <= 9939 } { return A } |
||||||
|
if {$char == 9940} { return W } |
||||||
|
if {$char >= 9941 && $char <= 9953 } { return A } |
||||||
|
if {$char == 9955} { return A } |
||||||
|
if {$char >= 9960 && $char <= 9961 } { return A } |
||||||
|
if {$char == 9962} { return W } |
||||||
|
if {$char >= 9963 && $char <= 9969 } { return A } |
||||||
|
if {$char >= 9970 && $char <= 9971 } { return W } |
||||||
|
if {$char == 9972} { return A } |
||||||
|
if {$char == 9973} { return W } |
||||||
|
if {$char >= 9974 && $char <= 9977 } { return A } |
||||||
|
if {$char == 9978} { return W } |
||||||
|
if {$char >= 9979 && $char <= 9980 } { return A } |
||||||
|
if {$char == 9981} { return W } |
||||||
|
if {$char >= 9982 && $char <= 9983 } { return A } |
||||||
|
if {$char == 9989} { return W } |
||||||
|
if {$char >= 9994 && $char <= 9995 } { return W } |
||||||
|
if {$char == 10024} { return W } |
||||||
|
if {$char == 10045} { return A } |
||||||
|
if {$char == 10060} { return W } |
||||||
|
if {$char == 10062} { return W } |
||||||
|
if {$char >= 10067 && $char <= 10069 } { return W } |
||||||
|
if {$char == 10071} { return W } |
||||||
|
if {$char >= 10102 && $char <= 10111 } { return A } |
||||||
|
if {$char >= 10133 && $char <= 10135 } { return W } |
||||||
|
if {$char == 10160} { return W } |
||||||
|
if {$char == 10175} { return W } |
||||||
|
if {$char >= 11035 && $char <= 11036 } { return W } |
||||||
|
if {$char == 11088} { return W } |
||||||
|
if {$char == 11093} { return W } |
||||||
|
if {$char >= 11094 && $char <= 11097 } { return A } |
||||||
|
if {$char >= 11904 && $char <= 11929 } { return W } |
||||||
|
if {$char >= 11931 && $char <= 12019 } { return W } |
||||||
|
if {$char >= 12032 && $char <= 12245 } { return W } |
||||||
|
if {$char >= 12272 && $char <= 12283 } { return W } |
||||||
|
if {$char == 12288} { return F } |
||||||
|
if {$char >= 12289 && $char <= 12291 } { return W } |
||||||
|
if {$char == 12292} { return W } |
||||||
|
if {$char == 12293} { return W } |
||||||
|
if {$char == 12294} { return W } |
||||||
|
if {$char == 12295} { return W } |
||||||
|
if {$char == 12296} { return W } |
||||||
|
if {$char == 12297} { return W } |
||||||
|
if {$char == 12298} { return W } |
||||||
|
if {$char == 12299} { return W } |
||||||
|
if {$char == 12300} { return W } |
||||||
|
if {$char == 12301} { return W } |
||||||
|
if {$char == 12302} { return W } |
||||||
|
if {$char == 12303} { return W } |
||||||
|
if {$char == 12304} { return W } |
||||||
|
if {$char == 12305} { return W } |
||||||
|
if {$char >= 12306 && $char <= 12307 } { return W } |
||||||
|
if {$char == 12308} { return W } |
||||||
|
if {$char == 12309} { return W } |
||||||
|
if {$char == 12310} { return W } |
||||||
|
if {$char == 12311} { return W } |
||||||
|
if {$char == 12312} { return W } |
||||||
|
if {$char == 12313} { return W } |
||||||
|
if {$char == 12314} { return W } |
||||||
|
if {$char == 12315} { return W } |
||||||
|
if {$char == 12316} { return W } |
||||||
|
if {$char == 12317} { return W } |
||||||
|
if {$char >= 12318 && $char <= 12319 } { return W } |
||||||
|
if {$char == 12320} { return W } |
||||||
|
if {$char >= 12321 && $char <= 12329 } { return W } |
||||||
|
if {$char >= 12330 && $char <= 12333 } { return W } |
||||||
|
if {$char >= 12334 && $char <= 12335 } { return W } |
||||||
|
if {$char == 12336} { return W } |
||||||
|
if {$char >= 12337 && $char <= 12341 } { return W } |
||||||
|
if {$char >= 12342 && $char <= 12343 } { return W } |
||||||
|
if {$char >= 12344 && $char <= 12346 } { return W } |
||||||
|
if {$char == 12347} { return W } |
||||||
|
if {$char == 12348} { return W } |
||||||
|
if {$char == 12349} { return W } |
||||||
|
if {$char == 12350} { return W } |
||||||
|
if {$char >= 12353 && $char <= 12438 } { return W } |
||||||
|
if {$char >= 12441 && $char <= 12442 } { return W } |
||||||
|
if {$char >= 12443 && $char <= 12444 } { return W } |
||||||
|
if {$char >= 12445 && $char <= 12446 } { return W } |
||||||
|
if {$char == 12447} { return W } |
||||||
|
if {$char == 12448} { return W } |
||||||
|
if {$char >= 12449 && $char <= 12538 } { return W } |
||||||
|
if {$char == 12539} { return W } |
||||||
|
if {$char >= 12540 && $char <= 12542 } { return W } |
||||||
|
if {$char == 12543} { return W } |
||||||
|
if {$char >= 12549 && $char <= 12591 } { return W } |
||||||
|
if {$char >= 12593 && $char <= 12686 } { return W } |
||||||
|
if {$char >= 12688 && $char <= 12689 } { return W } |
||||||
|
if {$char >= 12690 && $char <= 12693 } { return W } |
||||||
|
if {$char >= 12694 && $char <= 12703 } { return W } |
||||||
|
if {$char >= 12704 && $char <= 12730 } { return W } |
||||||
|
if {$char >= 12736 && $char <= 12771 } { return W } |
||||||
|
if {$char >= 12784 && $char <= 12799 } { return W } |
||||||
|
if {$char >= 12800 && $char <= 12830 } { return W } |
||||||
|
if {$char >= 12832 && $char <= 12841 } { return W } |
||||||
|
if {$char >= 12842 && $char <= 12871 } { return W } |
||||||
|
if {$char >= 12872 && $char <= 12879 } { return A } |
||||||
|
if {$char == 12880} { return W } |
||||||
|
if {$char >= 12881 && $char <= 12895 } { return W } |
||||||
|
if {$char >= 12896 && $char <= 12927 } { return W } |
||||||
|
if {$char >= 12928 && $char <= 12937 } { return W } |
||||||
|
if {$char >= 12938 && $char <= 12976 } { return W } |
||||||
|
if {$char >= 12977 && $char <= 12991 } { return W } |
||||||
|
if {$char >= 12992 && $char <= 13054 } { return W } |
||||||
|
if {$char >= 13056 && $char <= 13311 } { return W } |
||||||
|
if {$char >= 13312 && $char <= 19893 } { return W } |
||||||
|
if {$char >= 19894 && $char <= 19903 } { return W } |
||||||
|
if {$char >= 19968 && $char <= 40943 } { return W } |
||||||
|
if {$char >= 40944 && $char <= 40959 } { return W } |
||||||
|
if {$char >= 40960 && $char <= 40980 } { return W } |
||||||
|
if {$char == 40981} { return W } |
||||||
|
if {$char >= 40982 && $char <= 42124 } { return W } |
||||||
|
if {$char >= 42128 && $char <= 42182 } { return W } |
||||||
|
if {$char >= 43360 && $char <= 43388 } { return W } |
||||||
|
if {$char >= 44032 && $char <= 55203 } { return W } |
||||||
|
if {$char >= 57344 && $char <= 63743 } { return A } |
||||||
|
if {$char >= 63744 && $char <= 64109 } { return W } |
||||||
|
if {$char >= 64110 && $char <= 64111 } { return W } |
||||||
|
if {$char >= 64112 && $char <= 64217 } { return W } |
||||||
|
if {$char >= 64218 && $char <= 64255 } { return W } |
||||||
|
if {$char >= 65024 && $char <= 65039 } { return A } |
||||||
|
if {$char >= 65040 && $char <= 65046 } { return W } |
||||||
|
if {$char == 65047} { return W } |
||||||
|
if {$char == 65048} { return W } |
||||||
|
if {$char == 65049} { return W } |
||||||
|
if {$char == 65072} { return W } |
||||||
|
if {$char >= 65073 && $char <= 65074 } { return W } |
||||||
|
if {$char >= 65075 && $char <= 65076 } { return W } |
||||||
|
if {$char == 65077} { return W } |
||||||
|
if {$char == 65078} { return W } |
||||||
|
if {$char == 65079} { return W } |
||||||
|
if {$char == 65080} { return W } |
||||||
|
if {$char == 65081} { return W } |
||||||
|
if {$char == 65082} { return W } |
||||||
|
if {$char == 65083} { return W } |
||||||
|
if {$char == 65084} { return W } |
||||||
|
if {$char == 65085} { return W } |
||||||
|
if {$char == 65086} { return W } |
||||||
|
if {$char == 65087} { return W } |
||||||
|
if {$char == 65088} { return W } |
||||||
|
if {$char == 65089} { return W } |
||||||
|
if {$char == 65090} { return W } |
||||||
|
if {$char == 65091} { return W } |
||||||
|
if {$char == 65092} { return W } |
||||||
|
if {$char >= 65093 && $char <= 65094 } { return W } |
||||||
|
if {$char == 65095} { return W } |
||||||
|
if {$char == 65096} { return W } |
||||||
|
if {$char >= 65097 && $char <= 65100 } { return W } |
||||||
|
if {$char >= 65101 && $char <= 65103 } { return W } |
||||||
|
if {$char >= 65104 && $char <= 65106 } { return W } |
||||||
|
if {$char >= 65108 && $char <= 65111 } { return W } |
||||||
|
if {$char == 65112} { return W } |
||||||
|
if {$char == 65113} { return W } |
||||||
|
if {$char == 65114} { return W } |
||||||
|
if {$char == 65115} { return W } |
||||||
|
if {$char == 65116} { return W } |
||||||
|
if {$char == 65117} { return W } |
||||||
|
if {$char == 65118} { return W } |
||||||
|
if {$char >= 65119 && $char <= 65121 } { return W } |
||||||
|
if {$char == 65122} { return W } |
||||||
|
if {$char == 65123} { return W } |
||||||
|
if {$char >= 65124 && $char <= 65126 } { return W } |
||||||
|
if {$char == 65128} { return W } |
||||||
|
if {$char == 65129} { return W } |
||||||
|
if {$char >= 65130 && $char <= 65131 } { return W } |
||||||
|
if {$char >= 65281 && $char <= 65283 } { return F } |
||||||
|
if {$char == 65284} { return F } |
||||||
|
if {$char >= 65285 && $char <= 65287 } { return F } |
||||||
|
if {$char == 65288} { return F } |
||||||
|
if {$char == 65289} { return F } |
||||||
|
if {$char == 65290} { return F } |
||||||
|
if {$char == 65291} { return F } |
||||||
|
if {$char == 65292} { return F } |
||||||
|
if {$char == 65293} { return F } |
||||||
|
if {$char >= 65294 && $char <= 65295 } { return F } |
||||||
|
if {$char >= 65296 && $char <= 65305 } { return F } |
||||||
|
if {$char >= 65306 && $char <= 65307 } { return F } |
||||||
|
if {$char >= 65308 && $char <= 65310 } { return F } |
||||||
|
if {$char >= 65311 && $char <= 65312 } { return F } |
||||||
|
if {$char >= 65313 && $char <= 65338 } { return F } |
||||||
|
if {$char == 65339} { return F } |
||||||
|
if {$char == 65340} { return F } |
||||||
|
if {$char == 65341} { return F } |
||||||
|
if {$char == 65342} { return F } |
||||||
|
if {$char == 65343} { return F } |
||||||
|
if {$char == 65344} { return F } |
||||||
|
if {$char >= 65345 && $char <= 65370 } { return F } |
||||||
|
if {$char == 65371} { return F } |
||||||
|
if {$char == 65372} { return F } |
||||||
|
if {$char == 65373} { return F } |
||||||
|
if {$char == 65374} { return F } |
||||||
|
if {$char == 65375} { return F } |
||||||
|
if {$char == 65376} { return F } |
||||||
|
if {$char == 65377} { return H } |
||||||
|
if {$char == 65378} { return H } |
||||||
|
if {$char == 65379} { return H } |
||||||
|
if {$char >= 65380 && $char <= 65381 } { return H } |
||||||
|
if {$char >= 65382 && $char <= 65391 } { return H } |
||||||
|
if {$char == 65392} { return H } |
||||||
|
if {$char >= 65393 && $char <= 65437 } { return H } |
||||||
|
if {$char >= 65438 && $char <= 65439 } { return H } |
||||||
|
if {$char >= 65440 && $char <= 65470 } { return H } |
||||||
|
if {$char >= 65474 && $char <= 65479 } { return H } |
||||||
|
if {$char >= 65482 && $char <= 65487 } { return H } |
||||||
|
if {$char >= 65490 && $char <= 65495 } { return H } |
||||||
|
if {$char >= 65498 && $char <= 65500 } { return H } |
||||||
|
if {$char >= 65504 && $char <= 65505 } { return F } |
||||||
|
if {$char == 65506} { return F } |
||||||
|
if {$char == 65507} { return F } |
||||||
|
if {$char == 65508} { return F } |
||||||
|
if {$char >= 65509 && $char <= 65510 } { return F } |
||||||
|
if {$char == 65512} { return H } |
||||||
|
if {$char >= 65513 && $char <= 65516 } { return H } |
||||||
|
if {$char >= 65517 && $char <= 65518 } { return H } |
||||||
|
if {$char == 65533} { return A } |
||||||
|
if {$char >= 94176 && $char <= 94177 } { return W } |
||||||
|
if {$char >= 94208 && $char <= 100337 } { return W } |
||||||
|
if {$char >= 100352 && $char <= 101106 } { return W } |
||||||
|
if {$char >= 110592 && $char <= 110847 } { return W } |
||||||
|
if {$char >= 110848 && $char <= 110878 } { return W } |
||||||
|
if {$char >= 110960 && $char <= 111355 } { return W } |
||||||
|
if {$char == 126980} { return W } |
||||||
|
if {$char == 127183} { return W } |
||||||
|
if {$char >= 127232 && $char <= 127242 } { return A } |
||||||
|
if {$char >= 127248 && $char <= 127277 } { return A } |
||||||
|
if {$char >= 127280 && $char <= 127337 } { return A } |
||||||
|
if {$char >= 127344 && $char <= 127373 } { return A } |
||||||
|
if {$char == 127374} { return W } |
||||||
|
if {$char >= 127375 && $char <= 127376 } { return A } |
||||||
|
if {$char >= 127377 && $char <= 127386 } { return W } |
||||||
|
if {$char >= 127387 && $char <= 127404 } { return A } |
||||||
|
if {$char >= 127488 && $char <= 127490 } { return W } |
||||||
|
if {$char >= 127504 && $char <= 127547 } { return W } |
||||||
|
if {$char >= 127552 && $char <= 127560 } { return W } |
||||||
|
if {$char >= 127568 && $char <= 127569 } { return W } |
||||||
|
if {$char >= 127584 && $char <= 127589 } { return W } |
||||||
|
if {$char >= 127744 && $char <= 127776 } { return W } |
||||||
|
if {$char >= 127789 && $char <= 127797 } { return W } |
||||||
|
if {$char >= 127799 && $char <= 127868 } { return W } |
||||||
|
if {$char >= 127870 && $char <= 127891 } { return W } |
||||||
|
if {$char >= 127904 && $char <= 127946 } { return W } |
||||||
|
if {$char >= 127951 && $char <= 127955 } { return W } |
||||||
|
if {$char >= 127968 && $char <= 127984 } { return W } |
||||||
|
if {$char == 127988} { return W } |
||||||
|
if {$char >= 127992 && $char <= 127994 } { return W } |
||||||
|
if {$char >= 127995 && $char <= 127999 } { return W } |
||||||
|
if {$char >= 128000 && $char <= 128062 } { return W } |
||||||
|
if {$char == 128064} { return W } |
||||||
|
if {$char >= 128066 && $char <= 128252 } { return W } |
||||||
|
if {$char >= 128255 && $char <= 128317 } { return W } |
||||||
|
if {$char >= 128331 && $char <= 128334 } { return W } |
||||||
|
if {$char >= 128336 && $char <= 128359 } { return W } |
||||||
|
if {$char == 128378} { return W } |
||||||
|
if {$char >= 128405 && $char <= 128406 } { return W } |
||||||
|
if {$char == 128420} { return W } |
||||||
|
if {$char >= 128507 && $char <= 128511 } { return W } |
||||||
|
if {$char >= 128512 && $char <= 128591 } { return W } |
||||||
|
if {$char >= 128640 && $char <= 128709 } { return W } |
||||||
|
if {$char == 128716} { return W } |
||||||
|
if {$char >= 128720 && $char <= 128722 } { return W } |
||||||
|
if {$char >= 128747 && $char <= 128748 } { return W } |
||||||
|
if {$char >= 128756 && $char <= 128761 } { return W } |
||||||
|
if {$char >= 129296 && $char <= 129342 } { return W } |
||||||
|
if {$char >= 129344 && $char <= 129392 } { return W } |
||||||
|
if {$char >= 129395 && $char <= 129398 } { return W } |
||||||
|
if {$char == 129402} { return W } |
||||||
|
if {$char >= 129404 && $char <= 129442 } { return W } |
||||||
|
if {$char >= 129456 && $char <= 129465 } { return W } |
||||||
|
if {$char >= 129472 && $char <= 129474 } { return W } |
||||||
|
if {$char >= 129488 && $char <= 129535 } { return W } |
||||||
|
if {$char >= 131072 && $char <= 173782 } { return W } |
||||||
|
if {$char >= 173783 && $char <= 173823 } { return W } |
||||||
|
if {$char >= 173824 && $char <= 177972 } { return W } |
||||||
|
if {$char >= 177973 && $char <= 177983 } { return W } |
||||||
|
if {$char >= 177984 && $char <= 178205 } { return W } |
||||||
|
if {$char >= 178206 && $char <= 178207 } { return W } |
||||||
|
if {$char >= 178208 && $char <= 183969 } { return W } |
||||||
|
if {$char >= 183970 && $char <= 183983 } { return W } |
||||||
|
if {$char >= 183984 && $char <= 191456 } { return W } |
||||||
|
if {$char >= 191457 && $char <= 194559 } { return W } |
||||||
|
if {$char >= 194560 && $char <= 195101 } { return W } |
||||||
|
if {$char >= 195102 && $char <= 195103 } { return W } |
||||||
|
if {$char >= 195104 && $char <= 196605 } { return W } |
||||||
|
if {$char >= 196608 && $char <= 262141 } { return W } |
||||||
|
if {$char >= 917760 && $char <= 917999 } { return A } |
||||||
|
if {$char >= 983040 && $char <= 1048573 } { return A } |
||||||
|
if {$char >= 1048576 && $char <= 1114109 } { return A } |
||||||
|
return N |
||||||
|
} |
||||||
|
proc ::textutil::wcswidth_char char { |
||||||
|
if {$char >= 4352 && $char <= 4447 } { return 2 } |
||||||
|
if {$char >= 8986 && $char <= 8987 } { return 2 } |
||||||
|
if {$char == 9001} { return 2 } |
||||||
|
if {$char == 9002} { return 2 } |
||||||
|
if {$char >= 9193 && $char <= 9196 } { return 2 } |
||||||
|
if {$char == 9200} { return 2 } |
||||||
|
if {$char == 9203} { return 2 } |
||||||
|
if {$char >= 9725 && $char <= 9726 } { return 2 } |
||||||
|
if {$char >= 9748 && $char <= 9749 } { return 2 } |
||||||
|
if {$char >= 9800 && $char <= 9811 } { return 2 } |
||||||
|
if {$char == 9855} { return 2 } |
||||||
|
if {$char == 9875} { return 2 } |
||||||
|
if {$char == 9889} { return 2 } |
||||||
|
if {$char >= 9898 && $char <= 9899 } { return 2 } |
||||||
|
if {$char >= 9917 && $char <= 9918 } { return 2 } |
||||||
|
if {$char >= 9924 && $char <= 9925 } { return 2 } |
||||||
|
if {$char == 9934} { return 2 } |
||||||
|
if {$char == 9940} { return 2 } |
||||||
|
if {$char == 9962} { return 2 } |
||||||
|
if {$char >= 9970 && $char <= 9971 } { return 2 } |
||||||
|
if {$char == 9973} { return 2 } |
||||||
|
if {$char == 9978} { return 2 } |
||||||
|
if {$char == 9981} { return 2 } |
||||||
|
if {$char == 9989} { return 2 } |
||||||
|
if {$char >= 9994 && $char <= 9995 } { return 2 } |
||||||
|
if {$char == 10024} { return 2 } |
||||||
|
if {$char == 10060} { return 2 } |
||||||
|
if {$char == 10062} { return 2 } |
||||||
|
if {$char >= 10067 && $char <= 10069 } { return 2 } |
||||||
|
if {$char == 10071} { return 2 } |
||||||
|
if {$char >= 10133 && $char <= 10135 } { return 2 } |
||||||
|
if {$char == 10160} { return 2 } |
||||||
|
if {$char == 10175} { return 2 } |
||||||
|
if {$char >= 11035 && $char <= 11036 } { return 2 } |
||||||
|
if {$char == 11088} { return 2 } |
||||||
|
if {$char == 11093} { return 2 } |
||||||
|
if {$char >= 11904 && $char <= 11929 } { return 2 } |
||||||
|
if {$char >= 11931 && $char <= 12019 } { return 2 } |
||||||
|
if {$char >= 12032 && $char <= 12245 } { return 2 } |
||||||
|
if {$char >= 12272 && $char <= 12283 } { return 2 } |
||||||
|
if {$char == 12288} { return 2 } |
||||||
|
if {$char >= 12289 && $char <= 12291 } { return 2 } |
||||||
|
if {$char == 12292} { return 2 } |
||||||
|
if {$char == 12293} { return 2 } |
||||||
|
if {$char == 12294} { return 2 } |
||||||
|
if {$char == 12295} { return 2 } |
||||||
|
if {$char == 12296} { return 2 } |
||||||
|
if {$char == 12297} { return 2 } |
||||||
|
if {$char == 12298} { return 2 } |
||||||
|
if {$char == 12299} { return 2 } |
||||||
|
if {$char == 12300} { return 2 } |
||||||
|
if {$char == 12301} { return 2 } |
||||||
|
if {$char == 12302} { return 2 } |
||||||
|
if {$char == 12303} { return 2 } |
||||||
|
if {$char == 12304} { return 2 } |
||||||
|
if {$char == 12305} { return 2 } |
||||||
|
if {$char >= 12306 && $char <= 12307 } { return 2 } |
||||||
|
if {$char == 12308} { return 2 } |
||||||
|
if {$char == 12309} { return 2 } |
||||||
|
if {$char == 12310} { return 2 } |
||||||
|
if {$char == 12311} { return 2 } |
||||||
|
if {$char == 12312} { return 2 } |
||||||
|
if {$char == 12313} { return 2 } |
||||||
|
if {$char == 12314} { return 2 } |
||||||
|
if {$char == 12315} { return 2 } |
||||||
|
if {$char == 12316} { return 2 } |
||||||
|
if {$char == 12317} { return 2 } |
||||||
|
if {$char >= 12318 && $char <= 12319 } { return 2 } |
||||||
|
if {$char == 12320} { return 2 } |
||||||
|
if {$char >= 12321 && $char <= 12329 } { return 2 } |
||||||
|
if {$char >= 12330 && $char <= 12333 } { return 2 } |
||||||
|
if {$char >= 12334 && $char <= 12335 } { return 2 } |
||||||
|
if {$char == 12336} { return 2 } |
||||||
|
if {$char >= 12337 && $char <= 12341 } { return 2 } |
||||||
|
if {$char >= 12342 && $char <= 12343 } { return 2 } |
||||||
|
if {$char >= 12344 && $char <= 12346 } { return 2 } |
||||||
|
if {$char == 12347} { return 2 } |
||||||
|
if {$char == 12348} { return 2 } |
||||||
|
if {$char == 12349} { return 2 } |
||||||
|
if {$char == 12350} { return 2 } |
||||||
|
if {$char >= 12353 && $char <= 12438 } { return 2 } |
||||||
|
if {$char >= 12441 && $char <= 12442 } { return 2 } |
||||||
|
if {$char >= 12443 && $char <= 12444 } { return 2 } |
||||||
|
if {$char >= 12445 && $char <= 12446 } { return 2 } |
||||||
|
if {$char == 12447} { return 2 } |
||||||
|
if {$char == 12448} { return 2 } |
||||||
|
if {$char >= 12449 && $char <= 12538 } { return 2 } |
||||||
|
if {$char == 12539} { return 2 } |
||||||
|
if {$char >= 12540 && $char <= 12542 } { return 2 } |
||||||
|
if {$char == 12543} { return 2 } |
||||||
|
if {$char >= 12549 && $char <= 12591 } { return 2 } |
||||||
|
if {$char >= 12593 && $char <= 12686 } { return 2 } |
||||||
|
if {$char >= 12688 && $char <= 12689 } { return 2 } |
||||||
|
if {$char >= 12690 && $char <= 12693 } { return 2 } |
||||||
|
if {$char >= 12694 && $char <= 12703 } { return 2 } |
||||||
|
if {$char >= 12704 && $char <= 12730 } { return 2 } |
||||||
|
if {$char >= 12736 && $char <= 12771 } { return 2 } |
||||||
|
if {$char >= 12784 && $char <= 12799 } { return 2 } |
||||||
|
if {$char >= 12800 && $char <= 12830 } { return 2 } |
||||||
|
if {$char >= 12832 && $char <= 12841 } { return 2 } |
||||||
|
if {$char >= 12842 && $char <= 12871 } { return 2 } |
||||||
|
if {$char == 12880} { return 2 } |
||||||
|
if {$char >= 12881 && $char <= 12895 } { return 2 } |
||||||
|
if {$char >= 12896 && $char <= 12927 } { return 2 } |
||||||
|
if {$char >= 12928 && $char <= 12937 } { return 2 } |
||||||
|
if {$char >= 12938 && $char <= 12976 } { return 2 } |
||||||
|
if {$char >= 12977 && $char <= 12991 } { return 2 } |
||||||
|
if {$char >= 12992 && $char <= 13054 } { return 2 } |
||||||
|
if {$char >= 13056 && $char <= 13311 } { return 2 } |
||||||
|
if {$char >= 13312 && $char <= 19893 } { return 2 } |
||||||
|
if {$char >= 19894 && $char <= 19903 } { return 2 } |
||||||
|
if {$char >= 19968 && $char <= 40943 } { return 2 } |
||||||
|
if {$char >= 40944 && $char <= 40959 } { return 2 } |
||||||
|
if {$char >= 40960 && $char <= 40980 } { return 2 } |
||||||
|
if {$char == 40981} { return 2 } |
||||||
|
if {$char >= 40982 && $char <= 42124 } { return 2 } |
||||||
|
if {$char >= 42128 && $char <= 42182 } { return 2 } |
||||||
|
if {$char >= 43360 && $char <= 43388 } { return 2 } |
||||||
|
if {$char >= 44032 && $char <= 55203 } { return 2 } |
||||||
|
if {$char >= 63744 && $char <= 64109 } { return 2 } |
||||||
|
if {$char >= 64110 && $char <= 64111 } { return 2 } |
||||||
|
if {$char >= 64112 && $char <= 64217 } { return 2 } |
||||||
|
if {$char >= 64218 && $char <= 64255 } { return 2 } |
||||||
|
if {$char >= 65040 && $char <= 65046 } { return 2 } |
||||||
|
if {$char == 65047} { return 2 } |
||||||
|
if {$char == 65048} { return 2 } |
||||||
|
if {$char == 65049} { return 2 } |
||||||
|
if {$char == 65072} { return 2 } |
||||||
|
if {$char >= 65073 && $char <= 65074 } { return 2 } |
||||||
|
if {$char >= 65075 && $char <= 65076 } { return 2 } |
||||||
|
if {$char == 65077} { return 2 } |
||||||
|
if {$char == 65078} { return 2 } |
||||||
|
if {$char == 65079} { return 2 } |
||||||
|
if {$char == 65080} { return 2 } |
||||||
|
if {$char == 65081} { return 2 } |
||||||
|
if {$char == 65082} { return 2 } |
||||||
|
if {$char == 65083} { return 2 } |
||||||
|
if {$char == 65084} { return 2 } |
||||||
|
if {$char == 65085} { return 2 } |
||||||
|
if {$char == 65086} { return 2 } |
||||||
|
if {$char == 65087} { return 2 } |
||||||
|
if {$char == 65088} { return 2 } |
||||||
|
if {$char == 65089} { return 2 } |
||||||
|
if {$char == 65090} { return 2 } |
||||||
|
if {$char == 65091} { return 2 } |
||||||
|
if {$char == 65092} { return 2 } |
||||||
|
if {$char >= 65093 && $char <= 65094 } { return 2 } |
||||||
|
if {$char == 65095} { return 2 } |
||||||
|
if {$char == 65096} { return 2 } |
||||||
|
if {$char >= 65097 && $char <= 65100 } { return 2 } |
||||||
|
if {$char >= 65101 && $char <= 65103 } { return 2 } |
||||||
|
if {$char >= 65104 && $char <= 65106 } { return 2 } |
||||||
|
if {$char >= 65108 && $char <= 65111 } { return 2 } |
||||||
|
if {$char == 65112} { return 2 } |
||||||
|
if {$char == 65113} { return 2 } |
||||||
|
if {$char == 65114} { return 2 } |
||||||
|
if {$char == 65115} { return 2 } |
||||||
|
if {$char == 65116} { return 2 } |
||||||
|
if {$char == 65117} { return 2 } |
||||||
|
if {$char == 65118} { return 2 } |
||||||
|
if {$char >= 65119 && $char <= 65121 } { return 2 } |
||||||
|
if {$char == 65122} { return 2 } |
||||||
|
if {$char == 65123} { return 2 } |
||||||
|
if {$char >= 65124 && $char <= 65126 } { return 2 } |
||||||
|
if {$char == 65128} { return 2 } |
||||||
|
if {$char == 65129} { return 2 } |
||||||
|
if {$char >= 65130 && $char <= 65131 } { return 2 } |
||||||
|
if {$char >= 65281 && $char <= 65283 } { return 2 } |
||||||
|
if {$char == 65284} { return 2 } |
||||||
|
if {$char >= 65285 && $char <= 65287 } { return 2 } |
||||||
|
if {$char == 65288} { return 2 } |
||||||
|
if {$char == 65289} { return 2 } |
||||||
|
if {$char == 65290} { return 2 } |
||||||
|
if {$char == 65291} { return 2 } |
||||||
|
if {$char == 65292} { return 2 } |
||||||
|
if {$char == 65293} { return 2 } |
||||||
|
if {$char >= 65294 && $char <= 65295 } { return 2 } |
||||||
|
if {$char >= 65296 && $char <= 65305 } { return 2 } |
||||||
|
if {$char >= 65306 && $char <= 65307 } { return 2 } |
||||||
|
if {$char >= 65308 && $char <= 65310 } { return 2 } |
||||||
|
if {$char >= 65311 && $char <= 65312 } { return 2 } |
||||||
|
if {$char >= 65313 && $char <= 65338 } { return 2 } |
||||||
|
if {$char == 65339} { return 2 } |
||||||
|
if {$char == 65340} { return 2 } |
||||||
|
if {$char == 65341} { return 2 } |
||||||
|
if {$char == 65342} { return 2 } |
||||||
|
if {$char == 65343} { return 2 } |
||||||
|
if {$char == 65344} { return 2 } |
||||||
|
if {$char >= 65345 && $char <= 65370 } { return 2 } |
||||||
|
if {$char == 65371} { return 2 } |
||||||
|
if {$char == 65372} { return 2 } |
||||||
|
if {$char == 65373} { return 2 } |
||||||
|
if {$char == 65374} { return 2 } |
||||||
|
if {$char == 65375} { return 2 } |
||||||
|
if {$char == 65376} { return 2 } |
||||||
|
if {$char >= 65504 && $char <= 65505 } { return 2 } |
||||||
|
if {$char == 65506} { return 2 } |
||||||
|
if {$char == 65507} { return 2 } |
||||||
|
if {$char == 65508} { return 2 } |
||||||
|
if {$char >= 65509 && $char <= 65510 } { return 2 } |
||||||
|
if {$char >= 94176 && $char <= 94177 } { return 2 } |
||||||
|
if {$char >= 94208 && $char <= 100337 } { return 2 } |
||||||
|
if {$char >= 100352 && $char <= 101106 } { return 2 } |
||||||
|
if {$char >= 110592 && $char <= 110847 } { return 2 } |
||||||
|
if {$char >= 110848 && $char <= 110878 } { return 2 } |
||||||
|
if {$char >= 110960 && $char <= 111355 } { return 2 } |
||||||
|
if {$char == 126980} { return 2 } |
||||||
|
if {$char == 127183} { return 2 } |
||||||
|
if {$char == 127374} { return 2 } |
||||||
|
if {$char >= 127377 && $char <= 127386 } { return 2 } |
||||||
|
if {$char >= 127488 && $char <= 127490 } { return 2 } |
||||||
|
if {$char >= 127504 && $char <= 127547 } { return 2 } |
||||||
|
if {$char >= 127552 && $char <= 127560 } { return 2 } |
||||||
|
if {$char >= 127568 && $char <= 127569 } { return 2 } |
||||||
|
if {$char >= 127584 && $char <= 127589 } { return 2 } |
||||||
|
if {$char >= 127744 && $char <= 127776 } { return 2 } |
||||||
|
if {$char >= 127789 && $char <= 127797 } { return 2 } |
||||||
|
if {$char >= 127799 && $char <= 127868 } { return 2 } |
||||||
|
if {$char >= 127870 && $char <= 127891 } { return 2 } |
||||||
|
if {$char >= 127904 && $char <= 127946 } { return 2 } |
||||||
|
if {$char >= 127951 && $char <= 127955 } { return 2 } |
||||||
|
if {$char >= 127968 && $char <= 127984 } { return 2 } |
||||||
|
if {$char == 127988} { return 2 } |
||||||
|
if {$char >= 127992 && $char <= 127994 } { return 2 } |
||||||
|
if {$char >= 127995 && $char <= 127999 } { return 2 } |
||||||
|
if {$char >= 128000 && $char <= 128062 } { return 2 } |
||||||
|
if {$char == 128064} { return 2 } |
||||||
|
if {$char >= 128066 && $char <= 128252 } { return 2 } |
||||||
|
if {$char >= 128255 && $char <= 128317 } { return 2 } |
||||||
|
if {$char >= 128331 && $char <= 128334 } { return 2 } |
||||||
|
if {$char >= 128336 && $char <= 128359 } { return 2 } |
||||||
|
if {$char == 128378} { return 2 } |
||||||
|
if {$char >= 128405 && $char <= 128406 } { return 2 } |
||||||
|
if {$char == 128420} { return 2 } |
||||||
|
if {$char >= 128507 && $char <= 128511 } { return 2 } |
||||||
|
if {$char >= 128512 && $char <= 128591 } { return 2 } |
||||||
|
if {$char >= 128640 && $char <= 128709 } { return 2 } |
||||||
|
if {$char == 128716} { return 2 } |
||||||
|
if {$char >= 128720 && $char <= 128722 } { return 2 } |
||||||
|
if {$char >= 128747 && $char <= 128748 } { return 2 } |
||||||
|
if {$char >= 128756 && $char <= 128761 } { return 2 } |
||||||
|
if {$char >= 129296 && $char <= 129342 } { return 2 } |
||||||
|
if {$char >= 129344 && $char <= 129392 } { return 2 } |
||||||
|
if {$char >= 129395 && $char <= 129398 } { return 2 } |
||||||
|
if {$char == 129402} { return 2 } |
||||||
|
if {$char >= 129404 && $char <= 129442 } { return 2 } |
||||||
|
if {$char >= 129456 && $char <= 129465 } { return 2 } |
||||||
|
if {$char >= 129472 && $char <= 129474 } { return 2 } |
||||||
|
if {$char >= 129488 && $char <= 129535 } { return 2 } |
||||||
|
if {$char >= 131072 && $char <= 173782 } { return 2 } |
||||||
|
if {$char >= 173783 && $char <= 173823 } { return 2 } |
||||||
|
if {$char >= 173824 && $char <= 177972 } { return 2 } |
||||||
|
if {$char >= 177973 && $char <= 177983 } { return 2 } |
||||||
|
if {$char >= 177984 && $char <= 178205 } { return 2 } |
||||||
|
if {$char >= 178206 && $char <= 178207 } { return 2 } |
||||||
|
if {$char >= 178208 && $char <= 183969 } { return 2 } |
||||||
|
if {$char >= 183970 && $char <= 183983 } { return 2 } |
||||||
|
if {$char >= 183984 && $char <= 191456 } { return 2 } |
||||||
|
if {$char >= 191457 && $char <= 194559 } { return 2 } |
||||||
|
if {$char >= 194560 && $char <= 195101 } { return 2 } |
||||||
|
if {$char >= 195102 && $char <= 195103 } { return 2 } |
||||||
|
if {$char >= 195104 && $char <= 196605 } { return 2 } |
||||||
|
if {$char >= 196608 && $char <= 262141 } { return 2 } |
||||||
|
return 1 |
||||||
|
} |
||||||
|
|
||||||
|
proc ::textutil::wcswidth {string} { |
||||||
|
set width 0 |
||||||
|
set len [string length $string] |
||||||
|
foreach c [split $string {}] { |
||||||
|
scan $c %c char |
||||||
|
set n [::textutil::wcswidth_char $char] |
||||||
|
if {$n < 0} { |
||||||
|
return -1 |
||||||
|
} |
||||||
|
incr width $n |
||||||
|
} |
||||||
|
return $width |
||||||
|
} |
||||||
|
|
||||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue