73 changed files with 3156 additions and 20925 deletions
Binary file not shown.
Binary file not shown.
Binary file not shown.
@ -0,0 +1,34 @@
|
||||
# patterns to exclude when searching directories. defaults to empty list. |
||||
# follows gitignore pattern format: https://git-scm.com/docs/gitignore#_pattern_format |
||||
# the one exception is that a leading "#" character will be automatically escaped |
||||
#exclude = ["ignore_me/", "ignore*.tcl", "/ignore_from_here"] |
||||
# lint violations to ignore. defaults to empty list. |
||||
# can also supply an inline table with a path and a list of violations to ignore under that path. |
||||
|
||||
#ignore = [ |
||||
# "unbraced-expr", |
||||
# { path = "files_with_long_lines/", rules = ["line-length"] } |
||||
#] |
||||
|
||||
# extensions of files to lint when searching directories. defaults to tcl, sdc, |
||||
# xdc, and upf. |
||||
extensions = ["tcl", "tm", "sdc"] |
||||
# path to command spec defining tool-specific commands and arguments, generated by |
||||
# `tclint-plugins make-spec`. |
||||
|
||||
#commands = "~/.tclint/openroad.json" |
||||
|
||||
# with the exception of line-length, the [style] settings affect tclfmt rather than tclint. |
||||
|
||||
[style] |
||||
# number of spaces to indent. can also be set to "tab". defaults to 4. |
||||
#indent = 2 |
||||
# maximum allowed line length. defaults to 100. |
||||
line-length = 400 |
||||
# maximum allowed number of consecutive blank lines. defaults to 2. |
||||
max-blank-lines = 10 |
||||
# whether to require indenting of "namespace eval" blocks. defaults to true. |
||||
#indent-namespace-eval = false |
||||
# whether to expect a single space (true) or no spaces (false) surrounding the contents of a braced expression or script argument. |
||||
# defaults to false. |
||||
#spaces-in-braces = true |
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,829 +0,0 @@
|
||||
#package require logger |
||||
|
||||
|
||||
package require Thread |
||||
|
||||
namespace eval shellthread { |
||||
|
||||
proc iso8601 {{tsmicros ""}} { |
||||
if {$tsmicros eq ""} { |
||||
set tsmicros [tcl::clock::microseconds] |
||||
} else { |
||||
set microsnow [tcl::clock::microseconds] |
||||
if {[tcl::string::length $tsmicros] != [tcl::string::length $microsnow]} { |
||||
error "iso8601 requires 'clock micros' or empty string to create timestamp" |
||||
} |
||||
} |
||||
set seconds [expr {$tsmicros / 1000000}] |
||||
return [tcl::clock::format $seconds -format "%Y-%m-%d_%H-%M-%S"] |
||||
} |
||||
} |
||||
|
||||
namespace eval shellthread::worker { |
||||
variable settings |
||||
variable sysloghost_port |
||||
variable sock |
||||
variable logfile "" |
||||
variable fd |
||||
variable client_ids [list] |
||||
variable ts_start_micros |
||||
variable errorlist [list] |
||||
variable inpipe "" |
||||
|
||||
proc bgerror {args} { |
||||
variable errorlist |
||||
lappend errorlist $args |
||||
} |
||||
proc send_errors_now {tidcli} { |
||||
variable errorlist |
||||
thread::send -async $tidcli [list shellthread::manager::report_worker_errors [list worker_tid [thread::id] errors $errorlist]] |
||||
} |
||||
proc add_client_tid {tidcli} { |
||||
variable client_ids |
||||
if {$tidcli ni $client_ids} { |
||||
lappend client_ids $tidcli |
||||
} |
||||
} |
||||
proc init {tidclient start_m settingsdict} { |
||||
variable sysloghost_port |
||||
variable logfile |
||||
variable settings |
||||
interp bgerror {} shellthread::worker::bgerror |
||||
#package require overtype ;#overtype uses tcllib textutil, punk::char etc - currently too heavyweight in terms of loading time for use in threads. |
||||
variable client_ids |
||||
variable ts_start_micros |
||||
lappend client_ids $tidclient |
||||
set ts_start_micros $start_m |
||||
|
||||
set defaults [list -raw 0 -file "" -syslog "" -direction out] |
||||
set settings [dict merge $defaults $settingsdict] |
||||
|
||||
set syslog [dict get $settings -syslog] |
||||
if {[string length $syslog]} { |
||||
lassign [split $syslog :] s_host s_port |
||||
set sysloghost_port [list $s_host $s_port] |
||||
if {[catch {package require udp} errm]} { |
||||
#disable rather than bomb and interfere with any -file being written |
||||
#review - log/notify? |
||||
set sysloghost_port "" |
||||
} |
||||
} else { |
||||
set sysloghost_port "" |
||||
} |
||||
|
||||
set logfile [dict get $settings -file] |
||||
} |
||||
|
||||
proc start_pipe_read {source readchan args} { |
||||
#assume 1 inpipe for now |
||||
variable inpipe |
||||
variable sysloghost_port |
||||
variable logfile |
||||
|
||||
set defaults [dict create -buffering \uFFFF ] |
||||
set opts [dict merge $defaults $args] |
||||
if {[dict exists $opts -readbuffering]} { |
||||
set readbuffering [dict get $opts -readbuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
#get buffering setting from the channel as it was set prior to thread::transfer |
||||
set readbuffering [chan configure $readchan -buffering] |
||||
} else { |
||||
set readbuffering [dict get $opts -buffering] |
||||
chan configure $readchan -buffering $readbuffering |
||||
} |
||||
} |
||||
if {[dict exists $opts -writebuffering]} { |
||||
set writebuffering [dict get $opts -writebuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
set writebuffering line |
||||
#set writebuffering [chan configure $writechan -buffering] |
||||
} else { |
||||
set writebuffering [dict get $opts -buffering] |
||||
#can configure $writechan -buffering $writebuffering |
||||
} |
||||
} |
||||
|
||||
chan configure $readchan -translation lf |
||||
|
||||
if {$readchan ni [chan names]} { |
||||
error "shellthread::worker::start_pipe_read - inpipe not configured. Use shellthread::manager::set_pipe_read_from_client to thread::transfer the pipe end" |
||||
} |
||||
set inpipe $readchan |
||||
chan configure $readchan -blocking 0 |
||||
set waitvar ::shellthread::worker::wait($inpipe,[clock micros]) |
||||
|
||||
#tcl::chan::fifo2 based pipe seems slower to establish events upon than Memchan |
||||
chan event $readchan readable [list ::shellthread::worker::pipe_read $readchan $source $waitvar $readbuffering $writebuffering] |
||||
vwait $waitvar |
||||
} |
||||
proc pipe_read {chan source waitfor readbuffering writebuffering} { |
||||
if {$readbuffering eq "line"} { |
||||
set chunksize [chan gets $chan chunk] |
||||
if {$chunksize >= 0} { |
||||
if {![chan eof $chan]} { |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk\n $writebuffering |
||||
} else { |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering |
||||
} |
||||
} |
||||
} else { |
||||
set chunk [chan read $chan] |
||||
::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering |
||||
} |
||||
if {[chan eof $chan]} { |
||||
chan event $chan readable {} |
||||
set $waitfor "pipe" |
||||
chan close $chan |
||||
} |
||||
} |
||||
|
||||
proc start_pipe_write {source writechan args} { |
||||
variable outpipe |
||||
set defaults [dict create -buffering \uFFFF ] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
#todo! |
||||
set readchan stdin |
||||
|
||||
if {[dict exists $opts -readbuffering]} { |
||||
set readbuffering [dict get $opts -readbuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
set readbuffering [chan configure $readchan -buffering] |
||||
} else { |
||||
set readbuffering [dict get $opts -buffering] |
||||
chan configure $readchan -buffering $readbuffering |
||||
} |
||||
} |
||||
if {[dict exists $opts -writebuffering]} { |
||||
set writebuffering [dict get $opts -writebuffering] |
||||
} else { |
||||
if {[dict get $opts -buffering] eq "\uFFFF"} { |
||||
#nothing explicitly set - take from transferred channel |
||||
set writebuffering [chan configure $writechan -buffering] |
||||
} else { |
||||
set writebuffering [dict get $opts -buffering] |
||||
can configure $writechan -buffering $writebuffering |
||||
} |
||||
} |
||||
|
||||
if {$writechan ni [chan names]} { |
||||
error "shellthread::worker::start_pipe_write - outpipe not configured. Use shellthread::manager::set_pipe_write_to_client to thread::transfer the pipe end" |
||||
} |
||||
set outpipe $writechan |
||||
chan configure $readchan -blocking 0 |
||||
chan configure $writechan -blocking 0 |
||||
set waitvar ::shellthread::worker::wait($outpipe,[clock micros]) |
||||
|
||||
chan event $readchan readable [list apply {{chan writechan source waitfor readbuffering} { |
||||
if {$readbuffering eq "line"} { |
||||
set chunksize [chan gets $chan chunk] |
||||
if {$chunksize >= 0} { |
||||
if {![chan eof $chan]} { |
||||
puts $writechan $chunk |
||||
} else { |
||||
puts -nonewline $writechan $chunk |
||||
} |
||||
} |
||||
} else { |
||||
set chunk [chan read $chan] |
||||
puts -nonewline $writechan $chunk |
||||
} |
||||
if {[chan eof $chan]} { |
||||
chan event $chan readable {} |
||||
set $waitfor "pipe" |
||||
chan close $writechan |
||||
if {$chan ne "stdin"} { |
||||
chan close $chan |
||||
} |
||||
} |
||||
}} $readchan $writechan $source $waitvar $readbuffering] |
||||
|
||||
vwait $waitvar |
||||
} |
||||
|
||||
|
||||
proc _initsock {} { |
||||
variable sysloghost_port |
||||
variable sock |
||||
if {[string length $sysloghost_port]} { |
||||
if {[catch {chan configure $sock} state]} { |
||||
set sock [udp_open] |
||||
chan configure $sock -buffering none -translation binary |
||||
chan configure $sock -remote $sysloghost_port |
||||
} |
||||
} |
||||
} |
||||
proc _reconnect {} { |
||||
variable sock |
||||
catch {close $sock} |
||||
_initsock |
||||
return [chan configure $sock] |
||||
} |
||||
|
||||
proc send_info {client_tid ts_sent source msg} { |
||||
set ts_received [clock micros] |
||||
set lag_micros [expr {$ts_received - $ts_sent}] |
||||
set lag [expr {$lag_micros / 1000000.0}] ;#lag as x.xxxxxx seconds |
||||
log $client_tid $ts_sent $lag $source - info $msg line 1 |
||||
} |
||||
proc log {client_tid ts_sent lag source service level msg writebuffering {islog 0}} { |
||||
variable sock |
||||
variable fd |
||||
variable sysloghost_port |
||||
variable logfile |
||||
variable settings |
||||
|
||||
set logchunk $msg |
||||
|
||||
if {![dict get $settings -raw]} { |
||||
set tail_crlf 0 |
||||
set tail_lf 0 |
||||
set tail_cr 0 |
||||
#for cooked - always remove the trailing newline before splitting.. |
||||
# |
||||
#note that if we got our data from reading a non-line-buffered binary channel - then this naive line splitting will not split neatly for mixed line-endings. |
||||
# |
||||
#Possibly not critical as cooked is for logging and we are still preserving all \r and \n chars - but review and consider implementing a better split |
||||
#but add it back exactly as it was afterwards |
||||
#we can always split on \n - and any adjacent \r will be preserved in the rejoin |
||||
set lastchar [string range $logchunk end end] |
||||
if {[string range $logchunk end-1 end] eq "\r\n"} { |
||||
set tail_crlf 1 |
||||
set logchunk [string range $logchunk 0 end-2] |
||||
} else { |
||||
if {$lastchar eq "\n"} { |
||||
set tail_lf 1 |
||||
set logchunk [string range $logchunk 0 end-1] |
||||
} elseif {$lastchar eq "\r"} { |
||||
#\r line-endings are obsolete..and unlikely... and ugly as they can hide characters on the console. but we'll pass through anyway. |
||||
set tail_cr 1 |
||||
set logchunk [string range $logchunk 0 end-1] |
||||
} else { |
||||
#possibly a single line with no linefeed.. or has linefeeds only in the middle |
||||
} |
||||
} |
||||
|
||||
if {$ts_sent != 0} { |
||||
set micros [lindex [split [expr {$ts_sent / 1000000.0}] .] end] |
||||
set time_info [::shellthread::iso8601 $ts_sent].$micros |
||||
#set time_info "${time_info}+$lag" |
||||
set lagfp "+[format %f $lag]" |
||||
} else { |
||||
#from pipe - no ts_sent/lag info available |
||||
set time_info "" |
||||
set lagfp "" |
||||
} |
||||
|
||||
set idtail [string range $client_tid end-8 end] ;#enough for display purposes id - mostly zeros anyway |
||||
|
||||
|
||||
#set col0 [string repeat " " 9] |
||||
#set col1 [string repeat " " 27] |
||||
#set col2 [string repeat " " 11] |
||||
#set col3 [string repeat " " 22] |
||||
##do not columnize the final data column or append to tail - or we could muck up the crlf integrity |
||||
#lassign [list [overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 $lagfp] [overtype::left $col3 $source]] c0 c1 c2 c3 |
||||
|
||||
set w0 9 |
||||
set w1 27 |
||||
set w2 11 |
||||
set w3 22 ;#review - this can truncate source name without indication tail is missing |
||||
#do not columnize the final data column or append to tail - or we could muck up the crlf integrity |
||||
lassign [list \ |
||||
[format %-${w0}s $idtail]\ |
||||
[format %-${w1}s $time_info]\ |
||||
[format %-${w2}s $lagfp]\ |
||||
[format %-${w3}s $source]\ |
||||
] c0 c1 c2 c3 |
||||
set c2_blank [string repeat " " $w2] |
||||
|
||||
|
||||
#split on \n no matter the actual line-ending in use |
||||
#shouldn't matter as long as we don't add anything at the end of the line other than the raw data |
||||
#ie - don't quote or add spaces |
||||
set lines [split $logchunk \n] |
||||
|
||||
set i 1 |
||||
set outlines [list] |
||||
foreach ln $lines { |
||||
if {$i == 1} { |
||||
lappend outlines "$c0 $c1 $c2 $c3 $ln" |
||||
} else { |
||||
lappend outlines "$c0 $c1 $c2_blank $c3 $ln" |
||||
} |
||||
incr i |
||||
} |
||||
if {$tail_lf} { |
||||
set logchunk "[join $outlines \n]\n" |
||||
} elseif {$tail_crlf} { |
||||
set logchunk "[join $outlines \r\n]\r\n" |
||||
} elseif {$tail_cr} { |
||||
set logchunk "[join $outlines \r]\r" |
||||
} else { |
||||
#no trailing linefeed |
||||
set logchunk [join $outlines \n] |
||||
|
||||
} |
||||
|
||||
#set logchunk "[overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 "+$lagfp"] [overtype::left $col3 $source] $msg" |
||||
} |
||||
|
||||
if {[string length $sysloghost_port]} { |
||||
_initsock |
||||
catch {puts -nonewline $sock $logchunk} |
||||
} |
||||
#todo - sockets etc? |
||||
if {[string length $logfile]} { |
||||
#todo - setting to maintain open filehandle and reduce io. |
||||
# possible settings for buffersize - and maybe logrotation, although this could be left to client |
||||
#for now - default to safe option of open/close each write despite the overhead. |
||||
set fd [open $logfile a] |
||||
chan configure $fd -translation auto -buffering $writebuffering |
||||
#whether line buffered or not - by now our logchunk includes newlines |
||||
puts -nonewline $fd $logchunk |
||||
close $fd |
||||
} |
||||
} |
||||
|
||||
# - withdraw just this client |
||||
proc finish {tidclient} { |
||||
variable client_ids |
||||
if {($tidclient in $clientids) && ([llength $clientids] == 1)} { |
||||
terminate $tidclient |
||||
} else { |
||||
set posn [lsearch $client_ids $tidclient] |
||||
set client_ids [lreplace $clientids $posn $posn] |
||||
} |
||||
} |
||||
|
||||
#allow any client to terminate |
||||
proc terminate {tidclient} { |
||||
variable sock |
||||
variable fd |
||||
variable client_ids |
||||
if {$tidclient in $client_ids} { |
||||
catch {close $sock} |
||||
catch {close $fd} |
||||
set client_ids [list] |
||||
#review use of thread::release -wait |
||||
#docs indicate deprecated for regular use, and that we should use thread::join |
||||
#however.. how can we set a timeout on a thread::join ? |
||||
#by telling the thread to release itself - we can wait on the thread::send variable |
||||
# This needs review - because it's unclear that -wait even works on self |
||||
# (what does it mean to wait for the target thread to exit if the target is self??) |
||||
thread::release -wait |
||||
return [thread::id] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
namespace eval shellthread::manager { |
||||
variable workers [dict create] |
||||
variable worker_errors [list] |
||||
variable timeouts |
||||
|
||||
variable free_threads [list] |
||||
#variable log_threads |
||||
|
||||
proc dict_getdef {dictValue args} { |
||||
if {[llength $args] < 2} { |
||||
error {wrong # args: should be "dict_getdef dictValue ?key ...? key default"} |
||||
} |
||||
set keys [lrange $args 0 end-1] |
||||
if {[tcl::dict::exists $dictValue {*}$keys]} { |
||||
return [tcl::dict::get $dictValue {*}$keys] |
||||
} else { |
||||
return [lindex $args end] |
||||
} |
||||
} |
||||
#new datastructure regarding workers and sourcetags required. |
||||
#one worker can service multiple sourcetags - but each sourcetag may be used by multiple threads too. |
||||
#generally each thread will use a specific sourcetag - but we may have pools doing similar things which log to same destination. |
||||
# |
||||
#As a convention we may use a sourcetag for the thread which started the worker that isn't actually used for logging - but as a common target for joins |
||||
#If the thread which started the thread calls leave_worker with that 'primary' sourcetag it means others won't be able to use that target - which seems reasonable. |
||||
#If another thread want's to maintain joinability beyond the span provided by the starting client, |
||||
#it can join with both the primary tag and a tag it will actually use for logging. |
||||
#A thread can join the logger with any existingtag - not just the 'primary' |
||||
#(which is arbitrary anyway. It will usually be the first in the list - but may be unsubscribed by clients and disappear) |
||||
proc join_worker {existingtag sourcetaglist} { |
||||
set client_tid [thread::id] |
||||
#todo - allow a source to piggyback on existing worker by referencing one of the sourcetags already using the worker |
||||
} |
||||
|
||||
proc new_pipe_worker {sourcetaglist {settingsdict {}}} { |
||||
if {[dict exists $settingsdict -workertype]} { |
||||
if {[string tolower [dict get $settingsdict -workertype]] ne "pipe"} { |
||||
error "new_pipe_worker error: -workertype ne 'pipe'. Set to 'pipe' or leave empty" |
||||
} |
||||
} |
||||
dict set settingsdict -workertype pipe |
||||
new_worker $sourcetaglist $settingsdict |
||||
} |
||||
|
||||
#it is up to caller to use a unique sourcetag (e.g by prefixing with own thread::id etc) |
||||
# This allows multiple threads to more easily write to the same named sourcetag if necessary |
||||
# todo - change sourcetag for a list of tags which will be handled by the same thread. e.g for multiple threads logging to same file |
||||
# |
||||
# todo - some protection mechanism for case where target is a file to stop creation of multiple worker threads writing to same file. |
||||
# Even if we use open fd,close fd wrapped around writes.. it is probably undesirable to have multiple threads with same target |
||||
# On the other hand socket targets such as UDP can happily be written to by multiple threads. |
||||
# For now the mechanism is that a call to new_worker (rename to open_worker?) will join the same thread if a sourcetag matches. |
||||
# but, as sourcetags can get removed(unsubbed via leave_worker) this doesn't guarantee two threads with same -file settings won't fight. |
||||
# Also.. the settingsdict is ignored when joining with a tag that exists.. this is problematic.. e.g logrotation where previous file still being written by existing worker |
||||
# todo - rename 'sourcetag' concept to 'targettag' ?? the concept is a mixture of both.. it is somewhat analagous to a syslog 'facility' |
||||
# probably new_worker should disallow auto-joining and we allow different workers to handle same tags simultaneously to support overlap during logrotation etc. |
||||
proc new_worker {sourcetaglist {settingsdict {}}} { |
||||
variable workers |
||||
set ts_start [clock micros] |
||||
set tidclient [thread::id] |
||||
set sourcetag [lindex $sourcetaglist 0] ;#todo - use all |
||||
|
||||
set defaults [dict create\ |
||||
-workertype message\ |
||||
] |
||||
set settingsdict [dict merge $defaults $settingsdict] |
||||
|
||||
set workertype [string tolower [dict get $settingsdict -workertype]] |
||||
set known_workertypes [list pipe message] |
||||
if {$workertype ni $known_workertypes} { |
||||
error "new_worker - unknown -workertype $workertype. Expected one of '$known_workertypes'" |
||||
} |
||||
|
||||
if {[dict exists $workers $sourcetag]} { |
||||
set winfo [dict get $workers $sourcetag] |
||||
if {[dict get $winfo tid] ne "noop" && [thread::exists [dict get $winfo tid]]} { |
||||
#add our client-info to existing worker thread |
||||
dict lappend winfo list_client_tids $tidclient |
||||
dict set workers $sourcetag $winfo ;#writeback |
||||
return [dict get $winfo tid] |
||||
} |
||||
} |
||||
|
||||
#noop fake worker for empty syslog and empty file |
||||
if {$workertype eq "message"} { |
||||
if {[dict_getdef $settingsdict -syslog ""] eq "" && [dict_getdef $settingsdict -file ""] eq ""} { |
||||
set winfo [dict create tid noop list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list] workertype "message"] |
||||
dict set workers $sourcetag $winfo |
||||
return noop |
||||
} |
||||
} |
||||
|
||||
#check if there is an existing unsubscribed thread first |
||||
#don't use free_threads for pipe workertype for now.. |
||||
variable free_threads |
||||
if {$workertype ne "pipe"} { |
||||
if {[llength $free_threads]} { |
||||
#todo - re-use from tail - as most likely to have been doing similar work?? review |
||||
|
||||
set free_threads [lassign $free_threads tidworker] |
||||
#todo - keep track of real ts_start of free threads... kill when too old |
||||
set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list] workertype [dict get $settingsdict -workertype]] |
||||
#puts stderr "shellfilter::new_worker Re-using free worker thread: $tidworker with tag $sourcetag" |
||||
dict set workers $sourcetag $winfo |
||||
return $tidworker |
||||
} |
||||
} |
||||
|
||||
|
||||
#set ts_start [::shellthread::iso8601] |
||||
set tidworker [thread::create -preserved] |
||||
set init_script [string map [list %ts_start% $ts_start %mp% [tcl::tm::list] %ap% $::auto_path %tidcli% $tidclient %sd% $settingsdict] { |
||||
#set tclbase [file dirname [file dirname [info nameofexecutable]]] |
||||
#set tcllib $tclbase/lib |
||||
#if {$tcllib ni $::auto_path} { |
||||
# lappend ::auto_path $tcllib |
||||
#} |
||||
|
||||
set ::settingsinfo [dict create %sd%] |
||||
#if the executable running things is something like a tclkit, |
||||
# then it's likely we will need to use the caller's auto_path and tcl::tm::list to find things |
||||
#The caller can tune the thread's package search by providing a settingsdict |
||||
#tcl::tm::add * must add in reverse order to get reulting list in same order as original |
||||
if {![dict exists $::settingsinfo tcl_tm_list]} { |
||||
#JMN2 |
||||
::tcl::tm::add {*}[lreverse [list %mp%]] |
||||
} else { |
||||
tcl::tm::remove {*}[tcl::tm::list] |
||||
::tcl::tm::add {*}[lreverse [dict get $::settingsinfo tcl_tm_list]] |
||||
} |
||||
if {![dict exists $::settingsinfo auto_path]} { |
||||
set ::auto_path [list %ap%] |
||||
} else { |
||||
set ::auto_path [dict get $::settingsinfo auto_path] |
||||
} |
||||
|
||||
package require punk::packagepreference |
||||
punk::packagepreference::install |
||||
|
||||
package require Thread |
||||
package require shellthread |
||||
if {![catch {::shellthread::worker::init %tidcli% %ts_start% $::settingsinfo} errmsg]} { |
||||
unset ::settingsinfo |
||||
set ::shellthread_init "ok" |
||||
} else { |
||||
unset ::settingsinfo |
||||
set ::shellthread_init "err $errmsg" |
||||
} |
||||
}] |
||||
|
||||
thread::send -async $tidworker $init_script |
||||
#thread::send $tidworker $init_script |
||||
set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list]] |
||||
dict set workers $sourcetag $winfo |
||||
return $tidworker |
||||
} |
||||
|
||||
proc set_pipe_read_from_client {tag_pipename worker_tid rchan args} { |
||||
variable workers |
||||
if {![dict exists $workers $tag_pipename]} { |
||||
error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename not found" |
||||
} |
||||
set match_worker_tid [dict get $workers $tag_pipename tid] |
||||
if {$worker_tid ne $match_worker_tid} { |
||||
error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" |
||||
} |
||||
#buffering set during channel creation will be preserved on thread::transfer |
||||
thread::transfer $worker_tid $rchan |
||||
#start_pipe_read will vwait - so we have to send async |
||||
thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_read $tag_pipename $rchan] |
||||
#client may start writing immediately - but presumably it will buffer in fifo2 |
||||
} |
||||
|
||||
proc set_pipe_write_to_client {tag_pipename worker_tid wchan args} { |
||||
variable workers |
||||
if {![dict exists $workers $tag_pipename]} { |
||||
error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename not found" |
||||
} |
||||
set match_worker_tid [dict get $workers $tag_pipename tid] |
||||
if {$worker_tid ne $match_worker_tid} { |
||||
error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'" |
||||
} |
||||
#buffering set during channel creation will be preserved on thread::transfer |
||||
thread::transfer $worker_tid $wchan |
||||
thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_write $tag_pipename $wchan] |
||||
} |
||||
|
||||
proc write_log {source msg args} { |
||||
variable workers |
||||
set ts_micros_sent [clock micros] |
||||
set defaults [list -async 1 -level info] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
if {[dict exists $workers $source]} { |
||||
set tidworker [dict get $workers $source tid] |
||||
if {$tidworker eq "noop"} { |
||||
return |
||||
} |
||||
if {![thread::exists $tidworker]} { |
||||
# -syslog -file ? |
||||
set tidworker [new_worker $source] |
||||
} |
||||
} else { |
||||
#auto create with no requirement to call new_worker.. warn? |
||||
# -syslog -file ? |
||||
error "write_log no log opened for source: $source" |
||||
set tidworker [new_worker $source] |
||||
} |
||||
set client_tid [thread::id] |
||||
if {[dict get $opts -async]} { |
||||
thread::send -async $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] |
||||
} else { |
||||
thread::send $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg] |
||||
} |
||||
} |
||||
proc report_worker_errors {errdict} { |
||||
variable workers |
||||
set reporting_tid [dict get $errdict worker_tid] |
||||
dict for {src srcinfo} $workers { |
||||
if {[dict get $srcinfo tid] eq $reporting_tid} { |
||||
dict set srcinfo errors [dict get $errdict errors] |
||||
dict set workers $src $srcinfo ;#writeback updated |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
#aka leave_worker |
||||
#Note that the tags may be on separate workertids, or some tags may share workertids |
||||
proc unsubscribe {sourcetaglist} { |
||||
variable workers |
||||
#workers structure example: |
||||
#[list sourcetag1 [list tid <tidworker> list_client_tids <clients>] ts_start <ts_start> ts_end_list {}] |
||||
variable free_threads |
||||
set mytid [thread::id] ;#caller of shellthread::manager::xxx is the client thread |
||||
|
||||
set subscriberless_tags [list] |
||||
foreach source $sourcetaglist { |
||||
if {[dict exists $workers $source]} { |
||||
set list_client_tids [dict get $workers $source list_client_tids] |
||||
if {[set posn [lsearch $list_client_tids $mytid]] >= 0} { |
||||
set list_client_tids [lreplace $list_client_tids $posn $posn] |
||||
dict set workers $source list_client_tids $list_client_tids |
||||
} |
||||
if {![llength $list_client_tids]} { |
||||
lappend subscriberless_tags $source |
||||
} |
||||
} |
||||
} |
||||
|
||||
#we've removed our own tid from all the tags - possibly across multiplew workertids, and possibly leaving some workertids with no subscribers for a particular tag - or no subscribers at all. |
||||
|
||||
set subscriberless_workers [list] |
||||
set shuttingdown_workers [list] |
||||
foreach deadtag $subscriberless_tags { |
||||
set workertid [dict get $workers $deadtag tid] |
||||
set worker_tags [get_worker_tagstate $workertid] |
||||
set subscriber_count 0 |
||||
set kill_count 0 ;#number of ts_end_list entries - even one indicates thread is doomed |
||||
foreach taginfo $worker_tags { |
||||
incr subscriber_count [llength [dict get $taginfo list_client_tids]] |
||||
incr kill_count [llength [dict get $taginfo ts_end_list]] |
||||
} |
||||
if {$subscriber_count == 0} { |
||||
lappend subscriberless_workers $workertid |
||||
} |
||||
if {$kill_count > 0} { |
||||
lappend shuttingdown_workers $workertid |
||||
} |
||||
} |
||||
|
||||
#if worker isn't shutting down - add it to free_threads list |
||||
foreach workertid $subscriberless_workers { |
||||
if {$workertid ni $shuttingdown_workers} { |
||||
if {$workertid ni $free_threads && $workertid ne "noop"} { |
||||
lappend free_threads $workertid |
||||
} |
||||
} |
||||
} |
||||
|
||||
#todo |
||||
#unsub this client_tid from the sourcetags in the sourcetaglist. if no more client_tids exist for sourcetag, remove sourcetag, |
||||
#if no more sourcetags - add worker to free_threads |
||||
} |
||||
proc get_worker_tagstate {workertid} { |
||||
variable workers |
||||
set taginfo_list [list] |
||||
dict for {source sourceinfo} $workers { |
||||
if {[dict get $sourceinfo tid] eq $workertid} { |
||||
lappend taginfo_list $sourceinfo |
||||
} |
||||
} |
||||
return $taginfo_list |
||||
} |
||||
|
||||
#finalisation |
||||
proc shutdown_free_threads {{timeout 2500}} { |
||||
variable free_threads |
||||
if {![llength $free_threads]} { |
||||
return |
||||
} |
||||
upvar ::shellthread::manager::timeouts timeoutarr |
||||
if {[info exists timeoutarr(shutdown_free_threads)]} { |
||||
#already called |
||||
return false |
||||
} |
||||
#set timeoutarr(shutdown_free_threads) waiting |
||||
#after $timeout [list set timeoutarr(shutdown_free_threads) timed-out] |
||||
set ::shellthread::waitfor waiting |
||||
#after $timeout [list set ::shellthread::waitfor] |
||||
#2025-07 timed-out untested review |
||||
set cancelid [after $timeout [list set ::shellthread::waitfor timed-out]] |
||||
|
||||
set waiting_for [list] |
||||
set ended [list] |
||||
set timedout 0 |
||||
foreach tid $free_threads { |
||||
if {[thread::exists $tid]} { |
||||
lappend waiting_for $tid |
||||
#thread::send -async $tid [list shellthread::worker::terminate [thread::id]] timeoutarr(shutdown_free_threads) |
||||
thread::send -async $tid [list shellthread::worker::terminate [thread::id]] ::shellthread::waitfor |
||||
} |
||||
} |
||||
if {[llength $waiting_for]} { |
||||
for {set i 0} {$i < [llength $waiting_for]} {incr i} { |
||||
vwait ::shellthread::waitfor |
||||
if {$::shellthread::waitfor eq "timed-out"} { |
||||
set timedout 1 |
||||
break |
||||
} else { |
||||
after cancel $cancelid |
||||
lappend ended $::shellthread::waitfor |
||||
} |
||||
} |
||||
} |
||||
set free_threads [list] |
||||
return [dict create existed $waiting_for ended $ended timedout $timedout] |
||||
} |
||||
|
||||
#TODO - important. |
||||
#REVIEW! |
||||
#since moving to the unsubscribe mechansm - close_worker $source isn't being called |
||||
# - we need to set a limit to the number of free threads and shut down excess when detected during unsubscription |
||||
#instruction to shut-down the thread that has this source. |
||||
#instruction to shut-down the thread that has this source. |
||||
proc close_worker {source {timeout 2500}} { |
||||
variable workers |
||||
variable worker_errors |
||||
variable free_threads |
||||
upvar ::shellthread::manager::timeouts timeoutarr |
||||
set ts_now [clock micros] |
||||
#puts stderr "close_worker $source" |
||||
if {[dict exists $workers $source]} { |
||||
set tidworker [dict get $workers $source tid] |
||||
if {$tidworker in $freethreads} { |
||||
#make sure a thread that is being closed is removed from the free_threads list |
||||
set posn [lsearch $freethreads $tidworker] |
||||
set freethreads [lreplace $freethreads $posn $posn] |
||||
} |
||||
set mytid [thread::id] |
||||
set client_tids [dict get $workers $source list_client_tids] |
||||
if {[set posn [lsearch $client_tids $mytid]] >= 0} { |
||||
set client_tids [lreplace $client_tids $posn $posn] |
||||
#remove self from list of clients |
||||
dict set workers $source list_client_tids $client_tids |
||||
} |
||||
set ts_end_list [dict get $workers $source ts_end_list] ;#ts_end_list is just a list of timestamps of closing calls for this source - only one is needed to close, but they may all come in a flurry. |
||||
if {[llength $ts_end_list]} { |
||||
set last_end_ts [lindex $ts_end_list end] |
||||
if {(($tsnow - $last_end_ts) / 1000) >= $timeout} { |
||||
lappend ts_end_list $ts_now |
||||
dict set workers $source ts_end_list $ts_end_list |
||||
} else { |
||||
#existing close in progress.. assume it will work |
||||
return |
||||
} |
||||
} |
||||
|
||||
if {[thread::exists $tidworker]} { |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source still running.. terminating" |
||||
|
||||
#review - timeoutarr is local var (?) |
||||
set timeoutarr($source) 0 |
||||
after $timeout [list set timeoutarr($source) 2] |
||||
|
||||
thread::send -async $tidworker [list shellthread::worker::send_errors_now [thread::id]] |
||||
thread::send -async $tidworker [list shellthread::worker::terminate [thread::id]] timeoutarr($source) |
||||
|
||||
#thread::send -async $tidworker [string map [list %tidclient% [thread::id]] { |
||||
# shellthread::worker::terminate %tidclient% |
||||
#}] timeoutarr($source) |
||||
|
||||
vwait timeoutarr($source) |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE1" |
||||
|
||||
thread::release $tidworker |
||||
#puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE2" |
||||
if {[dict exists $workers $source errors]} { |
||||
set errlist [dict get $workers $source errors] |
||||
if {[llength $errlist]} { |
||||
lappend worker_errors [list $source [dict get $workers $source]] |
||||
} |
||||
} |
||||
dict unset workers $source |
||||
} else { |
||||
#thread may have been closed by call to close_worker with another source with same worker |
||||
#clear workers record for this source |
||||
#REVIEW - race condition for re-creation of source with new workerid? |
||||
#check that record is subscriberless to avoid this |
||||
if {[llength [dict get $workers $source list_client_tids]] == 0} { |
||||
dict unset workers $source |
||||
} |
||||
} |
||||
} |
||||
#puts stdout "close_worker $source - end" |
||||
} |
||||
|
||||
#worker errors only available for a source after close_worker called on that source |
||||
#It is possible for there to be multiple entries for a source because new_worker can be called multiple times with same sourcetag, |
||||
proc get_and_clear_errors {source} { |
||||
variable worker_errors |
||||
set source_errors [lsearch -all -inline -index 0 $worker_errors $source] |
||||
set worker_errors [lsearch -all -inline -index 0 -not $worker_errors $source] |
||||
return $source_errors |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
package provide shellthread [namespace eval shellthread { |
||||
variable version |
||||
set version 1.6.1 |
||||
}] |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@ -1,873 +0,0 @@
|
||||
#Do not update version of this file. Update sqids-buildversion.txt and run make.tcl to update the version in this file and copy to modules folder. |
||||
package require Tcl 8.6- |
||||
|
||||
#MIT license |
||||
#Julian Noble 2026 |
||||
|
||||
#example: |
||||
# % package require sqids |
||||
# % set s1 [sqids::idscope new] |
||||
# ::oo::Obj275 |
||||
# % $s1 encode {1 2 3} |
||||
# 86Rf07 |
||||
# % $s1 decode 86Rf07 |
||||
# 1 2 3 |
||||
|
||||
|
||||
namespace eval sqids { |
||||
oo::class create idscope { |
||||
variable o_alphabet |
||||
variable o_alphabet_configured |
||||
variable o_alpha_re |
||||
variable o_minlength |
||||
variable o_blocklist |
||||
#note that methods beginning with uppercase letters are private. |
||||
constructor {args} { |
||||
set defaults [dict create {*}{ |
||||
-alphabet "" |
||||
-minlength "" |
||||
-blocklist "" |
||||
}] |
||||
if {[llength $args] %2 !=0} { |
||||
error "sqids::idscope constructor: Require option value pairs. Known options:[dict keys $defaults]." |
||||
} |
||||
set useropts [dict create] |
||||
set explicit_empty_blocklist 0 ;#as opposed to default due to being unspecified. |
||||
dict for {k v} $args { |
||||
set fullmatch [tcl::prefix::match -error "" {-alphabet -minlength -blocklist} $k] |
||||
switch -exact -- $fullmatch { |
||||
-alphabet - -minlength { |
||||
dict set useropts $fullmatch $v |
||||
} |
||||
-blocklist { |
||||
if {[llength $v] == 0} { |
||||
set explicit_empty_blocklist 1 |
||||
} |
||||
dict set useropts -blocklist $v |
||||
} |
||||
default { |
||||
error "sqids::idscope constructor: unknown option '$k'. Known options:[dict keys $defaults]." |
||||
} |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $useropts] |
||||
|
||||
set opt_alphabet [dict get $opts -alphabet] |
||||
if {$opt_alphabet eq ""} { |
||||
set o_alphabet $::sqids::data::default_alphabet |
||||
} else { |
||||
if {[string length $opt_alphabet] < 3} { |
||||
error "sqids::idscope constructor: -alphabet length must be at least 3." |
||||
} |
||||
#review - deny multibyte |
||||
if {[regexp {[^\u00-\u7F]} $opt_alphabet]} { |
||||
error "sqids::idscope constructor: -alphabet must not contain multibyte characters." |
||||
} |
||||
if {[regexp {(.).*\1} $opt_alphabet]} { |
||||
error "sqids::idscope constructor: -alphabet must contain unique characters." |
||||
} |
||||
set o_alphabet $opt_alphabet |
||||
} |
||||
set o_alphabet_configured $o_alphabet ;#for use in public method alphabet, which returns the configured alphabet in the order it was configured, not the shuffled order used for encoding. |
||||
set alphamatch [string map [list . \\. \[ \\\[ \] \\\] \{ \\\{ \} \\\}] $o_alphabet] ;#review |
||||
set o_alpha_re "^\[$alphamatch\]+\$" ;#independent of shuffled order. |
||||
|
||||
set o_alphabet [my shuffle $o_alphabet[set o_alphabet {}]] |
||||
|
||||
set opt_minlength [dict get $opts -minlength] |
||||
if {$opt_minlength eq ""} { |
||||
set o_minlength $::sqids::data::default_minlength |
||||
} else { |
||||
set maxval 255 |
||||
if {![string is integer -strict $opt_minlength] || $opt_minlength < 0 || $opt_minlength > $maxval} { |
||||
error "sqids constructor: -minlength must be an integer from 0 to $maxval inclusive." |
||||
} |
||||
set o_minlength $opt_minlength |
||||
} |
||||
set opt_blocklist [dict get $opts -blocklist] |
||||
if {!$explicit_empty_blocklist && $opt_blocklist eq ""} { |
||||
set o_blocklist $::sqids::data::default_blocklist |
||||
} else { |
||||
set o_blocklist $opt_blocklist |
||||
} |
||||
set o_blocklist [string tolower $o_blocklist] |
||||
|
||||
} |
||||
method config {{option {}}} { |
||||
#introspection method. |
||||
#return a dict of the configured options if no option specified, otherwise return the value of the specified option. |
||||
|
||||
#no facility is provided to change options after construction as a new idscope object should be used for different configurations (different scope of sqid ids). |
||||
#note that -alphabet refers to the configured alphabet in the order it was configured, not the shuffled order used for encoding. |
||||
if {$option eq ""} { |
||||
# |
||||
return [dict create {*}{ |
||||
} -blocklist $o_blocklist {*}{ |
||||
} -minlength $o_minlength {*}{ |
||||
} -alphabet $o_alphabet_configured {*}{ |
||||
} |
||||
] |
||||
} |
||||
set fullmatch [tcl::prefix::match -error "" {-alphabet -minlength -blocklist} $option] |
||||
switch -exact -- $fullmatch { |
||||
-alphabet {return $o_alphabet_configured} |
||||
-minlength {return $o_minlength} |
||||
-blocklist {return $o_blocklist} |
||||
default { |
||||
error "sqids::idscope config: unknown option '$option'. Known options:-alphabet -minlength -blocklist." |
||||
} |
||||
} |
||||
} |
||||
method encode {numlist} { |
||||
if {[llength $numlist] == 0} {return} |
||||
#cannot encode negative numbers, or non-integers. |
||||
foreach num $numlist { |
||||
#tcl 9 'string is integer' supports bignums - which can be arbitrarily large. |
||||
#tcl 8.6 'string is integer' is limited to 2**32-1 |
||||
if {![string is integer -strict $num] || $num < 0} { |
||||
error "sqids encode: can only encode non-negative integers. Invalid value: '$num'" |
||||
} |
||||
} |
||||
return [my EncodeNumbers $numlist] |
||||
} |
||||
method EncodeNumbers {numlist {increment 0}} { |
||||
#assert number of letters in o_alphabet and number of letters in local alpha are the same and don't effectively change during this function. |
||||
#('set alpha {}' in calls to my shuffle is an optimization to avoid shared string and copy-on-write overhead. As alpha is set to the result, it doesn't violate the previous assertion.) |
||||
set alpha_len [string length $o_alphabet] |
||||
|
||||
if {$increment > $alpha_len} { |
||||
error "sqids EncodeNumbers: Reached max attempts to re-generate the ID" |
||||
} |
||||
|
||||
set offset [llength $numlist] |
||||
set i -1 |
||||
foreach v $numlist { |
||||
incr i |
||||
set x [scan [string index $o_alphabet [expr {$v % $alpha_len}]] %c] |
||||
set offset [expr {$offset + $x + $i}] |
||||
} |
||||
set offset [expr {$offset % $alpha_len}] |
||||
set offset [expr {($offset + $increment) % $alpha_len}] |
||||
set alpha [string range $o_alphabet $offset end][string range $o_alphabet 0 $offset-1] |
||||
set prefix [string index $alpha 0] |
||||
set alpha [string reverse $alpha] |
||||
set id $prefix |
||||
set i -1 |
||||
foreach num $numlist { |
||||
incr i |
||||
append id [my ToId $num [string range $alpha 1 end]] |
||||
if {$i < [llength $numlist]-1} { |
||||
append id [string index $alpha 0] |
||||
set alpha [my shuffle $alpha[set alpha {}]] |
||||
} |
||||
} |
||||
if {$o_minlength > [string length $id]} { |
||||
append id [string index $alpha 0] |
||||
while {$o_minlength - [string length $id] > 0} { |
||||
set alpha [my shuffle $alpha[set alpha {}]] |
||||
set numchars [expr {min($o_minlength - [string length $id],$alpha_len)}] |
||||
append id [string range $alpha 0 $numchars-1] |
||||
} |
||||
} |
||||
if {[my is_blocked $id]} { |
||||
set id [my EncodeNumbers $numlist [expr {$increment+1}]] |
||||
} |
||||
return $id |
||||
} |
||||
method is_blocked {id} { |
||||
#deliberately public method. |
||||
if {![llength $o_blocklist]} { |
||||
return 0 |
||||
} |
||||
#o_blocklist is stored in lowercase, so compare against lowercase id. |
||||
set idtest [string tolower $id] |
||||
set idlen [string length $idtest] |
||||
if {$idlen < 3} { |
||||
#sqids rule: short ids less than 3 chars will not be blocked. |
||||
return 0 |
||||
} |
||||
if {$idlen == 3} { |
||||
if {$idtest in $o_blocklist} { |
||||
return 1 |
||||
} |
||||
} else { |
||||
foreach blocked $o_blocklist { |
||||
if {[string length $blocked] <= 3} { |
||||
#sqids rule: blocklist entries of 3 chars will only be blocked if they match the entire id exactly, |
||||
#so skip them in this loop as we've already checked for exact matches of the whole id when idlen == 3. |
||||
continue |
||||
} |
||||
set posn [string first $blocked $idtest] |
||||
if {$posn == -1} { |
||||
continue |
||||
} |
||||
if {$posn == 0} { |
||||
#whether leetspeak or not, blocklist entries that match at the beginning of the id will be blocked. |
||||
return 1 |
||||
} |
||||
if {[regexp {[0-9]} $blocked]} { |
||||
#sqids rule: blocklist entries with digits (leetspeak) will only be blocked if the match is at the beginning or end of the id. |
||||
#we've already checked the beginning, so check the end now. |
||||
set endpos [expr {$idlen - [string length $blocked]}] |
||||
if {$posn == $endpos} { |
||||
return 1 |
||||
} |
||||
} else { |
||||
#sqids rule: blocklist entries without digits will be blocked if they match anywhere in the id. |
||||
return 1 |
||||
} |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
method ToId {num alpha} { |
||||
set id "" |
||||
set alpha_len [string length $alpha] |
||||
while 1 { |
||||
set id [string index $alpha [expr {$num % $alpha_len}]]$id |
||||
set num [expr {$num / $alpha_len}] |
||||
if {$num == 0} break |
||||
} |
||||
return $id |
||||
} |
||||
method ToNumber {id alpha} { |
||||
set number 0 |
||||
set alpha_len [string length $alpha] |
||||
for {set i 0} {$i < [string length $id]} {incr i} { |
||||
set posn [string first [string index $id $i] $alpha] |
||||
set number [expr {($number * $alpha_len) + $posn}] |
||||
} |
||||
return $number |
||||
} |
||||
method shuffle {alpha} { |
||||
#public method. Primarily for internal use but can be used externally to examine the shuffled alphabet being used for encoding. |
||||
#e.g myscopeobject shuffle [myscopeobject config -alphabet] would show the shuffled alphabet being used for encoding. |
||||
#consistent shuffle (always produce the same result for same input) |
||||
set alpha_len [string length $alpha] |
||||
if {$alpha_len < 2} { |
||||
return $alpha |
||||
} |
||||
set chars [split $alpha ""] |
||||
|
||||
for {set i 0; set j [expr {$alpha_len-1}]} {$j > 0} {incr i; incr j -1} { |
||||
set iv [scan [lindex $chars $i] %c] |
||||
set jv [scan [lindex $chars $j] %c] |
||||
set r [expr {($i * $j + $iv + $jv) % $alpha_len}] |
||||
set item2 [lindex $chars $r] |
||||
lset chars $r [lindex $chars $i] |
||||
lset chars $i $item2 |
||||
} |
||||
return [join $chars ""] |
||||
} |
||||
method decode {id} { |
||||
if {$id eq ""} {return} |
||||
set result [list] |
||||
|
||||
if {![regexp $o_alpha_re $id]} { |
||||
puts stderr "sqids decode: ID contains characters not in the alphabet. re: $o_alpha_re id: $id" |
||||
return [list] |
||||
} |
||||
set prefix [string index $id 0] |
||||
set offset [string first $prefix $o_alphabet] |
||||
set alpha [string range $o_alphabet $offset end][string range $o_alphabet 0 $offset-1] |
||||
set alpha [string reverse $alpha] |
||||
set id [string range $id 1 end] |
||||
while {[string length $id] > 0} { |
||||
set separator [string index $alpha 0] |
||||
#split on first occurrence of separator only. |
||||
set sep_posn [string first $separator $id] |
||||
if {$sep_posn == -1} { |
||||
set parts [list $id] |
||||
} else { |
||||
set parts [list [string range $id 0 $sep_posn-1] [string range $id $sep_posn+1 end]] |
||||
} |
||||
#assert parts has 1 or 2 elements |
||||
|
||||
if {[lindex $parts 0] eq ""} { |
||||
#separator was at start of the id - done. |
||||
return $result |
||||
} |
||||
lappend result [my ToNumber [lindex $parts 0] [string range $alpha 1 end]] |
||||
if {[llength $parts] == 2} { |
||||
set alpha [my shuffle $alpha[set alpha {}]] |
||||
set id [lindex $parts 1] |
||||
} else { |
||||
set id "" |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
} |
||||
} |
||||
namespace eval sqids::data { |
||||
variable default_alphabet {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789} |
||||
variable default_minlength 0 |
||||
variable default_blocklist { |
||||
0rgasm |
||||
1d10t |
||||
1d1ot |
||||
1di0t |
||||
1diot |
||||
1eccacu10 |
||||
1eccacu1o |
||||
1eccacul0 |
||||
1eccaculo |
||||
1mbec11e |
||||
1mbec1le |
||||
1mbeci1e |
||||
1mbecile |
||||
a11upat0 |
||||
a11upato |
||||
a1lupat0 |
||||
a1lupato |
||||
aand |
||||
ah01e |
||||
ah0le |
||||
aho1e |
||||
ahole |
||||
al1upat0 |
||||
al1upato |
||||
allupat0 |
||||
allupato |
||||
ana1 |
||||
ana1e |
||||
anal |
||||
anale |
||||
anus |
||||
arrapat0 |
||||
arrapato |
||||
arsch |
||||
arse |
||||
ass |
||||
b00b |
||||
b00be |
||||
b01ata |
||||
b0ceta |
||||
b0iata |
||||
b0ob |
||||
b0obe |
||||
b0sta |
||||
b1tch |
||||
b1te |
||||
b1tte |
||||
ba1atkar |
||||
balatkar |
||||
bastard0 |
||||
bastardo |
||||
batt0na |
||||
battona |
||||
bitch |
||||
bite |
||||
bitte |
||||
bo0b |
||||
bo0be |
||||
bo1ata |
||||
boceta |
||||
boiata |
||||
boob |
||||
boobe |
||||
bosta |
||||
bran1age |
||||
bran1er |
||||
bran1ette |
||||
bran1eur |
||||
bran1euse |
||||
branlage |
||||
branler |
||||
branlette |
||||
branleur |
||||
branleuse |
||||
c0ck |
||||
c0g110ne |
||||
c0g11one |
||||
c0g1i0ne |
||||
c0g1ione |
||||
c0gl10ne |
||||
c0gl1one |
||||
c0gli0ne |
||||
c0glione |
||||
c0na |
||||
c0nnard |
||||
c0nnasse |
||||
c0nne |
||||
c0u111es |
||||
c0u11les |
||||
c0u1l1es |
||||
c0u1lles |
||||
c0ui11es |
||||
c0ui1les |
||||
c0uil1es |
||||
c0uilles |
||||
c11t |
||||
c11t0 |
||||
c11to |
||||
c1it |
||||
c1it0 |
||||
c1ito |
||||
cabr0n |
||||
cabra0 |
||||
cabrao |
||||
cabron |
||||
caca |
||||
cacca |
||||
cacete |
||||
cagante |
||||
cagar |
||||
cagare |
||||
cagna |
||||
cara1h0 |
||||
cara1ho |
||||
caracu10 |
||||
caracu1o |
||||
caracul0 |
||||
caraculo |
||||
caralh0 |
||||
caralho |
||||
cazz0 |
||||
cazz1mma |
||||
cazzata |
||||
cazzimma |
||||
cazzo |
||||
ch00t1a |
||||
ch00t1ya |
||||
ch00tia |
||||
ch00tiya |
||||
ch0d |
||||
ch0ot1a |
||||
ch0ot1ya |
||||
ch0otia |
||||
ch0otiya |
||||
ch1asse |
||||
ch1avata |
||||
ch1er |
||||
ch1ng0 |
||||
ch1ngadaz0s |
||||
ch1ngadazos |
||||
ch1ngader1ta |
||||
ch1ngaderita |
||||
ch1ngar |
||||
ch1ngo |
||||
ch1ngues |
||||
ch1nk |
||||
chatte |
||||
chiasse |
||||
chiavata |
||||
chier |
||||
ching0 |
||||
chingadaz0s |
||||
chingadazos |
||||
chingader1ta |
||||
chingaderita |
||||
chingar |
||||
chingo |
||||
chingues |
||||
chink |
||||
cho0t1a |
||||
cho0t1ya |
||||
cho0tia |
||||
cho0tiya |
||||
chod |
||||
choot1a |
||||
choot1ya |
||||
chootia |
||||
chootiya |
||||
cl1t |
||||
cl1t0 |
||||
cl1to |
||||
clit |
||||
clit0 |
||||
clito |
||||
cock |
||||
cog110ne |
||||
cog11one |
||||
cog1i0ne |
||||
cog1ione |
||||
cogl10ne |
||||
cogl1one |
||||
cogli0ne |
||||
coglione |
||||
cona |
||||
connard |
||||
connasse |
||||
conne |
||||
cou111es |
||||
cou11les |
||||
cou1l1es |
||||
cou1lles |
||||
coui11es |
||||
coui1les |
||||
couil1es |
||||
couilles |
||||
cracker |
||||
crap |
||||
cu10 |
||||
cu1att0ne |
||||
cu1attone |
||||
cu1er0 |
||||
cu1ero |
||||
cu1o |
||||
cul0 |
||||
culatt0ne |
||||
culattone |
||||
culer0 |
||||
culero |
||||
culo |
||||
cum |
||||
cunt |
||||
d11d0 |
||||
d11do |
||||
d1ck |
||||
d1ld0 |
||||
d1ldo |
||||
damn |
||||
de1ch |
||||
deich |
||||
depp |
||||
di1d0 |
||||
di1do |
||||
dick |
||||
dild0 |
||||
dildo |
||||
dyke |
||||
encu1e |
||||
encule |
||||
enema |
||||
enf01re |
||||
enf0ire |
||||
enfo1re |
||||
enfoire |
||||
estup1d0 |
||||
estup1do |
||||
estupid0 |
||||
estupido |
||||
etr0n |
||||
etron |
||||
f0da |
||||
f0der |
||||
f0ttere |
||||
f0tters1 |
||||
f0ttersi |
||||
f0tze |
||||
f0utre |
||||
f1ca |
||||
f1cker |
||||
f1ga |
||||
fag |
||||
fica |
||||
ficker |
||||
figa |
||||
foda |
||||
foder |
||||
fottere |
||||
fotters1 |
||||
fottersi |
||||
fotze |
||||
foutre |
||||
fr0c10 |
||||
fr0c1o |
||||
fr0ci0 |
||||
fr0cio |
||||
fr0sc10 |
||||
fr0sc1o |
||||
fr0sci0 |
||||
fr0scio |
||||
froc10 |
||||
froc1o |
||||
froci0 |
||||
frocio |
||||
frosc10 |
||||
frosc1o |
||||
frosci0 |
||||
froscio |
||||
fuck |
||||
g00 |
||||
g0o |
||||
g0u1ne |
||||
g0uine |
||||
gandu |
||||
go0 |
||||
goo |
||||
gou1ne |
||||
gouine |
||||
gr0gnasse |
||||
grognasse |
||||
haram1 |
||||
harami |
||||
haramzade |
||||
hund1n |
||||
hundin |
||||
id10t |
||||
id1ot |
||||
idi0t |
||||
idiot |
||||
imbec11e |
||||
imbec1le |
||||
imbeci1e |
||||
imbecile |
||||
j1zz |
||||
jerk |
||||
jizz |
||||
k1ke |
||||
kam1ne |
||||
kamine |
||||
kike |
||||
leccacu10 |
||||
leccacu1o |
||||
leccacul0 |
||||
leccaculo |
||||
m1erda |
||||
m1gn0tta |
||||
m1gnotta |
||||
m1nch1a |
||||
m1nchia |
||||
m1st |
||||
mam0n |
||||
mamahuev0 |
||||
mamahuevo |
||||
mamon |
||||
masturbat10n |
||||
masturbat1on |
||||
masturbate |
||||
masturbati0n |
||||
masturbation |
||||
merd0s0 |
||||
merd0so |
||||
merda |
||||
merde |
||||
merdos0 |
||||
merdoso |
||||
mierda |
||||
mign0tta |
||||
mignotta |
||||
minch1a |
||||
minchia |
||||
mist |
||||
musch1 |
||||
muschi |
||||
n1gger |
||||
neger |
||||
negr0 |
||||
negre |
||||
negro |
||||
nerch1a |
||||
nerchia |
||||
nigger |
||||
orgasm |
||||
p00p |
||||
p011a |
||||
p01la |
||||
p0l1a |
||||
p0lla |
||||
p0mp1n0 |
||||
p0mp1no |
||||
p0mpin0 |
||||
p0mpino |
||||
p0op |
||||
p0rca |
||||
p0rn |
||||
p0rra |
||||
p0uff1asse |
||||
p0uffiasse |
||||
p1p1 |
||||
p1pi |
||||
p1r1a |
||||
p1rla |
||||
p1sc10 |
||||
p1sc1o |
||||
p1sci0 |
||||
p1scio |
||||
p1sser |
||||
pa11e |
||||
pa1le |
||||
pal1e |
||||
palle |
||||
pane1e1r0 |
||||
pane1e1ro |
||||
pane1eir0 |
||||
pane1eiro |
||||
panele1r0 |
||||
panele1ro |
||||
paneleir0 |
||||
paneleiro |
||||
patakha |
||||
pec0r1na |
||||
pec0rina |
||||
pecor1na |
||||
pecorina |
||||
pen1s |
||||
pendej0 |
||||
pendejo |
||||
penis |
||||
pip1 |
||||
pipi |
||||
pir1a |
||||
pirla |
||||
pisc10 |
||||
pisc1o |
||||
pisci0 |
||||
piscio |
||||
pisser |
||||
po0p |
||||
po11a |
||||
po1la |
||||
pol1a |
||||
polla |
||||
pomp1n0 |
||||
pomp1no |
||||
pompin0 |
||||
pompino |
||||
poop |
||||
porca |
||||
porn |
||||
porra |
||||
pouff1asse |
||||
pouffiasse |
||||
pr1ck |
||||
prick |
||||
pussy |
||||
put1za |
||||
puta |
||||
puta1n |
||||
putain |
||||
pute |
||||
putiza |
||||
puttana |
||||
queca |
||||
r0mp1ba11e |
||||
r0mp1ba1le |
||||
r0mp1bal1e |
||||
r0mp1balle |
||||
r0mpiba11e |
||||
r0mpiba1le |
||||
r0mpibal1e |
||||
r0mpiballe |
||||
rand1 |
||||
randi |
||||
rape |
||||
recch10ne |
||||
recch1one |
||||
recchi0ne |
||||
recchione |
||||
retard |
||||
romp1ba11e |
||||
romp1ba1le |
||||
romp1bal1e |
||||
romp1balle |
||||
rompiba11e |
||||
rompiba1le |
||||
rompibal1e |
||||
rompiballe |
||||
ruff1an0 |
||||
ruff1ano |
||||
ruffian0 |
||||
ruffiano |
||||
s1ut |
||||
sa10pe |
||||
sa1aud |
||||
sa1ope |
||||
sacanagem |
||||
sal0pe |
||||
salaud |
||||
salope |
||||
saugnapf |
||||
sb0rr0ne |
||||
sb0rra |
||||
sb0rrone |
||||
sbattere |
||||
sbatters1 |
||||
sbattersi |
||||
sborr0ne |
||||
sborra |
||||
sborrone |
||||
sc0pare |
||||
sc0pata |
||||
sch1ampe |
||||
sche1se |
||||
sche1sse |
||||
scheise |
||||
scheisse |
||||
schlampe |
||||
schwachs1nn1g |
||||
schwachs1nnig |
||||
schwachsinn1g |
||||
schwachsinnig |
||||
schwanz |
||||
scopare |
||||
scopata |
||||
sexy |
||||
sh1t |
||||
shit |
||||
slut |
||||
sp0mp1nare |
||||
sp0mpinare |
||||
spomp1nare |
||||
spompinare |
||||
str0nz0 |
||||
str0nza |
||||
str0nzo |
||||
stronz0 |
||||
stronza |
||||
stronzo |
||||
stup1d |
||||
stupid |
||||
succh1am1 |
||||
succh1ami |
||||
succhiam1 |
||||
succhiami |
||||
sucker |
||||
t0pa |
||||
tapette |
||||
test1c1e |
||||
test1cle |
||||
testic1e |
||||
testicle |
||||
tette |
||||
topa |
||||
tr01a |
||||
tr0ia |
||||
tr0mbare |
||||
tr1ng1er |
||||
tr1ngler |
||||
tring1er |
||||
tringler |
||||
tro1a |
||||
troia |
||||
trombare |
||||
turd |
||||
twat |
||||
vaffancu10 |
||||
vaffancu1o |
||||
vaffancul0 |
||||
vaffanculo |
||||
vag1na |
||||
vagina |
||||
verdammt |
||||
verga |
||||
w1chsen |
||||
wank |
||||
wichsen |
||||
x0ch0ta |
||||
x0chota |
||||
xana |
||||
xoch0ta |
||||
xochota |
||||
z0cc01a |
||||
z0cc0la |
||||
z0cco1a |
||||
z0ccola |
||||
z1z1 |
||||
z1zi |
||||
ziz1 |
||||
zizi |
||||
zocc01a |
||||
zocc0la |
||||
zocco1a |
||||
zoccola |
||||
} |
||||
} |
||||
|
||||
package provide sqids [namespace eval sqids { |
||||
variable version |
||||
set version 0.3.0 |
||||
}] |
||||
|
||||
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
@ -1,8 +0,0 @@
|
||||
if {[catch {package require Tcl 8.6-}]} return |
||||
set script "" |
||||
if {![info exists ::env(TREECTRL_LIBRARY)] |
||||
&& [file exists [file join $dir treectrl.tcl]]} { |
||||
append script "[list set ::treectrl_library $dir]\n" |
||||
} |
||||
append script [list load [file join $dir treectrl24.dll] [string totitle treectrl 0 0]] |
||||
package ifneeded treectrl 2.4.2 $script |
||||
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Loading…
Reference in new issue