63 changed files with 15921 additions and 1985 deletions
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,296 @@ |
|||||||
|
# -*- 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.3.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) DKF (based on DKF's REST client support class) |
||||||
|
# (C) 2024 JMN - packaging/possible mods |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::rest 999999.0a1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license MIT |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::rest 0 999999.0a1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {punk::rest}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {experimental rest}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::rest] |
||||||
|
#[keywords module rest http] |
||||||
|
#[description] |
||||||
|
#[para] Experimental *basic rest as wrapper over http lib - use tcllib's rest package for a more complete implementation of a rest client |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::rest |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::rest |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require http |
||||||
|
#*** !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::rest::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::rest::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 ---}] |
||||||
|
#} |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::rest { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::rest}] |
||||||
|
#[para] Core API functions for punk::rest |
||||||
|
#[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" |
||||||
|
#} |
||||||
|
|
||||||
|
set objname [namespace current]::matrixchain |
||||||
|
if {$objname ni [info commands $objname]} { |
||||||
|
# Support class for RESTful web services. |
||||||
|
# This wraps up the http package to make everything appear nicer. |
||||||
|
oo::class create CLIENT { |
||||||
|
variable base wadls acceptedmimetypestack |
||||||
|
|
||||||
|
constructor baseURL { |
||||||
|
set base $baseURL |
||||||
|
my LogWADL $baseURL |
||||||
|
} |
||||||
|
|
||||||
|
# TODO: Cookies! |
||||||
|
|
||||||
|
method ExtractError {tok} { |
||||||
|
return [http::code $tok],[http::data $tok] |
||||||
|
} |
||||||
|
|
||||||
|
method OnRedirect {tok location} { |
||||||
|
upvar 1 url url |
||||||
|
set url $location |
||||||
|
# By default, GET doesn't follow redirects; the next line would |
||||||
|
# change that... |
||||||
|
#return -code continue |
||||||
|
set where $location |
||||||
|
my LogWADL $where |
||||||
|
if {[string equal -length [string length $base/] $location $base/]} { |
||||||
|
set where [string range $where [string length $base/] end] |
||||||
|
return -level 2 [split $where /] |
||||||
|
} |
||||||
|
return -level 2 $where |
||||||
|
} |
||||||
|
|
||||||
|
method LogWADL url { |
||||||
|
return;# do nothing |
||||||
|
set tok [http::geturl $url?_wadl] |
||||||
|
set w [http::data $tok] |
||||||
|
http::cleanup $tok |
||||||
|
if {![info exist wadls($w)]} { |
||||||
|
set wadls($w) 1 |
||||||
|
puts stderr $w |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
method PushAcceptedMimeTypes args { |
||||||
|
lappend acceptedmimetypestack [http::config -accept] |
||||||
|
http::config -accept [join $args ", "] |
||||||
|
return |
||||||
|
} |
||||||
|
method PopAcceptedMimeTypes {} { |
||||||
|
set old [lindex $acceptedmimetypestack end] |
||||||
|
set acceptedmimetypestack [lrange $acceptedmimetypestack 0 end-1] |
||||||
|
http::config -accept $old |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method DoRequest {method url {type ""} {value ""}} { |
||||||
|
for {set reqs 0} {$reqs < 5} {incr reqs} { |
||||||
|
if {[info exists tok]} { |
||||||
|
http::cleanup $tok |
||||||
|
} |
||||||
|
set tok [http::geturl $url -method $method -type $type -query $value] |
||||||
|
if {[http::ncode $tok] > 399} { |
||||||
|
set msg [my ExtractError $tok] |
||||||
|
http::cleanup $tok |
||||||
|
return -code error $msg |
||||||
|
} elseif {[http::ncode $tok] > 299 || [http::ncode $tok] == 201} { |
||||||
|
set location {} |
||||||
|
if {[catch { |
||||||
|
set location [dict get [http::meta $tok] Location] |
||||||
|
}]} { |
||||||
|
http::cleanup $tok |
||||||
|
error "missing a location header!" |
||||||
|
} |
||||||
|
my OnRedirect $tok $location |
||||||
|
} else { |
||||||
|
set s [http::data $tok] |
||||||
|
http::cleanup $tok |
||||||
|
return $s |
||||||
|
} |
||||||
|
} |
||||||
|
error "too many redirections!" |
||||||
|
} |
||||||
|
|
||||||
|
method GET args { |
||||||
|
return [my DoRequest GET $base/[join $args /]] |
||||||
|
} |
||||||
|
|
||||||
|
method POST {args} { |
||||||
|
set type [lindex $args end-1] |
||||||
|
set value [lindex $args end] |
||||||
|
set m POST |
||||||
|
set path [join [lrange $args 0 end-2] /] |
||||||
|
return [my DoRequest $m $base/$path $type $value] |
||||||
|
} |
||||||
|
|
||||||
|
method PUT {args} { |
||||||
|
set type [lindex $args end-1] |
||||||
|
set value [lindex $args end] |
||||||
|
set m PUT |
||||||
|
set path [join [lrange $args 0 end-2] /] |
||||||
|
return [my DoRequest $m $base/$path $type $value] |
||||||
|
} |
||||||
|
|
||||||
|
method DELETE args { |
||||||
|
set m DELETE |
||||||
|
my DoRequest $m $base/[join $args /] |
||||||
|
return |
||||||
|
} |
||||||
|
export GET POST PUT DELETE |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::rest ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::rest::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::rest::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::rest::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
#tcl::namespace::eval punk::rest::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::rest::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::rest [tcl::namespace::eval punk::rest { |
||||||
|
variable pkg punk::rest |
||||||
|
variable version |
||||||
|
set version 999999.0a1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,3 @@ |
|||||||
|
0.1.0 |
||||||
|
#First line must be a semantic version number |
||||||
|
#all other lines are ignored. |
||||||
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,246 @@ |
|||||||
|
# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||||
|
# |
||||||
|
# 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 9 |
||||||
|
|
||||||
|
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] |
||||||
|
fconfigure $fin -encoding binary |
||||||
|
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 <windows.h> |
||||||
|
#include <ole2.h> |
||||||
|
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.8 |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# Local variables: |
||||||
|
# mode: tcl |
||||||
|
# indent-tabs-mode: nil |
||||||
|
# End: |
||||||
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,246 @@ |
|||||||
|
# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||||
|
# |
||||||
|
# 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 9 |
||||||
|
|
||||||
|
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] |
||||||
|
fconfigure $fin -encoding binary |
||||||
|
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 <windows.h> |
||||||
|
#include <ole2.h> |
||||||
|
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.8 |
||||||
|
|
||||||
|
# ------------------------------------------------------------------------- |
||||||
|
# Local variables: |
||||||
|
# mode: tcl |
||||||
|
# indent-tabs-mode: nil |
||||||
|
# End: |
||||||
Binary file not shown.
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,296 @@ |
|||||||
|
# -*- 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.3.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) DKF (based on DKF's REST client support class) |
||||||
|
# (C) 2024 JMN - packaging/possible mods |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::rest 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license MIT |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::rest 0 0.1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {punk::rest}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {experimental rest}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::rest] |
||||||
|
#[keywords module rest http] |
||||||
|
#[description] |
||||||
|
#[para] Experimental *basic rest as wrapper over http lib - use tcllib's rest package for a more complete implementation of a rest client |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::rest |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::rest |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require http |
||||||
|
#*** !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::rest::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::rest::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 ---}] |
||||||
|
#} |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::rest { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::rest}] |
||||||
|
#[para] Core API functions for punk::rest |
||||||
|
#[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" |
||||||
|
#} |
||||||
|
|
||||||
|
set objname [namespace current]::matrixchain |
||||||
|
if {$objname ni [info commands $objname]} { |
||||||
|
# Support class for RESTful web services. |
||||||
|
# This wraps up the http package to make everything appear nicer. |
||||||
|
oo::class create CLIENT { |
||||||
|
variable base wadls acceptedmimetypestack |
||||||
|
|
||||||
|
constructor baseURL { |
||||||
|
set base $baseURL |
||||||
|
my LogWADL $baseURL |
||||||
|
} |
||||||
|
|
||||||
|
# TODO: Cookies! |
||||||
|
|
||||||
|
method ExtractError {tok} { |
||||||
|
return [http::code $tok],[http::data $tok] |
||||||
|
} |
||||||
|
|
||||||
|
method OnRedirect {tok location} { |
||||||
|
upvar 1 url url |
||||||
|
set url $location |
||||||
|
# By default, GET doesn't follow redirects; the next line would |
||||||
|
# change that... |
||||||
|
#return -code continue |
||||||
|
set where $location |
||||||
|
my LogWADL $where |
||||||
|
if {[string equal -length [string length $base/] $location $base/]} { |
||||||
|
set where [string range $where [string length $base/] end] |
||||||
|
return -level 2 [split $where /] |
||||||
|
} |
||||||
|
return -level 2 $where |
||||||
|
} |
||||||
|
|
||||||
|
method LogWADL url { |
||||||
|
return;# do nothing |
||||||
|
set tok [http::geturl $url?_wadl] |
||||||
|
set w [http::data $tok] |
||||||
|
http::cleanup $tok |
||||||
|
if {![info exist wadls($w)]} { |
||||||
|
set wadls($w) 1 |
||||||
|
puts stderr $w |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
method PushAcceptedMimeTypes args { |
||||||
|
lappend acceptedmimetypestack [http::config -accept] |
||||||
|
http::config -accept [join $args ", "] |
||||||
|
return |
||||||
|
} |
||||||
|
method PopAcceptedMimeTypes {} { |
||||||
|
set old [lindex $acceptedmimetypestack end] |
||||||
|
set acceptedmimetypestack [lrange $acceptedmimetypestack 0 end-1] |
||||||
|
http::config -accept $old |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
method DoRequest {method url {type ""} {value ""}} { |
||||||
|
for {set reqs 0} {$reqs < 5} {incr reqs} { |
||||||
|
if {[info exists tok]} { |
||||||
|
http::cleanup $tok |
||||||
|
} |
||||||
|
set tok [http::geturl $url -method $method -type $type -query $value] |
||||||
|
if {[http::ncode $tok] > 399} { |
||||||
|
set msg [my ExtractError $tok] |
||||||
|
http::cleanup $tok |
||||||
|
return -code error $msg |
||||||
|
} elseif {[http::ncode $tok] > 299 || [http::ncode $tok] == 201} { |
||||||
|
set location {} |
||||||
|
if {[catch { |
||||||
|
set location [dict get [http::meta $tok] Location] |
||||||
|
}]} { |
||||||
|
http::cleanup $tok |
||||||
|
error "missing a location header!" |
||||||
|
} |
||||||
|
my OnRedirect $tok $location |
||||||
|
} else { |
||||||
|
set s [http::data $tok] |
||||||
|
http::cleanup $tok |
||||||
|
return $s |
||||||
|
} |
||||||
|
} |
||||||
|
error "too many redirections!" |
||||||
|
} |
||||||
|
|
||||||
|
method GET args { |
||||||
|
return [my DoRequest GET $base/[join $args /]] |
||||||
|
} |
||||||
|
|
||||||
|
method POST {args} { |
||||||
|
set type [lindex $args end-1] |
||||||
|
set value [lindex $args end] |
||||||
|
set m POST |
||||||
|
set path [join [lrange $args 0 end-2] /] |
||||||
|
return [my DoRequest $m $base/$path $type $value] |
||||||
|
} |
||||||
|
|
||||||
|
method PUT {args} { |
||||||
|
set type [lindex $args end-1] |
||||||
|
set value [lindex $args end] |
||||||
|
set m PUT |
||||||
|
set path [join [lrange $args 0 end-2] /] |
||||||
|
return [my DoRequest $m $base/$path $type $value] |
||||||
|
} |
||||||
|
|
||||||
|
method DELETE args { |
||||||
|
set m DELETE |
||||||
|
my DoRequest $m $base/[join $args /] |
||||||
|
return |
||||||
|
} |
||||||
|
export GET POST PUT DELETE |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::rest ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::rest::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::rest::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::rest::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
#tcl::namespace::eval punk::rest::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::rest::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::rest [tcl::namespace::eval punk::rest { |
||||||
|
variable pkg punk::rest |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
Binary file not shown.
Loading…
Reference in new issue