From 5b310390513f393332d4b0c1a9e7e61728662adb Mon Sep 17 00:00:00 2001 From: Julian Noble Date: Mon, 18 Mar 2024 22:21:51 +1100 Subject: [PATCH] make.tcl ensure lib folder exists, add uuid lib, ansistring fixes --- src/make.tcl | 3 +- src/modules/punk/ansi-999999.0a1.0.tm | 11 +- .../mix/commandset/loadedlib-999999.0a1.0.tm | 4 +- src/vendormodules/uuid-1.0.7.tm | 245 ++++++++++++++++++ 4 files changed, 255 insertions(+), 8 deletions(-) create mode 100644 src/vendormodules/uuid-1.0.7.tm diff --git a/src/make.tcl b/src/make.tcl index 10d8e7e..f4eef65 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -412,12 +412,13 @@ if {$::punkmake::command ne "project"} { exit 1 } - +file mkdir $projectroot/lib ;#needs to exist #only a single consolidated /modules folder used for target set target_modules_base $projectroot/modules file mkdir $target_modules_base + #external libs and modules first - and any supporting files - no 'building' required if {[file exists $sourcefolder/vendorlib]} { #exclude README.md from source folder - but only the root one diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 14842b9..45a292c 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -3730,6 +3730,7 @@ namespace eval punk::ansi::ansistring { proc _splits_trimright {sclist} { set intext 0 set outlist [list] + #we need to account for empty ansiblock var caused by dual-var iteration over odd length list foreach {pt ansiblock} [lreverse $sclist] { if {$ansiblock ne ""} { if {!$intext} { @@ -3761,11 +3762,13 @@ namespace eval punk::ansi::ansistring { proc _splits_trim {sclist} { return [_splits_trimright [_splits_trimleft $sclist]] } - + + #Note that trim/trimleft/trimright will trim spaces at the extremities that are styled with background colour, underline etc + #that may be unexpected, but it's probably the only thing that makes sense. Plain string trim can chop off whitespace that is extraneous to the ansi entirely. proc trimleft {string args} { set intext 0 set out "" - #for split_codes only first or last pt can be empty string + #for split_codes only first or last pt can be empty string - but we can also get an empty ansiblock by using foreach with 2 vars on an odd-length list foreach {pt ansiblock} [split_codes $string] { if {!$intext} { if {$pt eq "" || [regexp {^\s+$} $pt]} { @@ -3781,10 +3784,8 @@ namespace eval punk::ansi::ansistring { return $out } proc trimright {string} { - #broken! if {$string eq ""} {return ""} ;#excludes the case where split_codes would return nothing - #jmn - set rtrimmed_list [lreverse [_splits_trimright [lreverse [split_codes $string]]]] + set rtrimmed_list [_splits_trimright [split_codes $string]] return [join $rtrimmed_list ""] } proc trim {string} { diff --git a/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm b/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm index e2c8e42..0a6150f 100644 --- a/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm @@ -466,7 +466,7 @@ namespace eval punk::mix::commandset::loadedlib { 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 {$answer ne "y"} { + 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 } @@ -486,7 +486,7 @@ namespace eval punk::mix::commandset::loadedlib { if {$opt_askme} { set question "Copy anyway? Y|N" set answer [punk::lib::askuser $question] - if {$answer ne "y"} { + 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 } diff --git a/src/vendormodules/uuid-1.0.7.tm b/src/vendormodules/uuid-1.0.7.tm new file mode 100644 index 0000000..fbd43f3 --- /dev/null +++ b/src/vendormodules/uuid-1.0.7.tm @@ -0,0 +1,245 @@ +# uuid.tcl - Copyright (C) 2004 Pat Thoyts +# +# UUIDs are 128 bit values that attempt to be unique in time and space. +# +# Reference: +# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt +# +# uuid: scheme: +# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html +# +# Usage: uuid::uuid generate +# uuid::uuid equal $idA $idB + +package require Tcl 8.5 + +namespace eval uuid { + variable accel + array set accel {critcl 0} + + namespace export uuid + + variable uid + if {![info exists uid]} { + set uid 1 + } + + proc K {a b} {set a} +} + +### +# Optimization +# Caches machine info after the first pass +### + +proc ::uuid::generate_tcl_machinfo {} { + variable machinfo + if {[info exists machinfo]} { + return $machinfo + } + lappend machinfo [clock seconds]; # timestamp + lappend machinfo [clock clicks]; # system incrementing counter + lappend machinfo [info hostname]; # spatial unique id (poor) + lappend machinfo [pid]; # additional entropy + lappend machinfo [array get ::tcl_platform] + + ### + # If we have /dev/urandom just stream 128 bits from that + ### + if {[file exists /dev/urandom]} { + set fin [open /dev/urandom r] + binary scan [read $fin 128] H* machinfo + close $fin + } elseif {[catch {package require nettool}]} { + # More spatial information -- better than hostname. + # bug 1150714: opening a server socket may raise a warning messagebox + # with WinXP firewall, using ipconfig will return all IP addresses + # including ipv6 ones if available. ipconfig is OK on win98+ + if {[string equal $::tcl_platform(platform) "windows"]} { + catch {exec ipconfig} config + lappend machinfo $config + } else { + catch { + set s [socket -server void -myaddr [info hostname] 0] + K [fconfigure $s -sockname] [close $s] + } r + lappend machinfo $r + } + + if {[package provide Tk] != {}} { + lappend machinfo [winfo pointerxy .] + lappend machinfo [winfo id .] + } + } else { + ### + # If the nettool package works on this platform + # use the stream of hardware ids from it + ### + lappend machinfo {*}[::nettool::hwid_list] + } + return $machinfo +} + +# Generates a binary UUID as per the draft spec. We generate a pseudo-random +# type uuid (type 4). See section 3.4 +# +proc ::uuid::generate_tcl {} { + package require md5 2 + variable uid + + set tok [md5::MD5Init] + md5::MD5Update $tok [incr uid]; # package incrementing counter + foreach string [generate_tcl_machinfo] { + md5::MD5Update $tok $string + } + set r [md5::MD5Final $tok] + binary scan $r c* r + + # 3.4: set uuid versioning fields + lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] + lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] + + return [binary format c* $r] +} + +if {[string equal $tcl_platform(platform) "windows"] + && [package provide critcl] != {}} { + namespace eval uuid { + critcl::ccode { + #define WIN32_LEAN_AND_MEAN + #define STRICT + #include + #include + typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); + typedef const unsigned char cu_char; + } + critcl::cproc generate_c {Tcl_Interp* interp} ok { + HRESULT hr = S_OK; + int r = TCL_OK; + UUID uuid = {0}; + HMODULE hLib; + LPFNUUIDCREATE lpfnUuidCreate = NULL; + hLib = LoadLibraryA(("rpcrt4.dll")); + if (hLib) + lpfnUuidCreate = (LPFNUUIDCREATE) + GetProcAddress(hLib, "UuidCreate"); + if (lpfnUuidCreate) { + Tcl_Obj *obj; + lpfnUuidCreate(&uuid); + obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); + Tcl_SetObjResult(interp, obj); + } else { + Tcl_SetResult(interp, "error: failed to create a guid", + TCL_STATIC); + r = TCL_ERROR; + } + return r; + } + } +} + +# Convert a binary uuid into its string representation. +# +proc ::uuid::tostring {uuid} { + binary scan $uuid H* s + foreach {a b} {0 7 8 11 12 15 16 19 20 end} { + append r [string range $s $a $b] - + } + return [string tolower [string trimright $r -]] +} + +# Convert a string representation of a uuid into its binary format. +# +proc ::uuid::fromstring {uuid} { + return [binary format H* [string map {- {}} $uuid]] +} + +# Compare two uuids for equality. +# +proc ::uuid::equal {left right} { + set l [fromstring $left] + set r [fromstring $right] + return [string equal $l $r] +} + +# Call our generate uuid implementation +proc ::uuid::generate {} { + variable accel + if {$accel(critcl)} { + return [generate_c] + } else { + return [generate_tcl] + } +} + +# uuid generate -> string rep of a new uuid +# uuid equal uuid1 uuid2 +# +proc uuid::uuid {cmd args} { + switch -exact -- $cmd { + generate { + if {[llength $args] != 0} { + return -code error "wrong # args:\ + should be \"uuid generate\"" + } + return [tostring [generate]] + } + equal { + if {[llength $args] != 2} { + return -code error "wrong \# args:\ + should be \"uuid equal uuid1 uuid2\"" + } + return [eval [linsert $args 0 equal]] + } + default { + return -code error "bad option \"$cmd\":\ + must be generate or equal" + } + } +} + +# ------------------------------------------------------------------------- + +# 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 ::uuid::LoadAccelerator {name} { + variable accel + set r 0 + switch -exact -- $name { + critcl { + if {![catch {package require tcllibc}]} { + set r [expr {[info commands ::uuid::generate_c] != {}}] + } + } + default { + return -code error "invalid accelerator package:\ + must be one of [join [array names accel] {, }]" + } + } + set accel($name) $r +} + +# ------------------------------------------------------------------------- + +# Try and load a compiled extension to help. +namespace eval ::uuid { + variable e {} + foreach e {critcl} { + if {[LoadAccelerator $e]} break + } + unset e +} + +package provide uuid 1.0.7 + +# ------------------------------------------------------------------------- +# Local variables: +# mode: tcl +# indent-tabs-mode: nil +# End: