Julian Noble
11 months ago
252 changed files with 14704 additions and 77093 deletions
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,437 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2024 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::encmime 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin punkshell_module_punk::encmime 0 0.1.0] |
||||
#[copyright "2024"] |
||||
#[titledesc {mime encodings related subset of tcllib mime}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {mime encoding names and aliases}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::encmime] |
||||
#[keywords module encodings] |
||||
#[description] |
||||
#[para] This is a workaround package to provide the mime encoding names used in tcllib's mime package - without additional dependencies |
||||
#[para]tcllib mime loads either Trf or tcl::memchan functions. punk::encmime needs to work in a context where tcllib may not yet be loaded/available, and even these few dependencies are too much. |
||||
#[para]MAINTENANCE NOTE: The data in this module needs to be checked against the latest tcllib mime package |
||||
#[para]taken from tcllib mime version: 1.7.2 in 2024 |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::encmime |
||||
#[subsection Concepts] |
||||
#[para] Where practical - the actual tcllib mime package should be used instead. |
||||
#[para]This set of encoding related functions is a snapshot of the data from the mime package - and may not be up to date. |
||||
#[para]This pseudo-package was created to minimize dependencies for punk::char and punk::overtype |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::encmime |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6 |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::encmime::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::encmime::class}] |
||||
#[para] class definitions |
||||
if {[info commands [namespace current]::interface_sample1] eq ""} { |
||||
#*** !doctools |
||||
#[list_begin enumerated] |
||||
|
||||
# oo::class create interface_sample1 { |
||||
# #*** !doctools |
||||
# #[enum] CLASS [class interface_sample1] |
||||
# #[list_begin definitions] |
||||
|
||||
# method test {arg1} { |
||||
# #*** !doctools |
||||
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||
# #[para] test method |
||||
# puts "test: $arg1" |
||||
# } |
||||
|
||||
# #*** !doctools |
||||
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||
# } |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end class enumeration ---}] |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::encmime { |
||||
namespace export * |
||||
|
||||
variable encList { |
||||
ascii US-ASCII |
||||
big5 Big5 |
||||
cp1250 Windows-1250 |
||||
cp1251 Windows-1251 |
||||
cp1252 Windows-1252 |
||||
cp1253 Windows-1253 |
||||
cp1254 Windows-1254 |
||||
cp1255 Windows-1255 |
||||
cp1256 Windows-1256 |
||||
cp1257 Windows-1257 |
||||
cp1258 Windows-1258 |
||||
cp437 IBM437 |
||||
cp737 {} |
||||
cp775 IBM775 |
||||
cp850 IBM850 |
||||
cp852 IBM852 |
||||
cp855 IBM855 |
||||
cp857 IBM857 |
||||
cp860 IBM860 |
||||
cp861 IBM861 |
||||
cp862 IBM862 |
||||
cp863 IBM863 |
||||
cp864 IBM864 |
||||
cp865 IBM865 |
||||
cp866 IBM866 |
||||
cp869 IBM869 |
||||
cp874 {} |
||||
cp932 {} |
||||
cp936 GBK |
||||
cp949 {} |
||||
cp950 {} |
||||
dingbats {} |
||||
ebcdic {} |
||||
euc-cn EUC-CN |
||||
euc-jp EUC-JP |
||||
euc-kr EUC-KR |
||||
gb12345 GB12345 |
||||
gb1988 GB1988 |
||||
gb2312 GB2312 |
||||
iso2022 ISO-2022 |
||||
iso2022-jp ISO-2022-JP |
||||
iso2022-kr ISO-2022-KR |
||||
iso8859-1 ISO-8859-1 |
||||
iso8859-2 ISO-8859-2 |
||||
iso8859-3 ISO-8859-3 |
||||
iso8859-4 ISO-8859-4 |
||||
iso8859-5 ISO-8859-5 |
||||
iso8859-6 ISO-8859-6 |
||||
iso8859-7 ISO-8859-7 |
||||
iso8859-8 ISO-8859-8 |
||||
iso8859-9 ISO-8859-9 |
||||
iso8859-10 ISO-8859-10 |
||||
iso8859-13 ISO-8859-13 |
||||
iso8859-14 ISO-8859-14 |
||||
iso8859-15 ISO-8859-15 |
||||
iso8859-16 ISO-8859-16 |
||||
jis0201 JIS_X0201 |
||||
jis0208 JIS_C6226-1983 |
||||
jis0212 JIS_X0212-1990 |
||||
koi8-r KOI8-R |
||||
koi8-u KOI8-U |
||||
ksc5601 KS_C_5601-1987 |
||||
macCentEuro {} |
||||
macCroatian {} |
||||
macCyrillic {} |
||||
macDingbats {} |
||||
macGreek {} |
||||
macIceland {} |
||||
macJapan {} |
||||
macRoman {} |
||||
macRomania {} |
||||
macThai {} |
||||
macTurkish {} |
||||
macUkraine {} |
||||
shiftjis Shift_JIS |
||||
symbol {} |
||||
tis-620 TIS-620 |
||||
unicode {} |
||||
utf-8 UTF-8 |
||||
} |
||||
variable encodings |
||||
array set encodings $encList |
||||
variable reversemap |
||||
variable encAliasList { |
||||
ascii ANSI_X3.4-1968 |
||||
ascii iso-ir-6 |
||||
ascii ANSI_X3.4-1986 |
||||
ascii ISO_646.irv:1991 |
||||
ascii ASCII |
||||
ascii ISO646-US |
||||
ascii us |
||||
ascii IBM367 |
||||
ascii cp367 |
||||
cp437 cp437 |
||||
cp437 437 |
||||
cp775 cp775 |
||||
cp850 cp850 |
||||
cp850 850 |
||||
cp852 cp852 |
||||
cp852 852 |
||||
cp855 cp855 |
||||
cp855 855 |
||||
cp857 cp857 |
||||
cp857 857 |
||||
cp860 cp860 |
||||
cp860 860 |
||||
cp861 cp861 |
||||
cp861 861 |
||||
cp861 cp-is |
||||
cp862 cp862 |
||||
cp862 862 |
||||
cp863 cp863 |
||||
cp863 863 |
||||
cp864 cp864 |
||||
cp865 cp865 |
||||
cp865 865 |
||||
cp866 cp866 |
||||
cp866 866 |
||||
cp869 cp869 |
||||
cp869 869 |
||||
cp869 cp-gr |
||||
cp936 CP936 |
||||
cp936 MS936 |
||||
cp936 Windows-936 |
||||
iso8859-1 ISO_8859-1:1987 |
||||
iso8859-1 iso-ir-100 |
||||
iso8859-1 ISO_8859-1 |
||||
iso8859-1 latin1 |
||||
iso8859-1 l1 |
||||
iso8859-1 IBM819 |
||||
iso8859-1 CP819 |
||||
iso8859-2 ISO_8859-2:1987 |
||||
iso8859-2 iso-ir-101 |
||||
iso8859-2 ISO_8859-2 |
||||
iso8859-2 latin2 |
||||
iso8859-2 l2 |
||||
iso8859-3 ISO_8859-3:1988 |
||||
iso8859-3 iso-ir-109 |
||||
iso8859-3 ISO_8859-3 |
||||
iso8859-3 latin3 |
||||
iso8859-3 l3 |
||||
iso8859-4 ISO_8859-4:1988 |
||||
iso8859-4 iso-ir-110 |
||||
iso8859-4 ISO_8859-4 |
||||
iso8859-4 latin4 |
||||
iso8859-4 l4 |
||||
iso8859-5 ISO_8859-5:1988 |
||||
iso8859-5 iso-ir-144 |
||||
iso8859-5 ISO_8859-5 |
||||
iso8859-5 cyrillic |
||||
iso8859-6 ISO_8859-6:1987 |
||||
iso8859-6 iso-ir-127 |
||||
iso8859-6 ISO_8859-6 |
||||
iso8859-6 ECMA-114 |
||||
iso8859-6 ASMO-708 |
||||
iso8859-6 arabic |
||||
iso8859-7 ISO_8859-7:1987 |
||||
iso8859-7 iso-ir-126 |
||||
iso8859-7 ISO_8859-7 |
||||
iso8859-7 ELOT_928 |
||||
iso8859-7 ECMA-118 |
||||
iso8859-7 greek |
||||
iso8859-7 greek8 |
||||
iso8859-8 ISO_8859-8:1988 |
||||
iso8859-8 iso-ir-138 |
||||
iso8859-8 ISO_8859-8 |
||||
iso8859-8 hebrew |
||||
iso8859-9 ISO_8859-9:1989 |
||||
iso8859-9 iso-ir-148 |
||||
iso8859-9 ISO_8859-9 |
||||
iso8859-9 latin5 |
||||
iso8859-9 l5 |
||||
iso8859-10 iso-ir-157 |
||||
iso8859-10 l6 |
||||
iso8859-10 ISO_8859-10:1992 |
||||
iso8859-10 latin6 |
||||
iso8859-14 iso-ir-199 |
||||
iso8859-14 ISO_8859-14:1998 |
||||
iso8859-14 ISO_8859-14 |
||||
iso8859-14 latin8 |
||||
iso8859-14 iso-celtic |
||||
iso8859-14 l8 |
||||
iso8859-15 ISO_8859-15 |
||||
iso8859-15 Latin-9 |
||||
iso8859-16 iso-ir-226 |
||||
iso8859-16 ISO_8859-16:2001 |
||||
iso8859-16 ISO_8859-16 |
||||
iso8859-16 latin10 |
||||
iso8859-16 l10 |
||||
jis0201 X0201 |
||||
jis0208 iso-ir-87 |
||||
jis0208 x0208 |
||||
jis0208 JIS_X0208-1983 |
||||
jis0212 x0212 |
||||
jis0212 iso-ir-159 |
||||
ksc5601 iso-ir-149 |
||||
ksc5601 KS_C_5601-1989 |
||||
ksc5601 KSC5601 |
||||
ksc5601 korean |
||||
shiftjis MS_Kanji |
||||
utf-8 UTF8 |
||||
} |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::encmime}] |
||||
#[para] Core API functions for punk::encmime |
||||
#[list_begin definitions] |
||||
|
||||
# ::mime::mapencoding -- |
||||
# |
||||
# mime::mapencodings maps tcl encodings onto the proper names for their |
||||
# MIME charset type. This is only done for encodings whose charset types |
||||
# were known. The remaining encodings return {} for now. |
||||
# |
||||
# Arguments: |
||||
# enc The tcl encoding to map. |
||||
# |
||||
# Results: |
||||
# Returns the MIME charset type for the specified tcl encoding, or {} |
||||
# if none is known. |
||||
proc mapencoding {enc} { |
||||
#*** !doctools |
||||
#[call mapencoding [arg enc]] |
||||
#[para]maps tcl encodings onto the proper names for their MIME charset type. |
||||
#[para]This is only done for encodings whose charset types were known. |
||||
#[para]The remaining encodings return {} for now. |
||||
#[para]NOTE: consider using tcllib's mime::mapencoding instead if mime package available |
||||
|
||||
variable encodings |
||||
if {[info exists encodings($enc)]} { |
||||
return $encodings($enc) |
||||
} |
||||
return {} |
||||
} |
||||
|
||||
proc reversemapencoding {mimeType} { |
||||
#*** !doctools |
||||
#[call reversemapencoding [arg mimeType]] |
||||
#[para]mime::reversemapencodings maps MIME charset types onto tcl encoding names. |
||||
#[para]Returns the tcl encoding name for the specified mime charset, or {} if none is known |
||||
#[para] Arguments: |
||||
# [list_begin arguments] |
||||
# [arg_def string mimeType] The MIME charset to convert into a tcl encoding type. |
||||
# [list_end] |
||||
#[para]NOTE: consider using tcllib's mime::reversemapencoding instead if mime package available |
||||
|
||||
variable reversemap |
||||
|
||||
set lmimeType [string tolower $mimeType] |
||||
if {[info exists reversemap($lmimeType)]} { |
||||
return $reversemap($lmimeType) |
||||
} |
||||
return {} |
||||
} |
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::encmime ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
::apply {{} { |
||||
variable encList |
||||
variable encAliasList |
||||
variable reversemap |
||||
foreach {enc mimeType} $encList { |
||||
if {$mimeType eq {}} continue |
||||
set reversemap([string tolower $mimeType]) $enc |
||||
} |
||||
foreach {enc mimeType} $encAliasList { |
||||
set reversemap([string tolower $mimeType]) $enc |
||||
} |
||||
# Drop the helper variables |
||||
unset encList encAliasList |
||||
|
||||
} ::punk::encmime} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::encmime::lib { |
||||
namespace export * |
||||
namespace path [namespace parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::encmime::lib}] |
||||
#[para] Secondary functions that are part of the API |
||||
#[list_begin definitions] |
||||
|
||||
#proc utility1 {p1 args} { |
||||
# #*** !doctools |
||||
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||
# #[para]Description of utility1 |
||||
# return 1 |
||||
#} |
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::encmime::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
namespace eval punk::encmime::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::encmime::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::encmime [namespace eval punk::encmime { |
||||
variable pkg punk::encmime |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,3 @@
|
||||
%Major.Minor.Level% |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
@ -0,0 +1,10 @@
|
||||
Identifier: %package% |
||||
Version: %version% |
||||
Title: %title% |
||||
Creator: %name% <%email%> |
||||
Description: %description% |
||||
Rights: BSD |
||||
URL: %url% |
||||
Available: |
||||
Architecture: tcl |
||||
Subject: |
@ -0,0 +1,7 @@
|
||||
::lindex tcl;#\ |
||||
@call tclsh "%~dp0%~n0.bat" %* & goto :eof |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
||||
puts stdout "script: [info script]" |
||||
puts stdout "argv: $::argc" |
||||
puts stdout "args: '$::argv'" |
||||
|
@ -0,0 +1,112 @@
|
||||
: "[proc : args {}]" ;# *tcl shellbat - call with sh,bash,tclsh on any platform, or with cmd on windows. |
||||
: <<'HIDE_FROM_BASH_AND_SH' |
||||
: ;# leading colon hides from .bat, trailing slash hides next line from tcl \ |
||||
@call tclsh "%~dp0%~n0.bat" %* |
||||
: ;#\ |
||||
@set taskexitcode=%errorlevel% & goto :exit |
||||
# -*- tcl -*- |
||||
# ################################################################################################# |
||||
# This is a tcl shellbat file |
||||
# It is tuned to run when called as a batch file, a tcl script, an sh script or a bash script, |
||||
# so the specific layout and characters used are quite sensitive to change. |
||||
# It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. |
||||
# e.g ./filename.sh.bat in sh or bash or powershell |
||||
# e.g filename.sh or filename.sh.bat at windows command prompt |
||||
# e.g tclsh filename.sh.bat | sh filename.sh.bat | bash filename.sh.bat |
||||
# In all cases an arbitrary number of arguments are accepted |
||||
# To avoid the initial commandline on stdout when calling as a batch file on windows, use: |
||||
# cmd /Q /c filename.sh.bat |
||||
# (because we cannot use @if to silence it, as this isn't understood by tcl,sh or bash) |
||||
# ################################################################################################# |
||||
#fconfigure stdout -translation crlf |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload |
||||
#puts "script : [info script]" |
||||
#puts "argcount : $::argc" |
||||
#puts "argvalues: $::argv" |
||||
|
||||
|
||||
#<tcl-payload> |
||||
#<tcl-payload/> |
||||
|
||||
# --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# only exit if needed. see exitcode notes at bottom of file and exit there for consistency across invocation methods |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload |
||||
#-- |
||||
#-- bash/sh code follows. |
||||
#-- protect from tcl using line continuation char on the previous comment for each line, like so: \ |
||||
printf "etc" |
||||
#-- or alternatively place sh/bash script within the false==false block |
||||
#-- whilst being careful to balance braces {} |
||||
#-- For more complex needs you should call out to external scripts |
||||
#-- |
||||
#-- END marker for hide_from_bash_and_sh\ |
||||
HIDE_FROM_BASH_AND_SH |
||||
|
||||
#--------------------------------------------------------- |
||||
#-- This if statement hides(mostly) a sh/bash code block from Tcl |
||||
if false==false # else { |
||||
then |
||||
: |
||||
#--------------------------------------------------------- |
||||
#-- leave as is if all that's required is launching the Tcl payload" |
||||
#-- |
||||
#-- Note that sh/bash script isn't called when running a .bat from cmd.exe on windows by default |
||||
#-- adjust line 4: @call tclsh ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate |
||||
#-- if sh/bash scripting needs to run on windows too. |
||||
#-- |
||||
#printf "start of bash or sh code" |
||||
|
||||
#<shell-payload-pre-tcl> |
||||
#</shell-payload-pre-tcl> |
||||
|
||||
|
||||
#-- sh/bash launches Tcl here instead of shebang line at top |
||||
#<shell-launch-tcl> |
||||
#-- use exec to use exitcode (if any) directly from the tcl script |
||||
exec /usr/bin/env tclsh "$0" "$@" |
||||
#</shell-launch-tcl> |
||||
|
||||
#-- alternative - if sh/bash script required to run after the tcl call. |
||||
#/usr/bin/env tclsh "$0" "$@" |
||||
#tcl_exitcode=$? |
||||
#echo "tcl_exitcode: ${tcl_exitcode}" |
||||
|
||||
#<shell-payload-post-tcl> |
||||
#</shell-payload-post-tcl> |
||||
|
||||
#-- override exitcode example |
||||
#exit 66 |
||||
|
||||
#printf "No need for trailing slashes for sh/bash code here\n" |
||||
#--------------------------------------------------------- |
||||
fi |
||||
# closing brace for Tcl } |
||||
#--------------------------------------------------------- |
||||
|
||||
#-- tcl and shell script now both active |
||||
|
||||
#-- comment for line sample 1 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 1 \n" |
||||
|
||||
#-- comment for line sample 2 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 2 \n" |
||||
|
||||
|
||||
#-- Consistent exitcode from sh,bash,tclsh or cmd |
||||
#-- Call exit in tcl (or sh/bash) code only if explicitly required, otherwise leave this commented out. |
||||
#-- (script might be more widely useable without explicit exit. e.g in tcl: set ::argc 1; set ::argv "val"; source filename.sh.bat ) |
||||
#-- exit line unprotected by trailing slash will work for tcl and/or sh/bash |
||||
#exit 0 |
||||
#exit 42 |
||||
|
||||
|
||||
|
||||
#-- make sure sh/bash/tcl all skip over .bat style exit \ |
||||
: <<'shell_end' |
||||
#-- .bat exit with exitcode from tcl process \ |
||||
:exit |
||||
: ;# \ |
||||
@exit /B %taskexitcode% |
||||
# .bat has exited \ |
||||
shell_end |
||||
|
@ -0,0 +1,104 @@
|
||||
: "[proc : args {}]" ;# *tcl shellbat - call with sh,bash,tclsh on any platform, or with cmd on windows. |
||||
: <<'HIDE_FROM_BASH_AND_SH' |
||||
: ;# leading colon hides from .bat, trailing slash hides next line from tcl \ |
||||
@call tclsh "%~dp0%~n0.bat" %* |
||||
: ;#\ |
||||
@set taskexitcode=%errorlevel% & goto :exit |
||||
# -*- tcl -*- |
||||
# ################################################################################################# |
||||
# This is a tcl shellbat file |
||||
# It is tuned to run when called as a batch file, a tcl script, an sh script or a bash script, |
||||
# so the specific layout and characters used are quite sensitive to change. |
||||
# It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. |
||||
# e.g ./filename.sh.bat in sh or bash or powershell |
||||
# e.g filename.sh or filename.sh.bat at windows command prompt |
||||
# e.g tclsh filename.sh.bat | sh filename.sh.bat | bash filename.sh.bat |
||||
# In all cases an arbitrary number of arguments are accepted |
||||
# To avoid the initial commandline on stdout when calling as a batch file on windows, use: |
||||
# cmd /Q /c filename.sh.bat |
||||
# (because we cannot use @if to silence it, as this isn't understood by tcl,sh or bash) |
||||
# ################################################################################################# |
||||
#fconfigure stdout -translation crlf |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload |
||||
#puts "script : [info script]" |
||||
#puts "argcount : $::argc" |
||||
#puts "argvalues: $::argv" |
||||
|
||||
|
||||
#<tcl-payload> |
||||
|
||||
# --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# only exit if needed. see exitcode notes at bottom of file and exit there for consistency across invocation methods |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload |
||||
#-- |
||||
#-- bash/sh code follows. |
||||
#-- protect from tcl using line continuation char on the previous comment for each line, like so: \ |
||||
printf "etc" |
||||
#-- or alternatively place sh/bash script within the false==false block |
||||
#-- whilst being careful to balance braces {} |
||||
#-- For more complex needs you should call out to external scripts |
||||
#-- |
||||
#-- END marker for hide_from_bash_and_sh\ |
||||
HIDE_FROM_BASH_AND_SH |
||||
|
||||
#--------------------------------------------------------- |
||||
#-- This if statement hides(mostly) a sh/bash code block from Tcl |
||||
if false==false # else { |
||||
then |
||||
: |
||||
#--------------------------------------------------------- |
||||
#-- leave as is if all that's required is launching the Tcl payload" |
||||
#-- |
||||
#-- Note that sh/bash script isn't called when running a .bat from cmd.exe on windows by default |
||||
#-- adjust line 4: @call tclsh ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate |
||||
#-- if sh/bash scripting needs to run on windows too. |
||||
#-- |
||||
#printf "start of bash or sh code" |
||||
|
||||
|
||||
#-- sh/bash launches Tcl here instead of shebang line at top |
||||
|
||||
#-- use exec to use exitcode (if any) directly from the tcl script |
||||
exec /usr/bin/env tclsh "$0" "$@" |
||||
|
||||
#-- alternative - if sh/bash script required to run after the tcl call. |
||||
#/usr/bin/env tclsh "$0" "$@" |
||||
#tcl_exitcode=$? |
||||
#echo "tcl_exitcode: ${tcl_exitcode}" |
||||
|
||||
#-- override exitcode example |
||||
#exit 66 |
||||
|
||||
#printf "No need for trailing slashes for sh/bash code here\n" |
||||
#--------------------------------------------------------- |
||||
fi |
||||
# closing brace for Tcl } |
||||
#--------------------------------------------------------- |
||||
|
||||
#-- tcl and shell script now both active |
||||
|
||||
#-- comment for line sample 1 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 1 \n" |
||||
|
||||
#-- comment for line sample 2 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 2 \n" |
||||
|
||||
|
||||
#-- Consistent exitcode from sh,bash,tclsh or cmd |
||||
#-- Call exit in tcl (or sh/bash) code only if explicitly required, otherwise leave this commented out. |
||||
#-- (script might be more widely useable without explicit exit. e.g in tcl: set ::argc 1; set ::argv "val"; source filename.sh.bat ) |
||||
#-- exit line unprotected by trailing slash will work for tcl and/or sh/bash |
||||
#exit 0 |
||||
#exit 42 |
||||
|
||||
|
||||
|
||||
#-- make sure sh/bash/tcl all skip over .bat style exit \ |
||||
: <<'shell_end' |
||||
#-- .bat exit with exitcode from tcl process \ |
||||
:exit |
||||
: ;# \ |
||||
@exit /B %taskexitcode% |
||||
# .bat has exited \ |
||||
shell_end |
||||
|
@ -0,0 +1,106 @@
|
||||
if (true=="shellbat") #;#\ |
||||
: <<'HIDE_FROM_BASH_AND_SH' |
||||
::lindex tcl;# leading colons hide from .bat, trailing slash hides next line from tcl \ |
||||
@call tclsh "%~dp0%~n0.bat" %* |
||||
::lindex tcl;#\ |
||||
@set taskexitcode=%errorlevel% & goto :exit |
||||
# -*- tcl -*- |
||||
# ################################################################################################# |
||||
# This is a tcl shellbat file |
||||
# It is tuned to run when called as a batch file, a tcl script, an sh script or a bash script, |
||||
# so the specific layout and characters used are quite sensitive to change. |
||||
# It can be called on unix or windows platforms with or without the interpreter being specified on the commandline. |
||||
# e.g ./filename.sh.bat in sh or bash or powershell |
||||
# e.g filename.sh or filename.sh.bat at windows command prompt |
||||
# e.g tclsh filename.sh.bat | sh filename.sh.bat | bash filename.sh.bat |
||||
# In all cases an arbitrary number of arguments are accepted |
||||
# To avoid the initial commandline on stdout when calling as a batch file on windows, use: |
||||
# cmd /Q /c filename.sh.bat |
||||
# (because we cannot use @if to silence it, as this isn't understood by tcl,sh or bash) |
||||
# ################################################################################################# |
||||
#fconfigure stdout -translation crlf |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl Payload |
||||
#puts "script : [info script]" |
||||
#puts "argcount : $::argc" |
||||
#puts "argvalues: $::argv" |
||||
|
||||
#<tcl-payload> |
||||
|
||||
# --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# only exit if needed. see exitcode notes at bottom of file and exit there for consistency across invocation methods |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl Payload |
||||
#-- |
||||
#-- bash/sh code follows. |
||||
#-- protect from tcl using line continuation char on the previous comment for each line, like so: \ |
||||
printf "etc" |
||||
#-- or alternatively place sh/bash script within the false==false block |
||||
#-- whilst being careful to balance braces {} |
||||
#-- For more complex needs you should call out to external scripts |
||||
#-- |
||||
#-- END marker for hide_from_bash_and_sh\ |
||||
HIDE_FROM_BASH_AND_SH |
||||
#\ |
||||
then |
||||
|
||||
#--------------------------------------------------------- |
||||
if false==false # else { |
||||
then |
||||
: |
||||
#--------------------------------------------------------- |
||||
#-- leave as is if all that's required is launching the Tcl payload" |
||||
#-- |
||||
#-- Note that sh/bash script isn't called when running a .bat from cmd.exe on windows by default |
||||
#-- adjust line 4: @call tclsh ... to something like @call sh ... @call bash .. or @call env sh ... etc as appropriate |
||||
#-- if sh/bash scripting needs to run on windows too. |
||||
#-- |
||||
#printf "start of bash or sh code" |
||||
|
||||
|
||||
#-- sh/bash launches Tcl here instead of shebang line at top |
||||
|
||||
#-- use exec to use exitcode (if any) directly from the tcl script |
||||
exec /usr/bin/env tclsh "$0" "$@" |
||||
|
||||
#-- alternative - if sh/bash script required to run after the tcl call. |
||||
#/usr/bin/env tclsh "$0" "$@" |
||||
#tcl_exitcode=$? |
||||
#echo "tcl_exitcode: ${tcl_exitcode}" |
||||
|
||||
#-- override exitcode example |
||||
#exit 66 |
||||
|
||||
#printf "No need for trailing slashes for sh/bash code here\n" |
||||
#--------------------------------------------------------- |
||||
fi |
||||
# } |
||||
#--------------------------------------------------------- |
||||
|
||||
#-- comment for line sample 1 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 1 \n" |
||||
|
||||
#-- comment for line sample 2 with trailing continuation slash \ |
||||
#printf "tcl-invisible sh/bash line sample 2 \n" |
||||
|
||||
|
||||
#-- Consistent exitcode from sh,bash,tclsh or cmd |
||||
#-- Call exit in tcl (or sh/bash) code only if explicitly required, otherwise leave this commented out. |
||||
#-- (script might be more widely useable without explicit exit. e.g in tcl: set ::argc 1; set ::argv "val"; source filename.sh.bat ) |
||||
#-- exit line unprotected by trailing slash will work for tcl and/or sh/bash |
||||
#exit 0 |
||||
#exit 42 |
||||
|
||||
|
||||
#--------------------------------------------------------- |
||||
#-- end if true==shellbat on very first line\ |
||||
fi |
||||
#--------------------------------------------------------- |
||||
|
||||
#-- make sure sh/bash/tcl all skip over .bat style exit \ |
||||
: <<'shell_end' |
||||
#-- .bat exit with exitcode from tcl process \ |
||||
:exit |
||||
::lindex tcl;#\ |
||||
@exit /B %taskexitcode% |
||||
#\ |
||||
shell_end |
||||
|
@ -0,0 +1,3 @@
|
||||
::lindex tcl;#\ |
||||
@call tclsh "%~dp0%~n0.bat" %* & goto :eof |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
@ -0,0 +1,8 @@
|
||||
::lindex tcl;#\ |
||||
@call tclsh "%~dp0%~n0.bat" %* & goto :eof |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
||||
puts stdout "exe: [info nameof]" |
||||
puts stdout "scr: [info script]" |
||||
puts stdout "argc: $::argc" |
||||
puts stdout "argv: '$::argv'" |
||||
|
@ -0,0 +1,19 @@
|
||||
::set - { |
||||
@goto start |
||||
# -- tcl bat |
||||
:start |
||||
@echo off |
||||
set script=%0 |
||||
echo %* |
||||
if exist %script%.bat set script=%script%.bat |
||||
tclsh %script% %* |
||||
goto end of BAT file |
||||
};unset - ;# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
||||
|
||||
puts stdout "exe: [info nameof]" |
||||
puts stdout "scr: [info script]" |
||||
puts stdout "argc: $::argc" |
||||
puts stdout "argv: '$::argv'" |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl\ |
||||
:end of BAT file |
File diff suppressed because it is too large
Load Diff
@ -1,6 +1,6 @@
|
||||
#!/bin/sh |
||||
# -*- tcl -*- \ |
||||
# 'build.tcl' name as required by kettle |
||||
# Can be run directly - but also using `pmix Kettle ...` or `pmix KettleShell ...`\ |
||||
# Can be run directly - but also using `deck Kettle ...` or `deck KettleShell ...`\ |
||||
exec ./kettle -f "$0" "${1+$@}" |
||||
kettle doc |
||||
|
@ -1 +0,0 @@
|
||||
bootsupport libs and modules |
@ -1,200 +0,0 @@
|
||||
# cksum.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# Provides a Tcl only implementation of the unix cksum(1) command. This is |
||||
# similar to the sum(1) command but the algorithm is better defined and |
||||
# standardized across multiple platforms by POSIX 1003.2/D11.2 |
||||
# |
||||
# This command has been verified against the cksum command from the GNU |
||||
# textutils package version 2.0 |
||||
# |
||||
# ------------------------------------------------------------------------- |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# ------------------------------------------------------------------------- |
||||
|
||||
package require Tcl 8.5-; # tcl minimum version |
||||
|
||||
namespace eval ::crc { |
||||
namespace export cksum |
||||
|
||||
variable cksum_tbl [list 0x0 \ |
||||
0x04C11DB7 0x09823B6E 0x0D4326D9 0x130476DC 0x17C56B6B \ |
||||
0x1A864DB2 0x1E475005 0x2608EDB8 0x22C9F00F 0x2F8AD6D6 \ |
||||
0x2B4BCB61 0x350C9B64 0x31CD86D3 0x3C8EA00A 0x384FBDBD \ |
||||
0x4C11DB70 0x48D0C6C7 0x4593E01E 0x4152FDA9 0x5F15ADAC \ |
||||
0x5BD4B01B 0x569796C2 0x52568B75 0x6A1936C8 0x6ED82B7F \ |
||||
0x639B0DA6 0x675A1011 0x791D4014 0x7DDC5DA3 0x709F7B7A \ |
||||
0x745E66CD 0x9823B6E0 0x9CE2AB57 0x91A18D8E 0x95609039 \ |
||||
0x8B27C03C 0x8FE6DD8B 0x82A5FB52 0x8664E6E5 0xBE2B5B58 \ |
||||
0xBAEA46EF 0xB7A96036 0xB3687D81 0xAD2F2D84 0xA9EE3033 \ |
||||
0xA4AD16EA 0xA06C0B5D 0xD4326D90 0xD0F37027 0xDDB056FE \ |
||||
0xD9714B49 0xC7361B4C 0xC3F706FB 0xCEB42022 0xCA753D95 \ |
||||
0xF23A8028 0xF6FB9D9F 0xFBB8BB46 0xFF79A6F1 0xE13EF6F4 \ |
||||
0xE5FFEB43 0xE8BCCD9A 0xEC7DD02D 0x34867077 0x30476DC0 \ |
||||
0x3D044B19 0x39C556AE 0x278206AB 0x23431B1C 0x2E003DC5 \ |
||||
0x2AC12072 0x128E9DCF 0x164F8078 0x1B0CA6A1 0x1FCDBB16 \ |
||||
0x018AEB13 0x054BF6A4 0x0808D07D 0x0CC9CDCA 0x7897AB07 \ |
||||
0x7C56B6B0 0x71159069 0x75D48DDE 0x6B93DDDB 0x6F52C06C \ |
||||
0x6211E6B5 0x66D0FB02 0x5E9F46BF 0x5A5E5B08 0x571D7DD1 \ |
||||
0x53DC6066 0x4D9B3063 0x495A2DD4 0x44190B0D 0x40D816BA \ |
||||
0xACA5C697 0xA864DB20 0xA527FDF9 0xA1E6E04E 0xBFA1B04B \ |
||||
0xBB60ADFC 0xB6238B25 0xB2E29692 0x8AAD2B2F 0x8E6C3698 \ |
||||
0x832F1041 0x87EE0DF6 0x99A95DF3 0x9D684044 0x902B669D \ |
||||
0x94EA7B2A 0xE0B41DE7 0xE4750050 0xE9362689 0xEDF73B3E \ |
||||
0xF3B06B3B 0xF771768C 0xFA325055 0xFEF34DE2 0xC6BCF05F \ |
||||
0xC27DEDE8 0xCF3ECB31 0xCBFFD686 0xD5B88683 0xD1799B34 \ |
||||
0xDC3ABDED 0xD8FBA05A 0x690CE0EE 0x6DCDFD59 0x608EDB80 \ |
||||
0x644FC637 0x7A089632 0x7EC98B85 0x738AAD5C 0x774BB0EB \ |
||||
0x4F040D56 0x4BC510E1 0x46863638 0x42472B8F 0x5C007B8A \ |
||||
0x58C1663D 0x558240E4 0x51435D53 0x251D3B9E 0x21DC2629 \ |
||||
0x2C9F00F0 0x285E1D47 0x36194D42 0x32D850F5 0x3F9B762C \ |
||||
0x3B5A6B9B 0x0315D626 0x07D4CB91 0x0A97ED48 0x0E56F0FF \ |
||||
0x1011A0FA 0x14D0BD4D 0x19939B94 0x1D528623 0xF12F560E \ |
||||
0xF5EE4BB9 0xF8AD6D60 0xFC6C70D7 0xE22B20D2 0xE6EA3D65 \ |
||||
0xEBA91BBC 0xEF68060B 0xD727BBB6 0xD3E6A601 0xDEA580D8 \ |
||||
0xDA649D6F 0xC423CD6A 0xC0E2D0DD 0xCDA1F604 0xC960EBB3 \ |
||||
0xBD3E8D7E 0xB9FF90C9 0xB4BCB610 0xB07DABA7 0xAE3AFBA2 \ |
||||
0xAAFBE615 0xA7B8C0CC 0xA379DD7B 0x9B3660C6 0x9FF77D71 \ |
||||
0x92B45BA8 0x9675461F 0x8832161A 0x8CF30BAD 0x81B02D74 \ |
||||
0x857130C3 0x5D8A9099 0x594B8D2E 0x5408ABF7 0x50C9B640 \ |
||||
0x4E8EE645 0x4A4FFBF2 0x470CDD2B 0x43CDC09C 0x7B827D21 \ |
||||
0x7F436096 0x7200464F 0x76C15BF8 0x68860BFD 0x6C47164A \ |
||||
0x61043093 0x65C52D24 0x119B4BE9 0x155A565E 0x18197087 \ |
||||
0x1CD86D30 0x029F3D35 0x065E2082 0x0B1D065B 0x0FDC1BEC \ |
||||
0x3793A651 0x3352BBE6 0x3E119D3F 0x3AD08088 0x2497D08D \ |
||||
0x2056CD3A 0x2D15EBE3 0x29D4F654 0xC5A92679 0xC1683BCE \ |
||||
0xCC2B1D17 0xC8EA00A0 0xD6AD50A5 0xD26C4D12 0xDF2F6BCB \ |
||||
0xDBEE767C 0xE3A1CBC1 0xE760D676 0xEA23F0AF 0xEEE2ED18 \ |
||||
0xF0A5BD1D 0xF464A0AA 0xF9278673 0xFDE69BC4 0x89B8FD09 \ |
||||
0x8D79E0BE 0x803AC667 0x84FBDBD0 0x9ABC8BD5 0x9E7D9662 \ |
||||
0x933EB0BB 0x97FFAD0C 0xAFB010B1 0xAB710D06 0xA6322BDF \ |
||||
0xA2F33668 0xBCB4666D 0xB8757BDA 0xB5365D03 0xB1F740B4 ] |
||||
|
||||
variable uid |
||||
if {![info exists uid]} {set uid 0} |
||||
} |
||||
|
||||
# crc::CksumInit -- |
||||
# |
||||
# Create and initialize a cksum context. This is cleaned up when we |
||||
# call CksumFinal to obtain the result. |
||||
# |
||||
proc ::crc::CksumInit {} { |
||||
variable uid |
||||
set token [namespace current]::[incr uid] |
||||
upvar #0 $token state |
||||
array set state {t 0 l 0} |
||||
return $token |
||||
} |
||||
|
||||
proc ::crc::CksumUpdate {token data} { |
||||
variable cksum_tbl |
||||
upvar #0 $token state |
||||
set t $state(t) |
||||
binary scan $data c* r |
||||
foreach {n} $r { |
||||
set index [expr { (($t >> 24) ^ ($n & 0xFF)) & 0xFF }] |
||||
# Since the introduction of built-in bigInt support with Tcl |
||||
# 8.5, bit-shifting $t to the left no longer overflows, |
||||
# keeping it 32 bits long. The value grows bigger and bigger |
||||
# instead - a severe hit on performance. For this reason we |
||||
# do a bitwise AND against 0xFFFFFFFF at each step to keep the |
||||
# value within limits. |
||||
set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] |
||||
incr state(l) |
||||
} |
||||
set state(t) $t |
||||
return |
||||
} |
||||
|
||||
proc ::crc::CksumFinal {token} { |
||||
variable cksum_tbl |
||||
upvar #0 $token state |
||||
set t $state(t) |
||||
for {set i $state(l)} {$i > 0} {set i [expr {$i>>8}]} { |
||||
set index [expr {(($t >> 24) ^ $i) & 0xFF}] |
||||
set t [expr {0xFFFFFFFF & (($t << 8) ^ [lindex $cksum_tbl $index])}] |
||||
} |
||||
unset state |
||||
return [expr {~$t & 0xFFFFFFFF}] |
||||
} |
||||
|
||||
# crc::Pop -- |
||||
# |
||||
# Pop the nth element off a list. Used in options processing. |
||||
# |
||||
proc ::crc::Pop {varname {nth 0}} { |
||||
upvar $varname args |
||||
set r [lindex $args $nth] |
||||
set args [lreplace $args $nth $nth] |
||||
return $r |
||||
} |
||||
|
||||
# Description: |
||||
# Provide a Tcl equivalent of the unix cksum(1) command. |
||||
# Options: |
||||
# -filename name - return a checksum for the specified file. |
||||
# -format string - return the checksum using this format string. |
||||
# -chunksize size - set the chunking read size |
||||
# |
||||
proc ::crc::cksum {args} { |
||||
array set opts [list -filename {} -channel {} -chunksize 4096 \ |
||||
-format %u -command {}] |
||||
while {[string match -* [set option [lindex $args 0]]]} { |
||||
switch -glob -- $option { |
||||
-file* { set opts(-filename) [Pop args 1] } |
||||
-chan* { set opts(-channel) [Pop args 1] } |
||||
-chunk* { set opts(-chunksize) [Pop args 1] } |
||||
-for* { set opts(-format) [Pop args 1] } |
||||
-command { set opts(-command) [Pop args 1] } |
||||
default { |
||||
if {[llength $args] == 1} { break } |
||||
if {[string compare $option "--"] == 0} { Pop args ; break } |
||||
set err [join [lsort [array names opts -*]] ", "] |
||||
return -code error "bad option \"option\": must be $err" |
||||
} |
||||
} |
||||
Pop args |
||||
} |
||||
|
||||
if {$opts(-filename) != {}} { |
||||
set opts(-channel) [open $opts(-filename) r] |
||||
fconfigure $opts(-channel) -translation binary |
||||
} |
||||
|
||||
if {$opts(-channel) == {}} { |
||||
|
||||
if {[llength $args] != 1} { |
||||
return -code error "wrong # args: should be\ |
||||
cksum ?-format string?\ |
||||
-channel chan | -filename file | string" |
||||
} |
||||
set tok [CksumInit] |
||||
CksumUpdate $tok [lindex $args 0] |
||||
set r [CksumFinal $tok] |
||||
|
||||
} else { |
||||
|
||||
set tok [CksumInit] |
||||
while {![eof $opts(-channel)]} { |
||||
CksumUpdate $tok [read $opts(-channel) $opts(-chunksize)] |
||||
} |
||||
set r [CksumFinal $tok] |
||||
|
||||
if {$opts(-filename) != {}} { |
||||
close $opts(-channel) |
||||
} |
||||
} |
||||
|
||||
return [format $opts(-format) $r] |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
package provide cksum 1.1.4 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Local variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
@ -1,933 +0,0 @@
|
||||
# cmdline.tcl -- |
||||
# |
||||
# This package provides a utility for parsing command line |
||||
# arguments that are processed by our various applications. |
||||
# It also includes a utility routine to determine the |
||||
# application name for use in command line errors. |
||||
# |
||||
# Copyright (c) 1998-2000 by Ajuba Solutions. |
||||
# Copyright (c) 2001-2015 by Andreas Kupries <andreas_kupries@users.sf.net>. |
||||
# Copyright (c) 2003 by David N. Welton <davidw@dedasys.com> |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
|
||||
package require Tcl 8.5- |
||||
package provide cmdline 1.5.2 |
||||
|
||||
namespace eval ::cmdline { |
||||
namespace export getArgv0 getopt getKnownOpt getfiles getoptions \ |
||||
getKnownOptions usage |
||||
} |
||||
|
||||
# ::cmdline::getopt -- |
||||
# |
||||
# The cmdline::getopt works in a fashion like the standard |
||||
# C based getopt function. Given an option string and a |
||||
# pointer to an array or args this command will process the |
||||
# first argument and return info on how to proceed. |
||||
# |
||||
# Arguments: |
||||
# argvVar Name of the argv list that you |
||||
# want to process. If options are found the |
||||
# arg list is modified and the processed arguments |
||||
# are removed from the start of the list. |
||||
# optstring A list of command options that the application |
||||
# will accept. If the option ends in ".arg" the |
||||
# getopt routine will use the next argument as |
||||
# an argument to the option. Otherwise the option |
||||
# is a boolean that is set to 1 if present. |
||||
# optVar The variable pointed to by optVar |
||||
# contains the option that was found (without the |
||||
# leading '-' and without the .arg extension). |
||||
# valVar Upon success, the variable pointed to by valVar |
||||
# contains the value for the specified option. |
||||
# This value comes from the command line for .arg |
||||
# options, otherwise the value is 1. |
||||
# If getopt fails, the valVar is filled with an |
||||
# error message. |
||||
# |
||||
# Results: |
||||
# The getopt function returns 1 if an option was found, 0 if no more |
||||
# options were found, and -1 if an error occurred. |
||||
|
||||
proc ::cmdline::getopt {argvVar optstring optVar valVar} { |
||||
upvar 1 $argvVar argsList |
||||
upvar 1 $optVar option |
||||
upvar 1 $valVar value |
||||
|
||||
set result [getKnownOpt argsList $optstring option value] |
||||
|
||||
if {$result < 0} { |
||||
# Collapse unknown-option error into any-other-error result. |
||||
set result -1 |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
# ::cmdline::getKnownOpt -- |
||||
# |
||||
# The cmdline::getKnownOpt works in a fashion like the standard |
||||
# C based getopt function. Given an option string and a |
||||
# pointer to an array or args this command will process the |
||||
# first argument and return info on how to proceed. |
||||
# |
||||
# Arguments: |
||||
# argvVar Name of the argv list that you |
||||
# want to process. If options are found the |
||||
# arg list is modified and the processed arguments |
||||
# are removed from the start of the list. Note that |
||||
# unknown options and the args that follow them are |
||||
# left in this list. |
||||
# optstring A list of command options that the application |
||||
# will accept. If the option ends in ".arg" the |
||||
# getopt routine will use the next argument as |
||||
# an argument to the option. Otherwise the option |
||||
# is a boolean that is set to 1 if present. |
||||
# optVar The variable pointed to by optVar |
||||
# contains the option that was found (without the |
||||
# leading '-' and without the .arg extension). |
||||
# valVar Upon success, the variable pointed to by valVar |
||||
# contains the value for the specified option. |
||||
# This value comes from the command line for .arg |
||||
# options, otherwise the value is 1. |
||||
# If getopt fails, the valVar is filled with an |
||||
# error message. |
||||
# |
||||
# Results: |
||||
# The getKnownOpt function returns 1 if an option was found, |
||||
# 0 if no more options were found, -1 if an unknown option was |
||||
# encountered, and -2 if any other error occurred. |
||||
|
||||
proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} { |
||||
upvar 1 $argvVar argsList |
||||
upvar 1 $optVar option |
||||
upvar 1 $valVar value |
||||
|
||||
# default settings for a normal return |
||||
set value "" |
||||
set option "" |
||||
set result 0 |
||||
|
||||
# check if we're past the end of the args list |
||||
if {[llength $argsList] != 0} { |
||||
|
||||
# if we got -- or an option that doesn't begin with -, return (skipping |
||||
# the --). otherwise process the option arg. |
||||
switch -glob -- [set arg [lindex $argsList 0]] { |
||||
"--" { |
||||
set argsList [lrange $argsList 1 end] |
||||
} |
||||
"--*" - |
||||
"-*" { |
||||
set option [string range $arg 1 end] |
||||
if {[string equal [string range $option 0 0] "-"]} { |
||||
set option [string range $arg 2 end] |
||||
} |
||||
|
||||
# support for format: [-]-option=value |
||||
set idx [string first "=" $option 1] |
||||
if {$idx != -1} { |
||||
set _val [string range $option [expr {$idx+1}] end] |
||||
set option [string range $option 0 [expr {$idx-1}]] |
||||
} |
||||
|
||||
if {[lsearch -exact $optstring $option] != -1} { |
||||
# Booleans are set to 1 when present |
||||
set value 1 |
||||
set result 1 |
||||
set argsList [lrange $argsList 1 end] |
||||
} elseif {[lsearch -exact $optstring "$option.arg"] != -1} { |
||||
set result 1 |
||||
set argsList [lrange $argsList 1 end] |
||||
|
||||
if {[info exists _val]} { |
||||
set value $_val |
||||
} elseif {[llength $argsList]} { |
||||
set value [lindex $argsList 0] |
||||
set argsList [lrange $argsList 1 end] |
||||
} else { |
||||
set value "Option \"$option\" requires an argument" |
||||
set result -2 |
||||
} |
||||
} else { |
||||
# Unknown option. |
||||
set value "Illegal option \"-$option\"" |
||||
set result -1 |
||||
} |
||||
} |
||||
default { |
||||
# Skip ahead |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
# ::cmdline::getoptions -- |
||||
# |
||||
# Process a set of command line options, filling in defaults |
||||
# for those not specified. This also generates an error message |
||||
# that lists the allowed flags if an incorrect flag is specified. |
||||
# |
||||
# Arguments: |
||||
# argvVar The name of the argument list, typically argv. |
||||
# We remove all known options and their args from it. |
||||
# In other words, after the call to this command the |
||||
# referenced variable contains only the non-options, |
||||
# and unknown options. |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# (where flag takes no argument) |
||||
# flag comment |
||||
# |
||||
# (or where flag takes an argument) |
||||
# flag default comment |
||||
# |
||||
# If flag ends in ".arg" then the value is taken from the |
||||
# command line. Otherwise it is a boolean and appears in |
||||
# the result if present on the command line. If flag ends |
||||
# in ".secret", it will not be displayed in the usage. |
||||
# usage Text to include in the usage display. Defaults to |
||||
# "options:" |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
# A modified `argvVar`. |
||||
|
||||
proc ::cmdline::getoptions {argvVar optlist {usage options:}} { |
||||
upvar 1 $argvVar argv |
||||
|
||||
set opts [GetOptionDefaults $optlist result] |
||||
|
||||
set argc [llength $argv] |
||||
while {[set err [getopt argv $opts opt arg]]} { |
||||
if {$err < 0} { |
||||
set result(?) "" |
||||
break |
||||
} |
||||
set result($opt) $arg |
||||
} |
||||
if {[info exist result(?)] || [info exists result(help)]} { |
||||
Error [usage $optlist $usage] USAGE |
||||
} |
||||
return [array get result] |
||||
} |
||||
|
||||
# ::cmdline::getKnownOptions -- |
||||
# |
||||
# Process a set of command line options, filling in defaults |
||||
# for those not specified. This ignores unknown flags, but generates |
||||
# an error message that lists the correct usage if a known option |
||||
# is used incorrectly. |
||||
# |
||||
# Arguments: |
||||
# argvVar The name of the argument list, typically argv. This |
||||
# We remove all known options and their args from it. |
||||
# In other words, after the call to this command the |
||||
# referenced variable contains only the non-options, |
||||
# and unknown options. |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# flag default comment |
||||
# If flag ends in ".arg" then the value is taken from the |
||||
# command line. Otherwise it is a boolean and appears in |
||||
# the result if present on the command line. If flag ends |
||||
# in ".secret", it will not be displayed in the usage. |
||||
# usage Text to include in the usage display. Defaults to |
||||
# "options:" |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
# A modified `argvVar`. |
||||
|
||||
proc ::cmdline::getKnownOptions {argvVar optlist {usage options:}} { |
||||
upvar 1 $argvVar argv |
||||
|
||||
set opts [GetOptionDefaults $optlist result] |
||||
|
||||
# As we encounter them, keep the unknown options and their |
||||
# arguments in this list. Before we return from this procedure, |
||||
# we'll prepend these args to the argList so that the application |
||||
# doesn't lose them. |
||||
|
||||
set unknownOptions [list] |
||||
|
||||
set argc [llength $argv] |
||||
while {[set err [getKnownOpt argv $opts opt arg]]} { |
||||
if {$err == -1} { |
||||
# Unknown option. |
||||
|
||||
# Skip over any non-option items that follow it. |
||||
# For now, add them to the list of unknownOptions. |
||||
lappend unknownOptions [lindex $argv 0] |
||||
set argv [lrange $argv 1 end] |
||||
while {([llength $argv] != 0) \ |
||||
&& ![string match "-*" [lindex $argv 0]]} { |
||||
lappend unknownOptions [lindex $argv 0] |
||||
set argv [lrange $argv 1 end] |
||||
} |
||||
} elseif {$err == -2} { |
||||
set result(?) "" |
||||
break |
||||
} else { |
||||
set result($opt) $arg |
||||
} |
||||
} |
||||
|
||||
# Before returning, prepend the any unknown args back onto the |
||||
# argList so that the application doesn't lose them. |
||||
set argv [concat $unknownOptions $argv] |
||||
|
||||
if {[info exist result(?)] || [info exists result(help)]} { |
||||
Error [usage $optlist $usage] USAGE |
||||
} |
||||
return [array get result] |
||||
} |
||||
|
||||
# ::cmdline::GetOptionDefaults -- |
||||
# |
||||
# This internal procedure processes the option list (that was passed to |
||||
# the getopt or getKnownOpt procedure). The defaultArray gets an index |
||||
# for each option in the option list, the value of which is the option's |
||||
# default value. |
||||
# |
||||
# Arguments: |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# flag default comment |
||||
# If flag ends in ".arg" then the value is taken from the |
||||
# command line. Otherwise it is a boolean and appears in |
||||
# the result if present on the command line. If flag ends |
||||
# in ".secret", it will not be displayed in the usage. |
||||
# defaultArrayVar The name of the array in which to put argument defaults. |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
|
||||
proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} { |
||||
upvar 1 $defaultArrayVar result |
||||
|
||||
set opts {? help} |
||||
foreach opt $optlist { |
||||
set name [lindex $opt 0] |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Need to hide this from the usage display and getopt |
||||
} |
||||
lappend opts $name |
||||
if {[regsub -- {\.arg$} $name {} name] == 1} { |
||||
|
||||
# Set defaults for those that take values. |
||||
|
||||
set default [lindex $opt 1] |
||||
set result($name) $default |
||||
} else { |
||||
# The default for booleans is false |
||||
set result($name) 0 |
||||
} |
||||
} |
||||
return $opts |
||||
} |
||||
|
||||
# ::cmdline::usage -- |
||||
# |
||||
# Generate an error message that lists the allowed flags. |
||||
# |
||||
# Arguments: |
||||
# optlist As for cmdline::getoptions |
||||
# usage Text to include in the usage display. Defaults to |
||||
# "options:" |
||||
# |
||||
# Results |
||||
# A formatted usage message |
||||
|
||||
proc ::cmdline::usage {optlist {usage {options:}}} { |
||||
set str "[getArgv0] $usage\n" |
||||
set longest 20 |
||||
set lines {} |
||||
foreach opt [concat $optlist \ |
||||
{{- "Forcibly stop option processing"} {help "Print this message"} {? "Print this message"}}] { |
||||
set name "-[lindex $opt 0]" |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Hidden option |
||||
continue |
||||
} |
||||
if {[regsub -- {\.arg$} $name {} name] == 1} { |
||||
append name " value" |
||||
set desc "[lindex $opt 2] <[lindex $opt 1]>" |
||||
} else { |
||||
set desc "[lindex $opt 1]" |
||||
} |
||||
set n [string length $name] |
||||
if {$n > $longest} { set longest $n } |
||||
# max not available before 8.5 - set longest [expr {max($longest, )}] |
||||
lappend lines $name $desc |
||||
} |
||||
foreach {name desc} $lines { |
||||
append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" |
||||
} |
||||
|
||||
return $str |
||||
} |
||||
|
||||
# ::cmdline::getfiles -- |
||||
# |
||||
# Given a list of file arguments from the command line, compute |
||||
# the set of valid files. On windows, file globbing is performed |
||||
# on each argument. On Unix, only file existence is tested. If |
||||
# a file argument produces no valid files, a warning is optionally |
||||
# generated. |
||||
# |
||||
# This code also uses the full path for each file. If not |
||||
# given it prepends [pwd] to the filename. This ensures that |
||||
# these files will never conflict with files in our zip file. |
||||
# |
||||
# Arguments: |
||||
# patterns The file patterns specified by the user. |
||||
# quiet If this flag is set, no warnings will be generated. |
||||
# |
||||
# Results: |
||||
# Returns the list of files that match the input patterns. |
||||
|
||||
proc ::cmdline::getfiles {patterns quiet} { |
||||
set result {} |
||||
if {$::tcl_platform(platform) == "windows"} { |
||||
foreach pattern $patterns { |
||||
set pat [file join $pattern] |
||||
set files [glob -nocomplain -- $pat] |
||||
if {$files == {}} { |
||||
if {! $quiet} { |
||||
puts stdout "warning: no files match \"$pattern\"" |
||||
} |
||||
} else { |
||||
foreach file $files { |
||||
lappend result $file |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
set result $patterns |
||||
} |
||||
set files {} |
||||
foreach file $result { |
||||
# Make file an absolute path so that we will never conflict |
||||
# with files that might be contained in our zip file. |
||||
set fullPath [file join [pwd] $file] |
||||
|
||||
if {[file isfile $fullPath]} { |
||||
lappend files $fullPath |
||||
} elseif {! $quiet} { |
||||
puts stdout "warning: no files match \"$file\"" |
||||
} |
||||
} |
||||
return $files |
||||
} |
||||
|
||||
# ::cmdline::getArgv0 -- |
||||
# |
||||
# This command returns the "sanitized" version of argv0. It will strip |
||||
# off the leading path and remove the ".bin" extensions that our apps |
||||
# use because they must be wrapped by a shell script. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# The application name that can be used in error messages. |
||||
|
||||
proc ::cmdline::getArgv0 {} { |
||||
global argv0 |
||||
|
||||
set name [file tail $argv0] |
||||
return [file rootname $name] |
||||
} |
||||
|
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
# Now the typed versions of the above commands. |
||||
## |
||||
# ### ### ### ######### ######### ######### |
||||
## |
||||
|
||||
# typedCmdline.tcl -- |
||||
# |
||||
# This package provides a utility for parsing typed command |
||||
# line arguments that may be processed by various applications. |
||||
# |
||||
# Copyright (c) 2000 by Ross Palmer Mohn. |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: cmdline.tcl,v 1.28 2011/02/23 17:41:52 andreas_kupries Exp $ |
||||
|
||||
namespace eval ::cmdline { |
||||
namespace export typedGetopt typedGetoptions typedUsage |
||||
|
||||
# variable cmdline::charclasses -- |
||||
# |
||||
# Create regexp list of allowable character classes |
||||
# from "string is" error message. |
||||
# |
||||
# Results: |
||||
# String of character class names separated by "|" characters. |
||||
|
||||
variable charclasses |
||||
#checker exclude badKey |
||||
catch {string is . .} charclasses |
||||
variable dummy |
||||
regexp -- {must be (.+)$} $charclasses dummy charclasses |
||||
regsub -all -- {, (or )?} $charclasses {|} charclasses |
||||
unset dummy |
||||
} |
||||
|
||||
# ::cmdline::typedGetopt -- |
||||
# |
||||
# The cmdline::typedGetopt works in a fashion like the standard |
||||
# C based getopt function. Given an option string and a |
||||
# pointer to a list of args this command will process the |
||||
# first argument and return info on how to proceed. In addition, |
||||
# you may specify a type for the argument to each option. |
||||
# |
||||
# Arguments: |
||||
# argvVar Name of the argv list that you want to process. |
||||
# If options are found, the arg list is modified |
||||
# and the processed arguments are removed from the |
||||
# start of the list. |
||||
# |
||||
# optstring A list of command options that the application |
||||
# will accept. If the option ends in ".xxx", where |
||||
# xxx is any valid character class to the tcl |
||||
# command "string is", then typedGetopt routine will |
||||
# use the next argument as a typed argument to the |
||||
# option. The argument must match the specified |
||||
# character classes (e.g. integer, double, boolean, |
||||
# xdigit, etc.). Alternatively, you may specify |
||||
# ".arg" for an untyped argument. |
||||
# |
||||
# optVar Upon success, the variable pointed to by optVar |
||||
# contains the option that was found (without the |
||||
# leading '-' and without the .xxx extension). If |
||||
# typedGetopt fails the variable is set to the empty |
||||
# string. SOMETIMES! Different for each -value! |
||||
# |
||||
# argVar Upon success, the variable pointed to by argVar |
||||
# contains the argument for the specified option. |
||||
# If typedGetopt fails, the variable is filled with |
||||
# an error message. |
||||
# |
||||
# Argument type syntax: |
||||
# Option that takes no argument. |
||||
# foo |
||||
# |
||||
# Option that takes a typeless argument. |
||||
# foo.arg |
||||
# |
||||
# Option that takes a typed argument. Allowable types are all |
||||
# valid character classes to the tcl command "string is". |
||||
# Currently must be one of alnum, alpha, ascii, control, |
||||
# boolean, digit, double, false, graph, integer, lower, print, |
||||
# punct, space, true, upper, wordchar, or xdigit. |
||||
# foo.double |
||||
# |
||||
# Option that takes an argument from a list. |
||||
# foo.(bar|blat) |
||||
# |
||||
# Argument quantifier syntax: |
||||
# Option that takes an optional argument. |
||||
# foo.arg? |
||||
# |
||||
# Option that takes a list of arguments terminated by "--". |
||||
# foo.arg+ |
||||
# |
||||
# Option that takes an optional list of arguments terminated by "--". |
||||
# foo.arg* |
||||
# |
||||
# Argument quantifiers work on all argument types, so, for |
||||
# example, the following is a valid option specification. |
||||
# foo.(bar|blat|blah)? |
||||
# |
||||
# Argument syntax miscellany: |
||||
# Options may be specified on the command line using a unique, |
||||
# shortened version of the option name. Given that program foo |
||||
# has an option list of {bar.alpha blah.arg blat.double}, |
||||
# "foo -b fob" returns an error, but "foo -ba fob" |
||||
# successfully returns {bar fob} |
||||
# |
||||
# Results: |
||||
# The typedGetopt function returns one of the following: |
||||
# 1 a valid option was found |
||||
# 0 no more options found to process |
||||
# -1 invalid option |
||||
# -2 missing argument to a valid option |
||||
# -3 argument to a valid option does not match type |
||||
# |
||||
# Known Bugs: |
||||
# When using options which include special glob characters, |
||||
# you must use the exact option. Abbreviating it can cause |
||||
# an error in the "cmdline::prefixSearch" procedure. |
||||
|
||||
proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} { |
||||
variable charclasses |
||||
|
||||
upvar $argvVar argsList |
||||
|
||||
upvar $optVar retvar |
||||
upvar $argVar optarg |
||||
|
||||
# default settings for a normal return |
||||
set optarg "" |
||||
set retvar "" |
||||
set retval 0 |
||||
|
||||
# check if we're past the end of the args list |
||||
if {[llength $argsList] != 0} { |
||||
|
||||
# if we got -- or an option that doesn't begin with -, return (skipping |
||||
# the --). otherwise process the option arg. |
||||
switch -glob -- [set arg [lindex $argsList 0]] { |
||||
"--" { |
||||
set argsList [lrange $argsList 1 end] |
||||
} |
||||
|
||||
"-*" { |
||||
# Create list of options without their argument extensions |
||||
|
||||
set optstr "" |
||||
foreach str $optstring { |
||||
lappend optstr [file rootname $str] |
||||
} |
||||
|
||||
set _opt [string range $arg 1 end] |
||||
|
||||
set i [prefixSearch $optstr [file rootname $_opt]] |
||||
if {$i != -1} { |
||||
set opt [lindex $optstring $i] |
||||
|
||||
set quantifier "none" |
||||
if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} { |
||||
set opt [string range $opt 0 end-1] |
||||
} |
||||
|
||||
if {[string first . $opt] == -1} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
set argsList [lrange $argsList 1 end] |
||||
|
||||
} elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass] |
||||
|| [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} { |
||||
if {[string equal arg $charclass]} { |
||||
set type arg |
||||
} elseif {[regexp -- "^($charclasses)\$" $charclass]} { |
||||
set type class |
||||
} else { |
||||
set type oneof |
||||
} |
||||
|
||||
set argsList [lrange $argsList 1 end] |
||||
set opt [file rootname $opt] |
||||
|
||||
while {1} { |
||||
if {[llength $argsList] == 0 |
||||
|| [string equal "--" [lindex $argsList 0]]} { |
||||
if {[string equal "--" [lindex $argsList 0]]} { |
||||
set argsList [lrange $argsList 1 end] |
||||
} |
||||
|
||||
set oneof "" |
||||
if {$type == "arg"} { |
||||
set charclass an |
||||
} elseif {$type == "oneof"} { |
||||
set oneof ", one of $charclass" |
||||
set charclass an |
||||
} |
||||
|
||||
if {$quantifier == "?"} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
set optarg "" |
||||
} elseif {$quantifier == "+"} { |
||||
set retvar $opt |
||||
if {[llength $optarg] < 1} { |
||||
set retval -2 |
||||
set optarg "Option requires at least one $charclass argument$oneof -- $opt" |
||||
} else { |
||||
set retval 1 |
||||
} |
||||
} elseif {$quantifier == "*"} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
} else { |
||||
set optarg "Option requires $charclass argument$oneof -- $opt" |
||||
set retvar $opt |
||||
set retval -2 |
||||
} |
||||
set quantifier "" |
||||
} elseif {($type == "arg") |
||||
|| (($type == "oneof") |
||||
&& [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1) |
||||
|| (($type == "class") |
||||
&& [string is $charclass [lindex $argsList 0]])} { |
||||
set retval 1 |
||||
set retvar $opt |
||||
lappend optarg [lindex $argsList 0] |
||||
set argsList [lrange $argsList 1 end] |
||||
} else { |
||||
set oneof "" |
||||
if {$type == "arg"} { |
||||
set charclass an |
||||
} elseif {$type == "oneof"} { |
||||
set oneof ", one of $charclass" |
||||
set charclass an |
||||
} |
||||
set optarg "Option requires $charclass argument$oneof -- $opt" |
||||
set retvar $opt |
||||
set retval -3 |
||||
|
||||
if {$quantifier == "?"} { |
||||
set retval 1 |
||||
set optarg "" |
||||
} |
||||
set quantifier "" |
||||
} |
||||
if {![regexp -- {[+*]} $quantifier]} { |
||||
break; |
||||
} |
||||
} |
||||
} else { |
||||
Error \ |
||||
"Illegal option type specification: must be one of $charclasses" \ |
||||
BAD OPTION TYPE |
||||
} |
||||
} else { |
||||
set optarg "Illegal option -- $_opt" |
||||
set retvar $_opt |
||||
set retval -1 |
||||
} |
||||
} |
||||
default { |
||||
# Skip ahead |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $retval |
||||
} |
||||
|
||||
# ::cmdline::typedGetoptions -- |
||||
# |
||||
# Process a set of command line options, filling in defaults |
||||
# for those not specified. This also generates an error message |
||||
# that lists the allowed options if an incorrect option is |
||||
# specified. |
||||
# |
||||
# Arguments: |
||||
# argvVar The name of the argument list, typically argv |
||||
# optlist A list-of-lists where each element specifies an option |
||||
# in the form: |
||||
# |
||||
# option default comment |
||||
# |
||||
# Options formatting is as described for the optstring |
||||
# argument of typedGetopt. Default is for optionally |
||||
# specifying a default value. Comment is for optionally |
||||
# specifying a comment for the usage display. The |
||||
# options "--", "-help", and "-?" are automatically included |
||||
# in optlist. |
||||
# |
||||
# Argument syntax miscellany: |
||||
# Options formatting and syntax is as described in typedGetopt. |
||||
# There are two additional suffixes that may be applied when |
||||
# passing options to typedGetoptions. |
||||
# |
||||
# You may add ".multi" as a suffix to any option. For options |
||||
# that take an argument, this means that the option may be used |
||||
# more than once on the command line and that each additional |
||||
# argument will be appended to a list, which is then returned |
||||
# to the application. |
||||
# foo.double.multi |
||||
# |
||||
# If a non-argument option is specified as ".multi", it is |
||||
# toggled on and off for each time it is used on the command |
||||
# line. |
||||
# foo.multi |
||||
# |
||||
# If an option specification does not contain the ".multi" |
||||
# suffix, it is not an error to use an option more than once. |
||||
# In this case, the behavior for options with arguments is that |
||||
# the last argument is the one that will be returned. For |
||||
# options that do not take arguments, using them more than once |
||||
# has no additional effect. |
||||
# |
||||
# Options may also be hidden from the usage display by |
||||
# appending the suffix ".secret" to any option specification. |
||||
# Please note that the ".secret" suffix must be the last suffix, |
||||
# after any argument type specification and ".multi" suffix. |
||||
# foo.xdigit.multi.secret |
||||
# |
||||
# Results |
||||
# Name value pairs suitable for using with array set. |
||||
|
||||
proc ::cmdline::typedGetoptions {argvVar optlist {usage options:}} { |
||||
variable charclasses |
||||
|
||||
upvar 1 $argvVar argv |
||||
|
||||
set opts {? help} |
||||
foreach opt $optlist { |
||||
set name [lindex $opt 0] |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Remove this extension before passing to typedGetopt. |
||||
} |
||||
if {[regsub -- {\.multi$} $name {} name] == 1} { |
||||
# Remove this extension before passing to typedGetopt. |
||||
|
||||
regsub -- {\..*$} $name {} temp |
||||
set multi($temp) 1 |
||||
} |
||||
lappend opts $name |
||||
if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} { |
||||
# Set defaults for those that take values. |
||||
# Booleans are set just by being present, or not |
||||
|
||||
set dflt [lindex $opt 1] |
||||
if {$dflt != {}} { |
||||
set defaults($name) $dflt |
||||
} |
||||
} |
||||
} |
||||
set argc [llength $argv] |
||||
while {[set err [typedGetopt argv $opts opt arg]]} { |
||||
if {$err == 1} { |
||||
if {[info exists result($opt)] |
||||
&& [info exists multi($opt)]} { |
||||
# Toggle boolean options or append new arguments |
||||
|
||||
if {$arg == ""} { |
||||
unset result($opt) |
||||
} else { |
||||
set result($opt) "$result($opt) $arg" |
||||
} |
||||
} else { |
||||
set result($opt) "$arg" |
||||
} |
||||
} elseif {($err == -1) || ($err == -3)} { |
||||
Error [typedUsage $optlist $usage] USAGE |
||||
} elseif {$err == -2 && ![info exists defaults($opt)]} { |
||||
Error [typedUsage $optlist $usage] USAGE |
||||
} |
||||
} |
||||
if {[info exists result(?)] || [info exists result(help)]} { |
||||
Error [typedUsage $optlist $usage] USAGE |
||||
} |
||||
foreach {opt dflt} [array get defaults] { |
||||
if {![info exists result($opt)]} { |
||||
set result($opt) $dflt |
||||
} |
||||
} |
||||
return [array get result] |
||||
} |
||||
|
||||
# ::cmdline::typedUsage -- |
||||
# |
||||
# Generate an error message that lists the allowed flags, |
||||
# type of argument taken (if any), default value (if any), |
||||
# and an optional description. |
||||
# |
||||
# Arguments: |
||||
# optlist As for cmdline::typedGetoptions |
||||
# |
||||
# Results |
||||
# A formatted usage message |
||||
|
||||
proc ::cmdline::typedUsage {optlist {usage {options:}}} { |
||||
variable charclasses |
||||
|
||||
set str "[getArgv0] $usage\n" |
||||
set longest 20 |
||||
set lines {} |
||||
foreach opt [concat $optlist \ |
||||
{{help "Print this message"} {? "Print this message"}}] { |
||||
set name "-[lindex $opt 0]" |
||||
if {[regsub -- {\.secret$} $name {} name] == 1} { |
||||
# Hidden option |
||||
continue |
||||
} |
||||
|
||||
if {[regsub -- {\.multi$} $name {} name] == 1} { |
||||
# Display something about multiple options |
||||
} |
||||
|
||||
if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass] || |
||||
[regexp -- {\.\(([^)]+)\)} $opt dummy charclass] |
||||
} { |
||||
regsub -- "\\..+\$" $name {} name |
||||
append name " $charclass" |
||||
set desc [lindex $opt 2] |
||||
set default [lindex $opt 1] |
||||
if {$default != ""} { |
||||
append desc " <$default>" |
||||
} |
||||
} else { |
||||
set desc [lindex $opt 1] |
||||
} |
||||
lappend accum $name $desc |
||||
set n [string length $name] |
||||
if {$n > $longest} { set longest $n } |
||||
# max not available before 8.5 - set longest [expr {max($longest, [string length $name])}] |
||||
} |
||||
foreach {name desc} $accum { |
||||
append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n" |
||||
} |
||||
return $str |
||||
} |
||||
|
||||
# ::cmdline::prefixSearch -- |
||||
# |
||||
# Search a Tcl list for a pattern; searches first for an exact match, |
||||
# and if that fails, for a unique prefix that matches the pattern |
||||
# (i.e, first "lsearch -exact", then "lsearch -glob $pattern*" |
||||
# |
||||
# Arguments: |
||||
# list list of words |
||||
# pattern word to search for |
||||
# |
||||
# Results: |
||||
# Index of found word is returned. If no exact match or |
||||
# unique short version is found then -1 is returned. |
||||
|
||||
proc ::cmdline::prefixSearch {list pattern} { |
||||
# Check for an exact match |
||||
|
||||
if {[set pos [::lsearch -exact $list $pattern]] > -1} { |
||||
return $pos |
||||
} |
||||
|
||||
# Check for a unique short version |
||||
|
||||
set slist [lsort $list] |
||||
if {[set pos [::lsearch -glob $slist $pattern*]] > -1} { |
||||
# What if there is nothing for the check variable? |
||||
|
||||
set check [lindex $slist [expr {$pos + 1}]] |
||||
if {[string first $pattern $check] != 0} { |
||||
return [::lsearch -exact $list [lindex $slist $pos]] |
||||
} |
||||
} |
||||
return -1 |
||||
} |
||||
# ::cmdline::Error -- |
||||
# |
||||
# Internal helper to throw errors with a proper error-code attached. |
||||
# |
||||
# Arguments: |
||||
# message text of the error message to throw. |
||||
# args additional parts of the error code to use, |
||||
# with CMDLINE as basic prefix added by this command. |
||||
# |
||||
# Results: |
||||
# An error is thrown, always. |
||||
|
||||
proc ::cmdline::Error {message args} { |
||||
return -code error -errorcode [linsert $args 0 CMDLINE] $message |
||||
} |
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,195 +0,0 @@
|
||||
#JMN - api should be kept in sync with package patternlib where possible |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
namespace eval oolib { |
||||
oo::class create collection { |
||||
variable o_data ;#dict |
||||
variable o_alias |
||||
constructor {} { |
||||
set o_data [dict create] |
||||
} |
||||
method info {} { |
||||
return [dict info $o_data] |
||||
} |
||||
method count {} { |
||||
return [dict size $o_data] |
||||
} |
||||
method isEmpty {} { |
||||
expr {[dict size $o_data] == 0} |
||||
} |
||||
method names {{globOrIdx {}}} { |
||||
if {[llength $globOrIdx]} { |
||||
if {[string is integer -strict $globOrIdx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||
error "[self object] no such index : '$idx'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} else { |
||||
#glob |
||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||
} |
||||
} else { |
||||
return [dict keys $o_data] |
||||
} |
||||
} |
||||
#like names but without globbing |
||||
method keys {} { |
||||
dict keys $o_data |
||||
} |
||||
method key {{posn 0}} { |
||||
if {$posn < 0} { |
||||
set posn "end-[expr {abs($posn + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||
error "[self object] no such index : '$posn'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} |
||||
method hasKey {key} { |
||||
dict exists $o_data $key |
||||
} |
||||
method get {} { |
||||
return $o_data |
||||
} |
||||
method items {} { |
||||
return [dict values $o_data] |
||||
} |
||||
method item {key} { |
||||
if {[string is integer -strict $key]} { |
||||
if {$key > 0} { |
||||
set valposn [expr {(2*$key) +1}] |
||||
return [lindex $o_data $valposn] |
||||
} else { |
||||
set key "end-[expr {abs($key + 1)}]" |
||||
return [lindex [dict keys $o_data] $key] |
||||
} |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
return [dict get $o_data $key] |
||||
} |
||||
} |
||||
#inverse lookup |
||||
method itemKeys {value} { |
||||
set value_indices [lsearch -all [dict values $o_data] $value] |
||||
set keylist [list] |
||||
foreach i $value_indices { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
method search {value args} { |
||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||
if {"-inline" in $args} { |
||||
return $matches |
||||
} else { |
||||
set keylist [list] |
||||
foreach i $matches { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
} |
||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||
method alias {newAlias existingKeyOrAlias} { |
||||
if {[string is integer -strict $newAlias]} { |
||||
error "[self object] collection key alias cannot be integer" |
||||
} |
||||
if {[string length $existingKeyOrAlias]} { |
||||
set o_alias($newAlias) $existingKeyOrAlias |
||||
} else { |
||||
unset o_alias($newAlias) |
||||
} |
||||
} |
||||
method aliases {{key ""}} { |
||||
if {[string length $key]} { |
||||
set result [list] |
||||
foreach {n v} [array get o_alias] { |
||||
if {$v eq $key} { |
||||
lappend result $n $v |
||||
} |
||||
} |
||||
return $result |
||||
} else { |
||||
return [array get o_alias] |
||||
} |
||||
} |
||||
#if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||
method realKey {idx} { |
||||
if {[catch {set o_alias($idx)} key]} { |
||||
return $idx |
||||
} else { |
||||
return $key |
||||
} |
||||
} |
||||
method add {value key} { |
||||
if {[string is integer -strict $key]} { |
||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||
} |
||||
dict set o_data $key $value |
||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||
} |
||||
method remove {idx {endRange ""}} { |
||||
if {[string length $endRange]} { |
||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||
} |
||||
if {[string is integer -strict $idx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx+1)}]" |
||||
} |
||||
set key [lindex [dict keys $o_data] $idx] |
||||
set posn $idx |
||||
} else { |
||||
set key $idx |
||||
set posn [lsearch -exact [dict keys $o_data] $key] |
||||
if {$posn < 0} { |
||||
error "[self object] no such index: '$idx' in this collection" |
||||
} |
||||
} |
||||
dict unset o_data $key |
||||
return |
||||
} |
||||
method clear {} { |
||||
set o_data [dict create] |
||||
return |
||||
} |
||||
method reverse {} { |
||||
set dictnew [dict create] |
||||
foreach k [lreverse [dict keys $o_data]] { |
||||
dict set dictnew $k [dict get $o_data $k] |
||||
} |
||||
set o_data $dictnew |
||||
return |
||||
} |
||||
#review - cmd as list vs cmd as script? |
||||
method map {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||
} |
||||
return $seed |
||||
} |
||||
method objectmap {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||
} |
||||
return $seed |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
@ -1,663 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta description pkg capability register |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
#*** !doctools |
||||
#[manpage_begin punkshell_module_punk::cap 0 0.1.0] |
||||
#[copyright "2023 JMNoble - BSD licensed"] |
||||
#[titledesc {capability provider and handler plugin system}] |
||||
#[moddesc {punk capabilities plugin system}] |
||||
#[require punk::cap] |
||||
#[description] |
||||
#[keywords module capability plugin] |
||||
#[section Overview] |
||||
#[para]punk::cap provides management of named capabilities and the provider packages and handler packages that implement a pluggable capability. |
||||
#[para]see also [uri https://core.tcl-lang.org/tcllib/doc/trunk/embedded/md/tcllib/files/modules/pluginmgr/pluginmgr.md {tcllib pluginmgr}] for an alternative which uses safe interpreters |
||||
#[subsection Concepts] |
||||
#[para]A [term capability] may be something like providing a folder of files, or just a data dictionary, and/or an API |
||||
# |
||||
#[para][term {capability handler}] - a package/namespace which may provide validation and standardised ways of looking up provider data |
||||
# registered (or not) using register_capabilityname <capname> <capnamespace> |
||||
# |
||||
#[para][term {capability provider}] - a package which registers as providing one or more capablities. |
||||
#[para]registered using register_package <pkg> <capabilitylist> |
||||
#the capabilitylist is a list of 2-element lists where the first element is the capabilityname and the second element is a (possibly empty) dict of data relevant to that capability |
||||
#A capabilityname may appear multiple times. ie a package may register that it provides the capability with multiple datasets. |
||||
|
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require oolib |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::cap { |
||||
variable pkgcapsdeclared [dict create] |
||||
variable pkgcapsaccepted [dict create] |
||||
variable caps [dict create] |
||||
namespace eval class { |
||||
if {[info commands [namespace current]::interface_caphandler.registry] eq ""} { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::cap::class}] |
||||
#[para] class definitions |
||||
#[list_begin itemized] [comment {- punk::cap::class groupings -}] |
||||
# [item] |
||||
# [para] [emph {handler_classes}] |
||||
# [list_begin enumerated] |
||||
|
||||
oo::class create [namespace current]::interface_caphandler.registry { |
||||
#*** !doctools |
||||
#[enum] CLASS [class interface_caphandler.registry] |
||||
#[list_begin definitions] |
||||
# [para] [emph METHODS] |
||||
method pkg_register {pkg capname capdict fullcapabilitylist} { |
||||
#*** !doctools |
||||
#[call class::interface_caphandler.registry [method pkg_register] [arg pkg] [arg capname] [arg capdict] [arg fullcapabilitylist]] |
||||
#handler may override and return 0 (indicating don't register)e.g if pkg capdict data wasn't valid |
||||
#overridden handler must be able to handle multiple calls for same pkg - but it may return 1 or 0 as it wishes. |
||||
return 1 ;#default to permit |
||||
} |
||||
method pkg_unregister {pkg} { |
||||
#*** !doctools |
||||
#[call class::interface_caphandler.registry [method pkg_unregister] [arg pkg]] |
||||
return ;#unregistration return is ignored - review |
||||
} |
||||
#*** !doctools |
||||
#[list_end] |
||||
} |
||||
|
||||
oo::class create [namespace current]::interface_caphandler.sysapi { |
||||
#*** !doctools |
||||
#[enum] CLASS [class interface_caphandler.sysapi] |
||||
#[list_begin definitions] |
||||
# [para] [emph METHODS] |
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
} |
||||
|
||||
#*** !doctools |
||||
# [list_end] [comment {- end enumeration handler classes -}] |
||||
|
||||
#*** !doctools |
||||
# [item] |
||||
# [para] [emph {provider_classes}] |
||||
# [list_begin enumerated] |
||||
|
||||
#Provider classes |
||||
oo::class create [namespace current]::interface_capprovider.registration { |
||||
#*** !doctools |
||||
# [enum] CLASS [class interface_cappprovider.registration] |
||||
# [para]Your provider package will need to instantiate this object under a sub-namespace called [namespace capsystem] within your package namespace. |
||||
# [para]If your package namespace is mypackages::providerpkg then the object command would be at mypackages::providerpkg::capsystem::capprovider.registration |
||||
# [para]Example code for your provider package to evaluate within its namespace: |
||||
# [example { |
||||
#namespace eval capsystem { |
||||
# if {[info commands capprovider.registration] eq ""} { |
||||
# punk::cap::class::interface_capprovider.registration create capprovider.registration |
||||
# oo::objdefine capprovider.registration { |
||||
# method get_declarations {} { |
||||
# set decls [list] |
||||
# lappend decls [list punk.templates {relpath ../templates}] |
||||
# lappend decls [list another_capability_name {somekey blah key2 etc}] |
||||
# return $decls |
||||
# } |
||||
# } |
||||
# } |
||||
#} |
||||
#}] |
||||
#[para] The above example declares that your package can be registered as a provider for the capabilities named 'punk.templates' and 'another_capability_name' |
||||
# [list_begin definitions] |
||||
# [para] [emph METHODS] |
||||
method get_declarations {} { |
||||
#*** |
||||
#[call class::interface_capprovider.registration [method get_declarations]] |
||||
#[para] This method must be overridden by your provider using oo::objdefine cappprovider.registration as in the example above. |
||||
# There must be at least one 2-element list in the result for the provider to be registerable. |
||||
#[para]The first element of the list is the capabilityname - which can be custom to your provider/handler packages - or a well-known name that other authors may use/implement. |
||||
#[para]The second element is a dictionary of keys specific to the capability being implemented. It may be empty if the any potential capability handlers for the named capability don't require registration data. |
||||
error "interface_capprovider.registration not implemented by provider" |
||||
} |
||||
#*** !doctools |
||||
# [list_end] |
||||
} |
||||
|
||||
oo::class create [namespace current]::interface_capprovider.provider { |
||||
#*** !doctools |
||||
# [enum] CLASS [class interface_capprovider.provider] |
||||
# [para] Your provider package will need to instantiate this directly under it's own namespace with the command name of [emph {provider}] |
||||
# [example { |
||||
# namespace eval mypackages::providerpkg { |
||||
# punk::cap::class::interface_capprovider.provider create provider mypackages::providerpkg |
||||
# } |
||||
# }] |
||||
# [list_begin definitions] |
||||
# [para] [emph METHODS] |
||||
variable provider_pkg |
||||
variable registrationobj |
||||
constructor {providerpkg} { |
||||
#*** !doctools |
||||
#[call class::interface_capprovider.provider [method constructor] [arg providerpkg]] |
||||
variable provider_pkg |
||||
if {$providerpkg in [list "" "::"]} { |
||||
error "interface_capprovider.provider constructor error. Invalid provider '$providerpkg'" |
||||
} |
||||
if {![namespace exists ::$providerpkg]} { |
||||
error "interface_capprovider.provider constructor error. Invalid provider '$providerpkg' - matching namespace not found" |
||||
} |
||||
|
||||
set registrationobj ::${providerpkg}::capsystem::capprovider.registration |
||||
if {[info commands $registrationobj] eq ""} { |
||||
error "capprovider.provider constructor error. Missing capprovider.registration interface at '$obj' (command not found) interface_capprovider.regstration instantiation must precede interface_capprovider.provider" |
||||
} |
||||
|
||||
set provider_pkg [string trim $providerpkg ""] |
||||
|
||||
} |
||||
method register {{capabilityname_glob *}} { |
||||
#*** !doctools |
||||
#[comment {- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---}] |
||||
#[call class::interface_capprovider.provider [method register] [opt capabilityname_glob]] |
||||
# |
||||
#[para]This is the mechanism by which a user of your provider package will register your package as a provider of the capability named. |
||||
# |
||||
#[para]A user of your provider may elect to register all your declared capabilities: |
||||
#[example { |
||||
# package require mypackages::providerpkg |
||||
# mypackages::providerpkg::provider register * |
||||
#}] |
||||
#[para] Or a specific capability may be registered: |
||||
#[example { |
||||
# package require mypackages::providerpkg |
||||
# mypackages::providerpkg::provider register another_capability_name |
||||
#}] |
||||
# |
||||
variable provider_pkg |
||||
set all_decls [$registrationobj get_declarations] |
||||
set register_decls [lsearch -all -inline -index 0 $all_decls $capabilityname_glob] |
||||
punk::cap::register_package $provider_pkg $register_decls |
||||
} |
||||
method capabilities {} { |
||||
#*** !doctools |
||||
#[comment {- -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---}] |
||||
#[call class::interface_capprovider.provider [method capabilities]] |
||||
#[para] return a list of capabilities supported by this provider package |
||||
variable provider_pkg |
||||
variable registrationobj |
||||
|
||||
set capabilities [list] |
||||
set decls [$registrationobj get_declarations] |
||||
foreach decl $decls { |
||||
lassign $decl capname capdict |
||||
if {$capname ni $capabilities} { |
||||
lappend capabilities $capname |
||||
} |
||||
} |
||||
return $capabilities |
||||
} |
||||
#*** !doctools |
||||
# [list_end] [comment {- end class definitions -}] |
||||
} |
||||
#*** !doctools |
||||
# [list_end] [comment {- end enumeration provider_classes }] |
||||
#[list_end] [comment {- end itemized list punk::cap::class groupings -}] |
||||
} |
||||
} ;# end namespace class |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::cap}] |
||||
#[para] Main punk::cap API for client programs interested in using capability handler packages and associated (registered) provider packages |
||||
#[list_begin definitions] |
||||
|
||||
#Not all capability names have to be registered. |
||||
#A package registering as a provider using register_package can include capabilitynames in it's capabilitylist which have no associated handler. |
||||
#such unregistered capabilitynames may be used just to flag something, or have datamembers significant to callers cooperatively interested in that capname. |
||||
#we allow registering a capability with an empty handler (capnamespace) - but this means another handler could be registered later. |
||||
proc register_capabilityname {capname capnamespace} { |
||||
variable caps |
||||
variable pkgcapsdeclared |
||||
variable pkgcapsaccepted |
||||
if {$capnamespace ne ""} { |
||||
#normalize with leading :: in case caller passed in package name rather than fully qualified namespace |
||||
if {![string match ::* $capnamespace]} { |
||||
set capnamespace ::$capnamespace |
||||
} |
||||
} |
||||
#allow register of existing capname iff there is no current handler |
||||
#as handlers can be used to validate during provider registration - ideally handlers should be registered before any pkgs call register_package |
||||
#we allow loading a handler later though - but will need to validate existing data from pkgs that have already registered as providers |
||||
if {[set hdlr [capability_get_handler $capname]] ne ""} { |
||||
error "register_capabilityname cannot register capability:$capname with handler:$capnamespace. There is already a registered handler:$hdlr" |
||||
} |
||||
#assert: capnamespace may or may not be empty string, capname may or may not already exist in caps dict, caps $capname providers may have existing entries. |
||||
dict set caps $capname handler $capnamespace |
||||
if {![dict exists $caps $capname providers]} { |
||||
dict set caps $capname providers [list] |
||||
} |
||||
if {[llength [set providers [dict get $caps $capname providers]]]} { |
||||
#some provider(s) were in place before the handler was registered |
||||
if {[set capreg [punk::cap::capsystem::get_caphandler_registry $capname]] ne ""} { |
||||
foreach pkg $providers { |
||||
set fullcapabilitylist [dict get $pkgcapsdeclared $pkg] |
||||
foreach capspec $fullcapabilitylist { |
||||
lassign $capspec cn capdict |
||||
if {$cn ne $capname} { |
||||
continue |
||||
} |
||||
set do_register [$capreg pkg_register $pkg $capdict $fullcapabilitylist] |
||||
set list_accepted [dict get $pkgcapsaccepted $pkg] |
||||
if {$do_register} { |
||||
if {$capspec ni $list_accepted} { |
||||
dict lappend pkgcapsaccepted $pkg $capspec |
||||
} |
||||
} else { |
||||
set posn [lsearch $list_accepted $capspec] |
||||
if {$posn >=0} { |
||||
set list_accepted [lreplace $list_accepted $posn $posn] |
||||
dict set pkgcapsaccepted $pkg $list_accepted |
||||
} |
||||
} |
||||
} |
||||
#check if any accepted for this cap and remove from caps as necessary |
||||
set count 0 |
||||
foreach accepted_capspec [dict get $pkgcapsaccepted $pkg] { |
||||
if {[lindex $accepted_capspec 0] eq $capname} { |
||||
incr count |
||||
} |
||||
} |
||||
if {$count == 0} { |
||||
set pkgposn [lsearch $providers $pkg] |
||||
if {$pkgposn >= 0} { |
||||
set updated_providers [lreplace $providers $posn $posn] |
||||
dict set caps $capname providers $updated_providers |
||||
} |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
} |
||||
} |
||||
proc capability_exists {capname} { |
||||
#*** !doctools |
||||
# [call [fun capability_exists] [arg capname]] |
||||
# Return a boolean indicating if the named capability exists (0|1) |
||||
variable caps |
||||
return [dict exists $caps $capname] |
||||
} |
||||
proc capability_has_handler {capname} { |
||||
#*** !doctools |
||||
# [call [fun capability_has_handler] [arg capname]] |
||||
#Return a boolean indicating if the named capability has a handler package installed (0|1) |
||||
variable caps |
||||
return [expr {[dict exists $caps $capname handler] && [dict get $caps $capname handler] ne ""}] |
||||
} |
||||
proc capability_get_handler {capname} { |
||||
#*** !doctools |
||||
# [call [fun capability_get_handler] [arg capname]] |
||||
#Return the base namespace of the active handler package for the named capability. |
||||
#[para] The base namespace for a handler will always be the package name, but prefixed with :: |
||||
variable caps |
||||
if {[dict exists $caps $capname]} { |
||||
return [dict get $caps $capname handler] |
||||
} |
||||
return "" |
||||
} |
||||
proc call_handler {capname args} { |
||||
if {[set handler [capability_get_handler $capname]] eq ""} { |
||||
error "punk::cap::call_handler $capname $args - no handler registered for capability $capname" |
||||
} |
||||
set obj ${handler}::api_$capname |
||||
$obj [lindex $args 0] {*}[lrange $args 1 end] |
||||
} |
||||
proc get_providers {capname} { |
||||
variable caps |
||||
if {[dict exists $caps $capname]} { |
||||
return [dict get $caps $capname providers] |
||||
} |
||||
return [list] |
||||
} |
||||
|
||||
#register package with arbitrary capnames from capabilitylist |
||||
#The registered pkg is a module that provides some service to that capname. Possibly just data members, that the capability will use. |
||||
proc register_package {pkg capabilitylist args} { |
||||
variable pkgcapsdeclared |
||||
variable pkgcapsaccepted |
||||
variable caps |
||||
set defaults [dict create\ |
||||
-nowarnings false |
||||
] |
||||
dict for {k v} $args { |
||||
if {$k ni $defaults} { |
||||
error "Unrecognized option $k. Known options [dict keys $defaults]" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
set warnings [expr {! [dict get $opts -nowarnings]}] |
||||
|
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {[dict exists $pkgcapsaccepted $pkg]} { |
||||
set pkg_already_accepted [dict get $pkgcapsaccepted $pkg] |
||||
} else { |
||||
set pkg_already_accepted [list] |
||||
} |
||||
package require $pkg |
||||
set providerapi ::${pkg}::provider |
||||
if {[info commands $providerapi] eq ""} { |
||||
error "register_package error. pkg '$pkg' doesn't seem to be a punk::cap capability provider (no object found at $providerapi)" |
||||
} |
||||
set defined_caps [$providerapi capabilities] |
||||
#for each capability |
||||
# - ensure 1st element is a single word |
||||
# - ensure that if 2nd element (capdict) is present - it is dict shaped |
||||
foreach capspec $capabilitylist { |
||||
lassign $capspec capname capdict |
||||
|
||||
if {$warnings} { |
||||
if {$capname ni $defined_caps} { |
||||
puts stderr "WARNING: pkg '$pkg' doesn't declare support for capability '$capname'." |
||||
} |
||||
} |
||||
if {[llength $capname] !=1} { |
||||
error "register_package error. pkg: '$pkg' An entry in the capability list doesn't appear to have a single-word name. Problematic entry:'$capspec'" |
||||
} |
||||
if {[expr {[llength $capdict] %2 != 0}]} { |
||||
error "register_package error. pkg:'$pkg' The second element for capname:'$capname' doesn't appear to be a valid dict. Problematic entry: '$capspec'" |
||||
} |
||||
if {$capspec in $pkg_already_accepted} { |
||||
#review - multiple handlers? if so - will need to record which handler(s) accepted the capspec |
||||
if {$warnings} { |
||||
puts stderr "WARNING: register_package pkg $pkg already has capspec marked as accepted: $capspec" |
||||
} |
||||
continue |
||||
} |
||||
if {[dict exists $caps $capname]} { |
||||
set cap_pkgs [dict get $caps $capname providers] |
||||
} else { |
||||
dict set caps $capname [dict create handler "" providers [list]] |
||||
set cap_pkgs [list] |
||||
} |
||||
#todo - if there's a caphandler - call it's init/validation callback for the pkg |
||||
set do_register 1 ;#default assumption unless vetoed by handler |
||||
if {[set capreg [punk::cap::capsystem::get_caphandler_registry $capname]] ne ""} { |
||||
#Note that the interface_caphandler.registry instance must be able to handle multiple calls for same pkg |
||||
set do_register [$capreg pkg_register $pkg $capname $capdict $capabilitylist] |
||||
} |
||||
if {$do_register} { |
||||
if {$pkg ni $cap_pkgs} { |
||||
lappend cap_pkgs $pkg |
||||
dict set caps $capname providers $cap_pkgs |
||||
} |
||||
dict lappend pkgcapsaccepted $pkg $capspec ;#if pkg is being registered prior to handler-registration - the handler may undo this entry |
||||
} |
||||
} |
||||
#another call to register_pkg with same pkg may have been made (most likely with different capname) so we must append - but check not already present |
||||
#dict lappend pkgcapsdeclared $pkg $capabilitylist |
||||
if {[dict exists $pkgcapsdeclared $pkg]} { |
||||
set capspecs [dict get $pkgcapsdeclared $pkg] |
||||
foreach spec $capspecs { |
||||
if {$spec ni $capspecs} { |
||||
lappend capspecs $spec |
||||
} |
||||
} |
||||
dict set pkgcapsdeclared $pkg $capspecs |
||||
} else { |
||||
dict set pkgcapsdeclared $pkg $capabilitylist |
||||
} |
||||
} |
||||
|
||||
#todo! |
||||
proc unregister_package {pkg {capname *}} { |
||||
variable pkgcapsdeclared |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {[dict exists $pkgcapsdeclared $pkg]} { |
||||
#remove corresponding entries in caps |
||||
set capabilitylist [dict get $pkgcapsdeclared $pkg] |
||||
foreach c $capabilitylist { |
||||
set do_unregister 1 |
||||
lassign $c capname _capdict |
||||
set cap_info [dict get $caps $capname] |
||||
set pkglist [dict get $cap_info providers] |
||||
set posn [lsearch $pkglist $pkg] |
||||
if {$posn >= 0} { |
||||
if {[set capreg [punk::cap::capsystem::get_caphandler_registry $capname]] ne ""} { |
||||
#review |
||||
# it seems not useful to allow the callback to block this unregister action |
||||
#the pkg may have multiple datasets for each capname so callback will only be called for first dataset we encounter |
||||
#vetoing unregister would make this more complex for no particular advantage |
||||
#if per dataset deregistration required this should probably be a separate thing |
||||
$capreg pkg_unregister $pkg $capname |
||||
} |
||||
set pkglist [lreplace $pkglist $posn $posn] |
||||
dict set caps $capname providers $pkglist |
||||
} |
||||
} |
||||
#delete the main registration record |
||||
dict unset pkgcapsdeclared $pkg |
||||
} |
||||
} |
||||
|
||||
proc pkgcap {pkg} { |
||||
variable pkgcapsdeclared |
||||
variable pkgcapsaccepted |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {[dict exists $pkgcapsdeclared $pkg]} { |
||||
set accepted "" |
||||
if {[dict exists $pkgcapsaccepted $pkg]} { |
||||
set accepted [dict get $pkgcapsaccepted $pkg] |
||||
} |
||||
return [dict create declared [dict get $pkgcapsdeclared $pkg] accepted $accepted] |
||||
} else { |
||||
return |
||||
} |
||||
} |
||||
proc pkgcaps {} { |
||||
variable pkgcapsdeclared |
||||
variable pkgcapsaccepted |
||||
set result [dict create] |
||||
foreach {pkg capsdeclared} $pkgcapsdeclared { |
||||
set accepted "" |
||||
if {[dict exists $pkgcapsaccepted $pkg]} { |
||||
set accepted [dict get $pkgcapsaccepted $pkg] |
||||
} |
||||
dict set result $pkg declared $capsdeclared |
||||
dict set result $pkg accepted $accepted |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
proc capability {capname} { |
||||
variable caps |
||||
if {[dict exists $caps $capname]} { |
||||
return [dict get $caps $capname] |
||||
} |
||||
return "" |
||||
} |
||||
proc capabilities {{glob *}} { |
||||
variable caps |
||||
set capnames [lsort [dict keys $caps $glob]] |
||||
set cap_list [list] |
||||
foreach capname $capnames { |
||||
lappend cap_list [list $capname [dict get $caps $capname]] |
||||
} |
||||
return $cap_list |
||||
} |
||||
|
||||
proc capabilitynames {{glob *}} { |
||||
variable caps |
||||
return [lsort [dict keys $caps $glob]] |
||||
} |
||||
#return only those capnames which have at least one provider |
||||
proc capabilitynames_provided {{glob *}} { |
||||
variable caps |
||||
set keys [lsort [dict keys $caps $glob]] |
||||
set cap_list [list] |
||||
foreach k $keys { |
||||
if {[llength [dict get $caps $k providers]] > 0} { |
||||
lappend cap_list $k |
||||
} |
||||
} |
||||
return $cap_list |
||||
} |
||||
#*** !doctools |
||||
#[list_end] [comment {- end definitions for namespace punk::cap -}] |
||||
|
||||
namespace eval advanced { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::cap::advanced}] |
||||
#[para] punk::cap::advanced API. Functions here are generally not the preferred way to interact with punk::cap. |
||||
#[para] In some cases they may allow interaction in less safe ways or may allow use of features that are unavailable in the base namespace. |
||||
#[para] Some functions are here because they are only marginally or rarely useful, and they are here to keep the base API simple. |
||||
#[list_begin definitions] |
||||
|
||||
proc promote_provider {pkg} { |
||||
#*** !doctools |
||||
# [call advanced::[fun promote_provider] [arg pkg]] |
||||
#[para]Move the named provider package to the preferred end of the list (tail). |
||||
#[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. |
||||
#[para] |
||||
#[para] promote/demote doesn't always make a lot of sense .. should preferably be configurable per capapbility for multicap provider pkgs |
||||
#[para]The idea is to provide a crude way to preference/depreference packages independently of order the packages were loaded |
||||
#e.g a caller or cap-handler can ascribe some meaning to the order of the 'providers' key returned from punk::cap::capabilities <capname> |
||||
#[para]The order of providers will be the order the packages were loaded & registered |
||||
#[para]the naming: "promote vs demote" operates on a latest-package-in-list has higher preference assumption (matching last pkg loaded) |
||||
#[para]Each capability handler could and should implement specific preferencing methods within its own API if finer control needed. |
||||
#In some cases the preference/loading order may be inapplicable/irrelevant to a particular capability anyway. |
||||
#[para]As this is just a basic mechanism, which can't support independent per-cap preferencing for multi-cap packages - |
||||
# it only allows putting the pkgs to the head or tail of the lists. |
||||
#[para]Whether particular caps or users of caps do anything with this ordering is dependent on the cap-handler and/or calling code. |
||||
variable pkgcapsdeclared |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {![dict exists $pkgcapsdeclared $pkg]} { |
||||
error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" |
||||
} |
||||
if {[dict size $pkgcapsdeclared] > 1} { |
||||
set pkginfo [dict get $pkgcapsdeclared $pkg] |
||||
#remove and re-add at end of dict |
||||
dict unset pkgcapsdeclared $pkg |
||||
dict set pkgcapsdeclared $pkg $pkginfo |
||||
dict for {cap cap_info} $caps { |
||||
set cap_pkgs [dict get $cap_info providers] |
||||
if {$pkg in $cap_pkgs} { |
||||
set posn [lsearch $cap_pkgs $pkg] |
||||
if {$posn >=0} { |
||||
#rewrite package list with pkg at tail of list for this capability |
||||
set cap_pkgs [lreplace $cap_pkgs $posn $posn] |
||||
lappend cap_pkgs $pkg |
||||
dict set caps $cap providers $cap_pkgs |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
proc demote_provider {pkg} { |
||||
#*** !doctools |
||||
# [call advanced::[fun demote_provider] [arg pkg]] |
||||
#[para]Move the named provider package to the preferred end of the list (tail). |
||||
#[para]The active handler may or may not utilise this for preferencing. See documentation for the specific handler package to confirm. |
||||
variable pkgcapsdeclared |
||||
variable caps |
||||
if {[string match ::* $pkg]} { |
||||
set pkg [string range $pkg 2 end] |
||||
} |
||||
if {![dict exists $pkgcapsdeclared $pkg]} { |
||||
error "punk::cap::promote_package error pkg'$pkg' not registered. Use register_package \$pkg first" |
||||
} |
||||
if {[dict size $pkgcapsdeclared] > 1} { |
||||
set pkginfo [dict get $pkgcapsdeclared $pkg] |
||||
#remove and re-add at start of dict |
||||
dict unset pkgcapsdeclared $pkg |
||||
dict set pkgcapsdeclared $pkg $pkginfo |
||||
set pkgcapsdeclared [dict merge [dict create $pkg $pkginfo] $pkgcapsdeclared] |
||||
dict for {cap cap_info} $caps { |
||||
set cap_pkgs [dict get $cap_info providers] |
||||
if {$pkg in $cap_pkgs} { |
||||
set posn [lsearch $cap_pkgs $pkg] |
||||
if {$posn >=0} { |
||||
#rewrite package list with pkg at head of list for this capability |
||||
set cap_pkgs [lreplace $cap_pkgs $posn $posn] |
||||
set cap_pkgs [list $pkg {*}$cap_pkgs] |
||||
dict set caps $cap providers $cap_pkgs |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
} |
||||
|
||||
|
||||
#*** !doctools |
||||
#[section Internal] |
||||
|
||||
namespace eval capsystem { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::cap::capsystem}] |
||||
#[para] Internal functions used to communicate between punk::cap and capability handlers |
||||
#[list_begin definitions] |
||||
proc get_caphandler_registry {capname} { |
||||
set ns [::punk::cap::capability_get_handler $capname]::capsystem |
||||
if {[namespace exists ${ns}]} { |
||||
if {[info command ${ns}::caphandler.registry] ne ""} { |
||||
if {[info object isa object ${ns}::caphandler.registry]} { |
||||
return ${ns}::caphandler.registry |
||||
} |
||||
} |
||||
} |
||||
return "" |
||||
} |
||||
#*** !doctools |
||||
#[list_end] |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap [namespace eval punk::cap { |
||||
variable version |
||||
variable pkg punk::cap |
||||
set version 0.1.0 |
||||
variable README.md [string map [list %pkg% $pkg %ver% $version] { |
||||
# punk capabilities system |
||||
## pkg: %pkg% version: %ver% |
||||
|
||||
punk::cap base namespace |
||||
}] |
||||
return $version |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
@ -1,52 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap::handlers::caphandler 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::cap::handlers::caphandler { |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap::handlers::caphandler [namespace eval punk::cap::handlers::caphandler { |
||||
variable pkg punk::cap::handlers::caphandler |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -1,52 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap::handlers::scriptlibs 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::cap::handlers::scriptlibs { |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap::handlers::scriptlibs [namespace eval punk::cap::handlers::scriptlibs { |
||||
variable pkg punk::cap::handlers::scriptlibs |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -1,145 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap::handlers::templates 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#register using: |
||||
# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates |
||||
|
||||
#By convention and for consistency, we don't register here during package loading - but require the calling app to do it. |
||||
# (even if it tends to be done immediately after package require anyway) |
||||
# registering capability handlers can involve validating existing provider data and is best done explicitly as required. |
||||
# It is also possible for a capability handler to be registered to handle more than one capabilityname |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::cap::handlers::templates { |
||||
namespace eval capsystem { |
||||
#interfaces for punk::cap to call into |
||||
if {[info commands caphandler.registry] eq ""} { |
||||
punk::cap::class::interface_caphandler.registry create caphandler.registry |
||||
oo::objdefine caphandler.registry { |
||||
method pkg_register {pkg capname capdict caplist} { |
||||
#caplist may not be complete set - which somewhat reduces its utility here regarding any decisions based on the context of this capname/capdict (review - remove this arg?) |
||||
|
||||
# -- --- --- --- --- --- --- ---- --- |
||||
# validation of capdict |
||||
# -- --- --- --- --- --- --- ---- --- |
||||
if {![dict exists $capdict relpath]} { |
||||
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing 'relpath' key" |
||||
return 0 |
||||
} |
||||
set provide_statement [package ifneeded $pkg [package require $pkg]] |
||||
set tmfile [lindex $provide_statement end] |
||||
if {![file exists $tmfile]} { |
||||
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" |
||||
return 0 |
||||
} |
||||
set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder |
||||
if {![file isdirectory $tpath]} { |
||||
puts stderr "punk::cap::handlers::templates::capsystem pkg_register WARNING - unable to validate relpath location [dict get $capdict relpath] ($tpath) for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" |
||||
return 0 |
||||
} |
||||
|
||||
|
||||
# -- --- --- --- --- --- --- ---- --- |
||||
# update package internal data |
||||
# -- --- --- --- --- --- --- ---- --- |
||||
if {$capname ni $::punk::cap::handlers::templates::handled_caps} { |
||||
lappend ::punk::cap::handlers::templates::handled_caps $capname |
||||
} |
||||
set cname [string map [list . _] $capname] |
||||
upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders |
||||
dict lappend pfolders $pkg $tpath |
||||
|
||||
|
||||
# -- --- --- --- --- --- --- ---- --- |
||||
# instantiation of api at punk::cap::handlers::templates::api_$capname |
||||
# -- --- --- --- --- --- --- ---- --- |
||||
if {[info commands ::punk::cap::handlers::templates::$capname] eq ""} { |
||||
punk::cap::handlers::templates::class::api create ::punk::cap::handlers::templates::api_$capname $capname |
||||
} |
||||
|
||||
return 1 |
||||
} |
||||
method pkg_unregister {pkg} { |
||||
upvar ::punk::cap::handlers::templates::handled_caps hcaps |
||||
foreach capname $hcaps { |
||||
set cname [string map [list . _] $capname] |
||||
upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders |
||||
dict unset pfolders $pkg |
||||
#destroy api objects? |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
variable handled_caps [list] |
||||
#variable pkg_folders [dict create] |
||||
|
||||
# -- --- --- --- --- --- --- |
||||
#handler api for clients of this capability - called via punk::cap::call_handler <capname> <method> ?args? |
||||
# -- --- --- --- --- --- --- |
||||
namespace export * |
||||
namespace eval class { |
||||
oo::class create api { |
||||
#return a dict keyed on folder with source pkg as value |
||||
constructor {capname} { |
||||
variable capabilityname |
||||
variable cname |
||||
set cname [string map [list . _] $capname] |
||||
set capabilityname $capname |
||||
} |
||||
method folders {} { |
||||
variable capabilityname |
||||
variable cname |
||||
upvar punk::cap::handlers::templates::pkg_folders_$cname pkg_folders |
||||
package require punk::cap |
||||
set capinfo [punk::cap::capability $capabilityname] |
||||
# e.g {punk.templates {handler punk::mix::templates providers ::somepkg}} |
||||
|
||||
#use the order of pkgs as registered with punk::cap - may have been modified with punk::cap::promote_package/demote_package |
||||
set pkgs [dict get $capinfo providers] |
||||
set folderdict [dict create] |
||||
foreach pkg $pkgs { |
||||
foreach pfolder [dict get $pkg_folders $pkg] { |
||||
dict set folderdict $pfolder [list source $pkg sourcetype package] |
||||
} |
||||
} |
||||
return $folderdict |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap::handlers::templates [namespace eval punk::cap::handlers::templates { |
||||
variable pkg punk::cap::handlers::templates |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -1,71 +0,0 @@
|
||||
|
||||
# -*- tcl -* |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::docgen 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
package require punk::repo |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::docgen { |
||||
proc get_doctools_comments {fname} { |
||||
#does no validation of doctools commands |
||||
#existence of string match #\**!doctools is taken as evidence enough that the file has inline doctools - review |
||||
if {![file exists $fname]} { |
||||
error "get_doctools_comments file '$fname' not found" |
||||
} |
||||
set fd [open $fname r] |
||||
set data [read $fd] |
||||
close $fd |
||||
if {![string match "*#\**!doctools*" $data]} { |
||||
return |
||||
} |
||||
set data [string map [list \r\n \n] $data] |
||||
set in_doctools 0 |
||||
set doctools "" |
||||
foreach ln [split $data \n] { |
||||
set ln [string trim $ln] |
||||
if {$in_doctools && [string index $ln 0] != "#"} { |
||||
set in_doctools 0 |
||||
} elseif {[string range $ln 0 1] == "#*"} { |
||||
#todo - process doctools ordering hints in tail of line |
||||
set in_doctools 1 |
||||
} elseif {$in_doctools} { |
||||
append doctools [string range $ln 1 end] \n |
||||
} |
||||
} |
||||
return $doctools |
||||
} |
||||
#todo - proc autogen_doctools_comments {fname} {} |
||||
# - will probably need to use something like parsetcl - as we won't be able to reliably source in an interp without side-effects and use info body etc. |
||||
# - mechanism will be to autodocument namespaces, procs, methods where no #*** doctools indication present - but use existing doctools comments for that particular item if it is present. |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::docgen [namespace eval punk::docgen { |
||||
variable pkg punk::docgen |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
File diff suppressed because it is too large
Load Diff
@ -1,21 +0,0 @@
|
||||
|
||||
package require punk::cap |
||||
|
||||
package require punk::cap::handlers::templates ;#handler for templates cap |
||||
punk::cap::register_capabilityname punk.templates ::punk::cap::handlers::templates |
||||
|
||||
package require punk::mix::templates ;#registers as provider pkg for 'punk.templates' capability with punk::cap |
||||
punk::mix::templates::provider register * |
||||
|
||||
package require punk::mix::base |
||||
package require punk::mix::cli |
||||
|
||||
namespace eval punk::mix { |
||||
|
||||
} |
||||
|
||||
package provide punk::mix [namespace eval punk::mix { |
||||
variable version |
||||
set version 0.2 |
||||
|
||||
}] |
@ -1,910 +0,0 @@
|
||||
package provide punk::mix::base [namespace eval punk::mix::base { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
package require punk::path |
||||
|
||||
#base internal plumbing functions |
||||
namespace eval punk::mix::base { |
||||
proc set_alias {cmdname args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
|
||||
uplevel #0 [list interp alias {} $cmdname {} punk::mix::base::_cli -extension $extension] |
||||
} |
||||
proc _cli {args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
#puts stderr "punk::mix::base extension: [string trimleft $extension :]" |
||||
if {![string length $extension]} { |
||||
#if still no extension - must have been called dirctly as punk::mix::base::_cli |
||||
if {![llength $args]} { |
||||
set args "help" |
||||
} |
||||
set extension [namespace current] |
||||
} |
||||
if {![llength $args]} { |
||||
if {[info exists ${extension}::default_command]} { |
||||
tailcall $extension [set ${extension}::default_command] |
||||
} |
||||
tailcall $extension |
||||
} else { |
||||
tailcall $extension {*}$args |
||||
} |
||||
} |
||||
proc _unknown {ns args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
|
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
#puts stderr "arglen:[llength $args]" |
||||
#puts stdout "_unknown '$ns' '$args'" |
||||
|
||||
set d_commands [get_commands -extension $extension] |
||||
set all_commands [list {*}[dict get $d_commands main] {*}[dict get $d_commands base]] |
||||
error "Unknown subcommand \"[lindex $args 0]\": must be one of: $all_commands" "punk::mix::base _unknown $ns $args" [list unknown_ensemble_subcommand ensemble punk::mix::base] |
||||
} |
||||
proc _redirected {from_ns subcommand args} { |
||||
#puts stderr "_redirected from_ns: $from_ns subcommand:$subcommand args:$args" |
||||
set pname [namespace current]::$subcommand |
||||
if {$pname in [info procs $pname]} { |
||||
set argnames [info args $pname] |
||||
#puts stderr "_redirected $subcommand argnames: $argnames" |
||||
if {[lindex $argnames end] eq "args"} { |
||||
set pos_argnames [lrange $argnames 0 end-1] |
||||
} else { |
||||
set pos_argnames $argnames |
||||
} |
||||
set argvals [list] |
||||
set numargs [llength $pos_argnames] |
||||
if {$numargs > 0} { |
||||
set argvals [lrange $args 0 $numargs-1] |
||||
set args [lrange $args $numargs end] |
||||
} |
||||
if {[llength $argvals] < $numargs} { |
||||
error "wrong # args: $from_ns $subcommand requires args: $pos_argnames" |
||||
} |
||||
tailcall [namespace current] $subcommand {*}$argvals {*}$args -extension $from_ns |
||||
} else { |
||||
tailcall [namespace current] $subcommand {*}$args -extension $from_ns |
||||
} |
||||
} |
||||
proc _split_args {arglist} { |
||||
#don't assume arglist is fully paired. |
||||
set posn [lsearch $arglist -extension] |
||||
set opts [list] |
||||
if {$posn >= 0} { |
||||
if {$posn+2 <= [llength $arglist]} { |
||||
set opts [list -extension [lindex $arglist $posn+1]] |
||||
set argsremaining [lreplace $arglist $posn $posn+1] |
||||
} else { |
||||
#no value supplied to -extension |
||||
error "punk::mix::base::_split_args - no value found for option '-extension'. Supply a value or omit the option." |
||||
} |
||||
} else { |
||||
set argsremaining $arglist |
||||
} |
||||
|
||||
return [list opts $opts args $argsremaining] |
||||
} |
||||
} |
||||
|
||||
|
||||
#base API (potentially overridden functions - may also be called from overriding namespace) |
||||
#commands should either handle or silently ignore -extension <namespace/ensemble> |
||||
namespace eval punk::mix::base { |
||||
namespace ensemble create |
||||
namespace export help dostuff get_commands set_alias |
||||
namespace ensemble configure [namespace current] -unknown punk::mix::base::_unknown |
||||
proc get_commands {args} { |
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
|
||||
set maincommands [list] |
||||
#extension may still be blank e.g if punk::mix::base::get_commands called directly |
||||
if {[string length $extension]} { |
||||
set nsmain $extension |
||||
#puts stdout "get_commands nsmain: $nsmain" |
||||
set parentpatterns [namespace eval $nsmain [list namespace export]] |
||||
set nscommands [list] |
||||
foreach p $parentpatterns { |
||||
lappend nscommands {*}[info commands ${nsmain}::$p] |
||||
} |
||||
foreach c $nscommands { |
||||
set cmd [namespace tail $c] |
||||
lappend maincommands $cmd |
||||
} |
||||
set maincommands [lsort $maincommands] |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
set nsbase [namespace current] |
||||
set basepatterns [namespace export] |
||||
#puts stdout "basepatterns:$basepatterns" |
||||
set nscommands [list] |
||||
foreach p $basepatterns { |
||||
lappend nscommands {*}[info commands ${nsbase}::$p] |
||||
} |
||||
|
||||
set basecommands [list] |
||||
foreach c $nscommands { |
||||
set cmd [namespace tail $c] |
||||
if {$cmd ni $maincommands} { |
||||
lappend basecommands $cmd |
||||
} |
||||
} |
||||
set basecommands [lsort $basecommands] |
||||
|
||||
|
||||
return [list main $maincommands base $basecommands] |
||||
} |
||||
proc help {args} { |
||||
#' **%ensemblecommand% help** *args* |
||||
#' |
||||
#' Help for ensemble commands in the command line interface |
||||
#' |
||||
#' |
||||
#' Arguments: |
||||
#' |
||||
#' * args - first word of args is the helptopic requested - usually a command name |
||||
#' - calling help with no arguments will list available commands |
||||
#' |
||||
#' Returns: help text (text) |
||||
#' |
||||
#' Examples: |
||||
#' |
||||
#' ``` |
||||
#' %ensemblecommand% help <commandname> |
||||
#' ``` |
||||
#' |
||||
#' |
||||
|
||||
|
||||
#extension.= @@opts/@?@-extension,args@@args=>. [_split_args $args] {| |
||||
# >} inspect -label a {| |
||||
# >} .=e>end,data>end pipeswitch { |
||||
# pipecase ,0/1/#= $switchargs {| |
||||
# e/0 |
||||
# >} .=>. {set e} |
||||
# pipecase /1,1/1/#= $switchargs |
||||
#} |@@ok/result> <e/0| [namespace qualifiers [lindex [info level -1] 0]] |
||||
|
||||
|
||||
#--------- |
||||
#extension@@opts/@?@-extension,args@@args= [_split_args $args] ;#dependency on punk pipeline/patternmatching system |
||||
lassign [_split_args $args] _opts opts _args args |
||||
if {[dict exists $opts -extension]} { |
||||
set extension [dict get $opts -extension] |
||||
} else { |
||||
set extension "" |
||||
} |
||||
#--------- |
||||
|
||||
|
||||
|
||||
if {![string length $extension]} { |
||||
set extension [namespace qualifiers [lindex [info level -1] 0]] |
||||
} |
||||
#puts stderr "-1:[info level -1]" |
||||
|
||||
set command_info [punk::mix::base::get_commands -extension $extension] |
||||
set subhelp1 [lindex $args 0] |
||||
if {[string length $subhelp1]} { |
||||
if {[regexp {[*?]} $subhelp1]} { |
||||
set helpstr "" |
||||
append helpstr "matched commands:\n" |
||||
dict for {source cmdlist} $command_info { |
||||
set matches [lsearch -all -inline -glob $cmdlist $subhelp1] |
||||
if {[llength $matches]} { |
||||
append helpstr \n " $source" |
||||
foreach cmd $matches { |
||||
append helpstr \n " - $cmd" |
||||
} |
||||
} |
||||
} |
||||
return $helpstr |
||||
} else { |
||||
dict for {source cmdlist} $command_info { |
||||
if {$subhelp1 in $cmdlist} { |
||||
if {$source eq "base"} { |
||||
set ns [namespace current] |
||||
} else { |
||||
set ns $extension |
||||
} |
||||
set procname ${ns}::$subhelp1 |
||||
if {$procname in [info procs $procname]} { |
||||
return "proc: $subhelp1 arguments: [info args $procname]" |
||||
} else { |
||||
set a [interp alias {} ${ns}::$subhelp1] |
||||
if {[string length $a]} { |
||||
return "alias: $subhelp1 target: $a" |
||||
} else { |
||||
return "command: $subhelp1 (No info available)" |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
return "No info found" |
||||
} |
||||
|
||||
} |
||||
#result for just 'pmix help' |
||||
set helpstr "" |
||||
append helpstr "commands:\n" |
||||
|
||||
foreach {source cmdlist} $command_info { |
||||
append helpstr \n " $source" |
||||
foreach cmd $cmdlist { |
||||
append helpstr \n " - $cmd" |
||||
} |
||||
} |
||||
return $helpstr |
||||
} |
||||
#proc dostuff {args} { |
||||
# extension@@opts/@?@-extension,args@@args= [_split_args $args] |
||||
# puts stdout "base doingstuff-with-args:'$args'-in-namespace:'[namespace current]'" |
||||
#} |
||||
namespace eval lib { |
||||
variable sha3_implementation "" ;#set by cksum_algorithms (which is called by cksum_path) It looks for fossil or sqlite3. Todo - add proper Tcl implementation. |
||||
namespace export * |
||||
|
||||
#----------------------------------------------------- |
||||
#literate-programming style naming for some path tests |
||||
#Note the naming of the operator portion of a_op_b is consistent in that it is the higher side of the filesystem tree first. |
||||
#hence aboveorat vs atorbelow |
||||
#These names also sort in the logical order of higher to lower in the filesystem (when considering the root as 'higher' in the filesystem) |
||||
proc path_a_above_b {path_a path_b} { |
||||
#stripPath prefix path |
||||
return [expr {[fileutil::stripPath $path_a $path_b] ni [list . $path_b]}] |
||||
} |
||||
proc path_a_aboveorat_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_a $path_b] ne $path_b}] |
||||
} |
||||
proc path_a_at_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_a $path_b] eq "." }] |
||||
} |
||||
proc path_a_atorbelow_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_b $path_a] ne $path_a}] |
||||
} |
||||
proc path_a_below_b {path_a path_b} { |
||||
return [expr {[fileutil::stripPath $path_b $path_a] ni [list . $path_a]}] |
||||
} |
||||
proc path_a_inlinewith_b {path_a path_b} { |
||||
return [expr {[path_a_aboveorat_b $path_a $path_b] || [path_a_below_b $path_a $path_b]}] |
||||
} |
||||
#----------------------------------------------------- |
||||
|
||||
|
||||
|
||||
#find src/something folders which are not certain known folders with other purposes, (such as: bootsupport .vfs folders or vendor folders etc) and contain .tm file(s) |
||||
proc find_source_module_paths {{path {}}} { |
||||
if {![string length [set candidate [punk::repo::find_candidate $path]]]} { |
||||
error "find_source_module_paths cannot determine a suitable project root at or above path '$path' - path supplied should be within a project" |
||||
} |
||||
#we can return module paths even if the project isn't yet under revision control |
||||
set src_subs [glob -nocomplain -dir [file join $candidate src] -type d -tail *] |
||||
set antipatterns [list *.vfs vendor* lib _build doc embedded runtime bootsupport] |
||||
set tm_folders [list] |
||||
foreach sub $src_subs { |
||||
set is_ok 1 |
||||
foreach anti $antipatterns { |
||||
if {[string match $anti $sub]} { |
||||
set is_ok 0 |
||||
break |
||||
} |
||||
} |
||||
if {!$is_ok} { |
||||
continue |
||||
} |
||||
set testfolder [file join $candidate src $sub] |
||||
set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm] |
||||
if {[llength $tmfiles]} { |
||||
lappend tm_folders $testfolder |
||||
} |
||||
} |
||||
return $tm_folders |
||||
} |
||||
|
||||
proc mix_templates_dir {} { |
||||
puts stderr "mix_templates_dir WARNING: deprecated - use get_template_basefolders instead" |
||||
set provide_statement [package ifneeded punk::mix [package require punk::mix]] |
||||
set tmdir [file dirname [lindex $provide_statement end]] |
||||
set tpldir $tmdir/mix/templates |
||||
if {![file exists $tpldir]} { |
||||
error "punk::mix::lib::mix_templates_dir unable to locate mix templates folder at '$tpldir'" |
||||
} |
||||
return $tpldir |
||||
} |
||||
|
||||
#get_template_basefolders |
||||
# scriptpath - file or folder |
||||
# It represents the base point from which to search for mixtemplates folders either directly related to the scriptpath (../) or in the containing project if any |
||||
# The cwd will also be searched for project root - but with lower precedence in the resultset (later in list) |
||||
proc get_template_basefolders {{scriptpath ""}} { |
||||
#1 lowest precedence - templates from packages (ordered by order in which packages registered with punk::cap) |
||||
set folderdict [dict create] |
||||
|
||||
package require punk::cap |
||||
if {[punk::cap::capability_has_handler punk.templates]} { |
||||
set template_folder_dict [punk::cap::call_handler punk.templates folders] |
||||
dict for {dir folderinfo} $template_folder_dict { |
||||
dict set folderdict $dir $folderinfo |
||||
} |
||||
} |
||||
|
||||
#2 middle precedence - mixtemplates folder relative to cwd |
||||
set searchbase [pwd] |
||||
set fld [file join $searchbase mixtemplates] |
||||
if {[file isdirectory $fld]} { |
||||
if {![dict exists $folderdict $fld]} { |
||||
dict set folderdict $fld [list source $searchbase sourcetype cwd] |
||||
} |
||||
} |
||||
set pathinfo [punk::repo::find_repos $searchbase] |
||||
set pwd_projectroot [dict get $pathinfo closest] |
||||
if {$pwd_projectroot ne ""} { |
||||
set fld [file join $pwd_projectroot src/mixtemplates] |
||||
if {![dict exists $folderdict $fld]} { |
||||
dict set folderdict $fld [list source $pwd_projectroot sourcetype project] |
||||
} |
||||
} |
||||
|
||||
#3 highest precedence - mixtemplates relative to scriptpath argument |
||||
if {$scriptpath ne ""} { |
||||
if {[file type $scriptpath] eq "file"} { |
||||
set searchbase [file dirname $scriptpath] |
||||
} else { |
||||
set searchbase $scriptpath |
||||
} |
||||
if {[file isdirectory [file join $searchbase mixtemplates]]} { |
||||
dict set folderdict [file join $searchbase mixtemplates] [list source $searchbase sourcetype pathsearch] |
||||
} |
||||
set pathinfo [punk::repo::find_repos $searchbase] |
||||
set scriptpath_projectroot [dict get $pathinfo closest] |
||||
if {$scriptpath_projectroot ne ""} { |
||||
set fld [file join $scriptpath_projectroot src/mixtemplates] |
||||
if {[file isdirectory $fld]} { |
||||
dict set folderdict $fld [list source $scriptpath_projectroot sourcetype project] |
||||
} |
||||
} |
||||
} |
||||
#don't sort - order in which encountered defines the precedence - with later overriding earlier |
||||
return $folderdict |
||||
} |
||||
|
||||
proc module_subpath {modulename} { |
||||
set modulename [string trim $modulename :] |
||||
set nsq [namespace qualifiers $modulename] |
||||
return [string map [list :: /] $nsq] |
||||
} |
||||
|
||||
proc get_build_workdir {path} { |
||||
set repo_info [punk::repo::find_repos $path] |
||||
set base [lindex [dict get $repo_info project] 0] |
||||
if {![string length $base]} { |
||||
error "get_build_workdir unable to determine project base for path '$path'" |
||||
} |
||||
if {![file exists $base/src] || ![file writable $base/src]} { |
||||
error "get_build_workdir unable to access $base/src" |
||||
} |
||||
file mkdir $base/src/_build |
||||
return $base/src/_build |
||||
} |
||||
|
||||
|
||||
|
||||
#todo - move cksum stuff to punkcheck - more logical home |
||||
proc cksum_path_content {path args} { |
||||
dict set args -cksum_content 1 |
||||
dict set args -cksum_meta 0 |
||||
tailcall cksum_path $path {*}$args |
||||
} |
||||
|
||||
#not just used by cksum_path. used by caller (e.g fill_relativecksums_from_base_and_relativepathdict via cksum_filter_opts) to determine what opt names passed through |
||||
proc cksum_default_opts {} { |
||||
return [dict create -cksum_content 1 -cksum_meta auto -cksum_acls 0 -cksum_usetar auto -cksum_algorithm sha1] |
||||
} |
||||
|
||||
#crc::cksum is extremely slow in tcllib as at 2023 e.g 20x slower (no c implementation?) |
||||
#sha1 is performant - and this is not being used in a cryptographic or adversarial context - so performance and practical unlikelihood of accidental collisions should be the main consideration. |
||||
#adler32 is fastest for some larger files of a few MB but slower on small files (possibly due to Tcl-based file load?) |
||||
#sha1 as at 2023 seems a good default |
||||
proc cksum_algorithms {} { |
||||
variable sha3_implementation |
||||
#sha2 is an alias for sha256 |
||||
#2023 - no sha3 available in tcllib - we can exec fossil for now - which will be very slow |
||||
set algs [list md5 sha1 sha2 sha256 cksum adler32] |
||||
set sha3_algs [list sha3 sha3-224 sha3-256 sha3-384 sha3-512] |
||||
if {[auto_execok sqlite3] ne ""} { |
||||
lappend algs {*}$sha3_algs |
||||
set sha3_implementation sqlite3_sha3 |
||||
} else { |
||||
if {[auto_execok fossil] ne ""} { |
||||
lappend algs {*}$sha3_algs |
||||
set sha3_implementation fossil_sha3 |
||||
} |
||||
} |
||||
return $algs |
||||
} |
||||
|
||||
proc sqlite3_sha3 {bits filename} { |
||||
return [exec sqlite3 :memory: "select lower(hex(sha3(readfile('$filename'),$bits)))"] |
||||
} |
||||
proc fossil_sha3 {bits filename} { |
||||
return [lindex [exec fossil sha3sum -$bits $filename] 0] |
||||
} |
||||
|
||||
#adler32 via file-slurp |
||||
proc cksum_adler32_file {filename} { |
||||
package require zlib; #should be builtin anyway |
||||
set data [punk::mix::util::fcat -translation binary $filename] |
||||
#set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names |
||||
zlib adler32 $data |
||||
} |
||||
|
||||
|
||||
#required to be able to accept relative paths |
||||
#for full cksum - using tar could reduce number of hashes to be made.. |
||||
#but as it stores metadata such as permission - we don't know if/how the archive will vary based on platform/filesystem |
||||
#-noperms only available on extraction - so that doesn't help |
||||
#Needs to operate on non-existant paths and return empty string in cksum field |
||||
proc cksum_path {path args} { |
||||
variable sha3_implementation |
||||
if {$path eq {}} { set path [pwd] } |
||||
if {[file pathtype $path] eq "relative"} { |
||||
set path [file normalize $path] |
||||
} |
||||
set base [file dirname $path] |
||||
set startdir [pwd] |
||||
|
||||
set defaults [cksum_default_opts] |
||||
set known_opts [dict keys $defaults] |
||||
foreach {k v} $args { |
||||
if {$k ni $known_opts} { |
||||
error "cksum_path unknown option '$k' known_options: $known_opts" |
||||
} |
||||
} |
||||
|
||||
set opts [dict merge $defaults $args] |
||||
set opts_actual $opts ;#default - auto updated to 0 or 1 later |
||||
|
||||
#if {![file exists $path]} { |
||||
# return [list cksum "" opts $opts] |
||||
#} |
||||
|
||||
if {[catch {file type $path} ftype]} { |
||||
return [list cksum "<PATHNOTFOUND>" opts $opts] |
||||
} |
||||
if {$ftype ni [list file directory]} { |
||||
#review - links? |
||||
error "cksum_path error file type '$ftype' not supported" |
||||
} |
||||
|
||||
|
||||
set opt_cksum_algorithm [dict get $opts -cksum_algorithm] |
||||
if {$opt_cksum_algorithm ni [cksum_algorithms]} { |
||||
return [list error unsupported_cksum_algorithm cksum "<ERR>" opts $opts] |
||||
} |
||||
set opt_cksum_acls [dict get $opts -cksum_acls] |
||||
if {$opt_cksum_acls} { |
||||
puts stderr "cksum_path is not yet able to cksum ACLs" |
||||
return |
||||
} |
||||
|
||||
set opt_cksum_meta [dict get $opts -cksum_meta] |
||||
set opt_use_tar [dict get $opts -cksum_usetar] |
||||
if {$ftype eq "file"} { |
||||
if {$opt_use_tar eq "auto"} { |
||||
if {$opt_cksum_meta eq "1"} { |
||||
set opt_use_tar 1 |
||||
} else { |
||||
#prefer no tar if meta not required - faster/simpler |
||||
#meta == auto or 0 |
||||
set opt_cksum_meta 0 |
||||
set opt_use_tar 0 |
||||
} |
||||
} elseif {$opt_use_tar eq "0"} { |
||||
if {$opt_cksum_meta eq "1"} { |
||||
puts stderr "cksum_path doesn't yet support a non-tar cksum with metadata for a file" |
||||
return [list error unsupported_meta_without_tar cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#meta == auto or 0 |
||||
set opt_cksum_meta 0 |
||||
} |
||||
} else { |
||||
#tar == 1 |
||||
if {$opt_cksum_meta eq "0"} { |
||||
puts stderr "cksum_path doesn't yet support a tar cksum without metadata for a file" |
||||
return [list error unsupported_tar_without_meta cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#meta == auto or 1 |
||||
set opt_cksum_meta 1 |
||||
} |
||||
} |
||||
} elseif {$ftype eq "directory"} { |
||||
if {$opt_use_tar eq "auto"} { |
||||
if {$opt_cksum_meta in [list "auto" "1"]} { |
||||
set opt_use_tar 1 |
||||
set opt_cksum_meta 1 |
||||
} else { |
||||
puts stderr "cksum_path doesn't yet support a content-only cksum of a folder structure. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto" |
||||
return [list error unsupported_directory_cksum_without_meta cksum "<ERR>" opts $opts] |
||||
} |
||||
} elseif {$opt_use_tar eq "0"} { |
||||
puts stderr "cksum_path doesn't yet support a cksum of a folder structure without tar. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" |
||||
return [list error unsupported_directory_cksum_without_tar cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#tar 1 |
||||
if {$opt_cksum_meta eq "0"} { |
||||
puts stderr "cksum_path doesn't yet support a tar checksum of a folder structure without metadat. Currently only files supported without metadata. For folders use cksum_path -cksum_meta 1 or auto with -cksum_usetar 1 or auto" |
||||
return [list error unsupported_without_meta cksum "<ERR>" opts $opts] |
||||
} else { |
||||
#meta == auto or 1 |
||||
set opt_cksum_meta 1 |
||||
} |
||||
} |
||||
} |
||||
|
||||
dict set opts_actual -cksum_meta $opt_cksum_meta |
||||
dict set opts_actual -cksum_usetar $opt_use_tar |
||||
|
||||
|
||||
if {$opt_use_tar} { |
||||
package require tar ;#from tcllib |
||||
} |
||||
|
||||
if {$path eq $base} { |
||||
#attempting to cksum at root/volume level of a filesystem.. extra work |
||||
#This needs fixing for general use.. not necessarily just for project repos |
||||
puts stderr "cksum_path doesn't yet support cksum of entire volume. (todo)" |
||||
return [list error unsupported_path opts $opts] |
||||
} |
||||
|
||||
if {$opt_cksum_algorithm eq "sha1"} { |
||||
package require sha1 |
||||
set cksum_command [list sha1::sha1 -hex -file] |
||||
} elseif {$opt_cksum_algorithm in [list "sha2" "sha256"]} { |
||||
package require sha256 |
||||
set cksum_command [list sha2::sha256 -hex -file] |
||||
} elseif {$opt_cksum_algorithm eq "md5"} { |
||||
package require md5 |
||||
set cksum_command [list md5::md5 -hex -file] |
||||
} elseif {$opt_cksum_algorithm eq "cksum"} { |
||||
package require cksum ;#tcllib |
||||
set cksum_command [list crc::cksum -format 0x%X -file] |
||||
} elseif {$opt_cksum_algorithm eq "adler32"} { |
||||
set cksum_command [list cksum_adler32_file] |
||||
} elseif {$opt_cksum_algorithm in [list "sha3" "sha3-256"]} { |
||||
#todo - replace with something that doesn't call another process |
||||
#set cksum_command [list apply {{file} {lindex [exec fossil sha3sum -256 $file] 0}}] |
||||
set cksum_command [list $sha3_implementation 256] |
||||
} elseif {$opt_cksum_algorithm in [list "sha3-224" "sha3-384" "sha3-512"]} { |
||||
set bits [lindex [split $opt_cksum_algorithm -] 1] |
||||
#set cksum_command [list apply {{bits file} {lindex [exec fossil sha3sum -$bits $file] 0}} $bits] |
||||
set cksum_command [list $sha3_implementation $bits] |
||||
} |
||||
|
||||
set cksum "" |
||||
if {$opt_use_tar != 0} { |
||||
set target [file tail $path] |
||||
set tmplocation [punk::mix::util::tmpdir] |
||||
set archivename $tmplocation/[punk::mix::util::tmpfile].tar |
||||
|
||||
cd $base ;#cd is process-wide.. keep cd in effect for as small a scope as possible. (review for thread issues) |
||||
|
||||
#temp emission to stdout.. todo - repl telemetry channel |
||||
puts stdout "cksum_path: creating temporary tar archive for $path" |
||||
puts stdout " at: $archivename .." |
||||
tar::create $archivename $target |
||||
if {$ftype eq "file"} { |
||||
set sizeinfo "(size [file size $target])" |
||||
} else { |
||||
set sizeinfo "(file type $ftype - size unknown)" |
||||
} |
||||
puts stdout "cksum_path: calculating cksum for $target $sizeinfo..." |
||||
set cksum [{*}$cksum_command $archivename] |
||||
#puts stdout "cksum_path: cleaning up.. " |
||||
file delete -force $archivename |
||||
cd $startdir |
||||
|
||||
} else { |
||||
#todo |
||||
if {$ftype eq "file"} { |
||||
if {$opt_cksum_meta} { |
||||
return [list error unsupported_opts_combo cksum "<ERR>" opts $opts] |
||||
} else { |
||||
set cksum [{*}$cksum_command $path] |
||||
} |
||||
} else { |
||||
error "cksum_path unsupported $opts for path type [file type $path]" |
||||
} |
||||
} |
||||
set result [dict create] |
||||
dict set result cksum $cksum |
||||
dict set result opts $opts_actual |
||||
return $result |
||||
} |
||||
|
||||
#dict_path_cksum keyed on path - with value as a dict that must contain cksum key - but can contain other keys |
||||
#e.g -cksum_usetar which is one of the keys understood by the punk::mix::base::lib::cksum_path function - or unrelated keys which will also be passed through |
||||
#cksum only calculated for keys in dict where cksum is empty - ie return same dict but with empty cksums filled out. |
||||
#base can be empty string in which case paths must be absolute |
||||
proc fill_relativecksums_from_base_and_relativepathdict {base {dict_path_cksum {}}} { |
||||
if {$base eq ""} { |
||||
set error_paths [list] |
||||
dict for {path pathinfo} $dict_path_cksum { |
||||
if {[file pathtype $path] ne "absolute"} { |
||||
lappend error_paths $path |
||||
} |
||||
} |
||||
if {[llength $error_paths]} { |
||||
puts stderr "get_relativecksums_from_base_and_relativepathdict has empty base - and non-absolute paths in the supplied checksum dict - aborting" |
||||
puts stderr "error_paths: $error_paths" |
||||
error "fill_relativecksums_from_base_and_relativepathdict error: non-absolute paths when base empty. $error_paths" |
||||
} |
||||
} else { |
||||
if {[file pathtype $base] ne "absolute"} { |
||||
error "fill_relativecksums_from_base_and_relativepathdict error: base supplied but was not absolute path. $base" |
||||
} |
||||
#conversely now we have a base - so we require all paths are relative. |
||||
#We will ignore/disallow volume-relative - as these shouldn't be used here either |
||||
set error_paths [list] |
||||
dict for {path pathinfo} $dict_path_cksum { |
||||
if {[file pathtype $path] ne "relative"} { |
||||
lappend error_paths $path |
||||
} |
||||
} |
||||
if {[llength $error_paths]} { |
||||
puts stderr "fill_relativecksums_from_base_and_relativepathdict has a supplied absolute base path, but some of the paths in the supplied dict are not relative - aborting" |
||||
error "fill_relativecksums_from_base_and_relativepathdict error: non-relative paths when base supplied. $error_paths" |
||||
} |
||||
} |
||||
|
||||
|
||||
dict for {path pathinfo} $dict_path_cksum { |
||||
if {![dict exists $pathinfo cksum]} { |
||||
dict set pathinfo cksum "" |
||||
} else { |
||||
if {[dict get $pathinfo cksum] ne "" && ![cksum_is_tag [dict get $pathinfo cksum]]} { |
||||
continue ;#already filled with non-tag value |
||||
} |
||||
} |
||||
if {$base ne ""} { |
||||
set fullpath [file join $base $path] |
||||
} else { |
||||
set fullpath $path |
||||
} |
||||
|
||||
set ckopts [cksum_filter_opts {*}$pathinfo] |
||||
|
||||
if {![file exists $fullpath]} { |
||||
dict set dict_path_cksum $path cksum "<PATHNOTFOUND>" |
||||
} else { |
||||
set ckinfo [cksum_path $fullpath {*}$ckopts] |
||||
dict set dict_path_cksum $path cksum [dict get $ckinfo cksum] |
||||
dict set dict_path_cksum $path cksum_all_opts [dict get $ckinfo opts] |
||||
if {[dict exists $ckinfo error]} { |
||||
dict set dict_path_cksum $path cksum_error [dict get $ckinfo error] |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $dict_path_cksum |
||||
} |
||||
#whether cksum is <XXX> e.g <ERR> <PATHNOTFOUND> |
||||
proc cksum_is_tag {cksum} { |
||||
expr {[string index $cksum 0] eq "<" && [string index $cksum end] eq ">"} |
||||
} |
||||
proc cksum_filter_opts {args} { |
||||
set ck_opt_names [dict keys [cksum_default_opts]] |
||||
set ck_opts [dict create] |
||||
dict for {k v} $args { |
||||
if {$k in $ck_opt_names} { |
||||
dict set ck_opts $k $v |
||||
} |
||||
} |
||||
return $ck_opts |
||||
} |
||||
|
||||
#convenience so caller doesn't have to pre-calculate the relative path from the base |
||||
#Note semantic difference from fill_relativecksums_from_base_and_relativepathdict (hence get_ vs fill_) |
||||
#Here we will raise an error if cksum exists and is not empty or a tag - whereas the multiple path version will ignore valid-looking prefilled cksum values |
||||
#base is the presumed location to store the checksum file. The caller should retain (normalize if relative) |
||||
proc get_relativecksum_from_base {base specifiedpath args} { |
||||
if {$base ne ""} { |
||||
#targetpath ideally should be within same project tree as base if base supplied - but not necessarily below it |
||||
#we don't necessarily want to restrict this to use in punk projects though - so we'll allow anything with a common prefix |
||||
if {[file pathtype $specifiedpath] eq "relative"} { |
||||
if {[file pathtype $base] eq "relative"} { |
||||
set normbase [file normalize $base] |
||||
set normtarg [file normalize [file join $normbase $specifiedpath]] |
||||
set targetpath $normtarg |
||||
set storedpath [punk::path::relative $normbase $normtarg] |
||||
} else { |
||||
set targetpath [file join $base $specifiedpath] |
||||
set storedpath $specifiedpath |
||||
} |
||||
} else { |
||||
#specifed absolute |
||||
if {[file pathtype $base] eq "relative"} { |
||||
#relative to cwd or to specifiedpath? For consistency it should arguably be cwd but a case could be made that when one path is relative it is in reference to the other |
||||
#there is a strong possibility that allowing this combination will cause confusion - better to disallow |
||||
error "get_relativecksum_from_base error: disallowed pathtype combination. Base must be empty or absolute when specified path is absolute" |
||||
} |
||||
#both absolute - compute relative path if they share a common prefix |
||||
set commonprefix [punk::mix::util::path_common_prefix $base $specifiedpath] |
||||
if {$commonprefix eq ""} { |
||||
#absolute base with no shared prefix doesn't make sense - we could ignore it - but better to error-out and require the caller specify an empty base |
||||
error "get_relativecksum_from_base error: base '$base' and specifiedpath '$specifiedpath' don't share a common root. Use empty-string for base if independent absolute path is required" |
||||
} |
||||
set targetpath $specifiedpath |
||||
set storedpath [punk::path::relative $base $specifiedpath] |
||||
|
||||
} |
||||
} else { |
||||
if {[file type $specifiedpath] eq "relative"} { |
||||
#if specifiedpath is relative - and we don't have a base, we now need to convert relative to cwd to an absolute path for storage |
||||
set targetpath [file normalize $specifiedpath] |
||||
set storedpath $targetpath |
||||
} else { |
||||
set targetpath $specifiedpath |
||||
set storedpath $targetpath |
||||
} |
||||
} |
||||
|
||||
# |
||||
#NOTE: specifiedpath can be a relative path (to cwd) when base is empty |
||||
#OR - a relative path when base itself is relative e.g base: somewhere targetpath somewhere/etc |
||||
#possibly also: base: somewhere targetpath: ../elsewhere/etc |
||||
# |
||||
#todo - write tests |
||||
|
||||
|
||||
if {([llength $args] % 2) != 0} { |
||||
error "get_relativecksum_from_base error. args supplied must be in the form of key-value pairs. received '$args' " |
||||
} |
||||
if {[dict exists $args cksum]} { |
||||
if {[dict get $args cksum] ne "" && ![cksum_is_tag [dict get $args cksum]]} { |
||||
error "get_relativecksum_from_base called with existing cksum value (and is not a tag or empty-value to be replaced) cksum: [dict get $args cksum] Set cksum to be empty, any tag such as <REPLACE> or remove the key and try again." |
||||
} |
||||
} |
||||
|
||||
|
||||
set ckopts [cksum_filter_opts {*}$args] |
||||
set ckinfo [cksum_path $targetpath {*}$ckopts] |
||||
|
||||
set keyvals $args |
||||
dict set keyvals cksum [dict get $ckinfo cksum] |
||||
dict set keyvals cksum_all_opts [dict get $ckinfo opts] |
||||
if {[dict exists $ckinfo error]} { |
||||
dict set keyvals cksum_error [dict get $ckinfo error] |
||||
} |
||||
|
||||
#set relpath [punk::repo::path_strip_alreadynormalized_prefixdepth $fullpath $base] ;#empty base ok noop |
||||
#storedpath is relative if possible |
||||
return [dict create $storedpath $keyvals] |
||||
} |
||||
|
||||
#calculate the runtime checksum and vfs checksums |
||||
proc get_all_vfs_build_cksums {path} { |
||||
set buildfolder [get_build_workdir $path] |
||||
set cksum_base_folder [file dirname $buildfolder] ;#this is the <project>/src folder - a reasonable base for our vfs cksums |
||||
set dict_cksums [dict create] |
||||
|
||||
set buildrelpath [punk::repo::path_strip_alreadynormalized_prefixdepth $buildfolder $cksum_base_folder] |
||||
set vfs_tail_list [glob -nocomplain -dir $cksum_base_folder -type d -tails *.vfs] |
||||
|
||||
foreach vfstail $vfs_tail_list { |
||||
set vname [file rootname $vfstail] |
||||
dict set dict_cksums $vfstail [list cksum ""] |
||||
dict set dict_cksums [file join $buildrelpath $vname.exe] [list cksum ""] |
||||
} |
||||
|
||||
set fullpath_buildruntime $buildfolder/buildruntime.exe |
||||
|
||||
set ckinfo_buildruntime [cksum_path $fullpath_buildruntime] |
||||
set ck [dict get $ckinfo_buildruntime cksum] |
||||
|
||||
|
||||
set relpath [file join $buildrelpath "buildruntime.exe"] |
||||
dict set dict_cksums $relpath [list cksum $ck] |
||||
|
||||
set dict_cksums [fill_relativecksums_from_base_and_relativepathdict $cksum_base_folder $dict_cksums] |
||||
|
||||
return $dict_cksums |
||||
} |
||||
|
||||
proc get_vfs_build_cksums_stored {vfsfolder} { |
||||
set vfscontainer [file dirname $vfsfolder] |
||||
set buildfolder $vfscontainer/_build |
||||
set vfs [file tail $vfsfolder] |
||||
set vname [file rootname $vfs] |
||||
set dict_vfs [list $vname.vfs "" $vname.exe "" buildruntime.exe ""] |
||||
set ckfile $buildfolder/$vname.cksums |
||||
if {[file exists $ckfile]} { |
||||
set data [punk::mix::util::fcat -translation binary $ckfile] |
||||
foreach ln [split $data \n] { |
||||
if {[string trim $ln] eq ""} {continue} |
||||
lassign $ln path cksum |
||||
dict set dict_vfs $path $cksum |
||||
} |
||||
} |
||||
return $dict_vfs |
||||
} |
||||
proc get_all_build_cksums_stored {path} { |
||||
set buildfolder [get_build_workdir $path] |
||||
|
||||
set vfscontainer [file dirname $buildfolder] |
||||
set vfslist [glob -nocomplain -dir $vfscontainer -type d -tail *.vfs] |
||||
set dict_cksums [dict create] |
||||
foreach vfs $vfslist { |
||||
set vname [file rootname $vfs] |
||||
set dict_vfs [get_vfs_build_cksums_stored $vfscontainer/$vfs] |
||||
|
||||
dict set dict_cksums $vname $dict_vfs |
||||
} |
||||
return $dict_cksums |
||||
} |
||||
|
||||
proc store_vfs_build_cksums {vfsfolder} { |
||||
if {![file isdirectory $vfsfolder]} { |
||||
error "Unable to find supplied vfsfolder: $vfsfolder" |
||||
} |
||||
set vfscontainer [file dirname $vfsfolder] |
||||
set buildfolder $vfscontainer/_build |
||||
set dict_vfs [get_vfs_build_cksums $vfsfolder] |
||||
set data "" |
||||
dict for {path cksum} $dict_vfs { |
||||
append data "$path $cksum" \n |
||||
} |
||||
set fd [open $buildfolder/$vname.cksums w] |
||||
chan configure $fd -translation binary |
||||
puts $fd $data |
||||
close $fd |
||||
return $dict_vfs |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
} |
@ -1,925 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::cli 0.3 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::repo |
||||
package require punkcheck ;#checksum and/or timestamp records |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
namespace eval punk::mix::cli { |
||||
namespace eval temp_import { |
||||
} |
||||
namespace ensemble create |
||||
|
||||
package require punk::overlay |
||||
catch { |
||||
punk::overlay::import_commandset module . ::punk::mix::commandset::module |
||||
} |
||||
punk::overlay::import_commandset debug . ::punk::mix::commandset::debug |
||||
punk::overlay::import_commandset repo . ::punk::mix::commandset::repo |
||||
punk::overlay::import_commandset lib . ::punk::mix::commandset::loadedlib |
||||
|
||||
catch { |
||||
package require punk::mix::commandset::project |
||||
punk::overlay::import_commandset project . ::punk::mix::commandset::project |
||||
punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection |
||||
} |
||||
if {[catch { |
||||
package require punk::mix::commandset::layout |
||||
punk::overlay::import_commandset project.layout . ::punk::mix::commandset::layout |
||||
punk::overlay::import_commandset project.layouts . ::punk::mix::commandset::layout::collection |
||||
} errM]} { |
||||
puts stderr "error loading punk::mix::commandset::layout" |
||||
puts stderr $errM |
||||
} |
||||
if {[catch { |
||||
package require punk::mix::commandset::buildsuite |
||||
punk::overlay::import_commandset buildsuite . ::punk::mix::commandset::buildsuite |
||||
punk::overlay::import_commandset buildsuites . ::punk::mix::commandset::buildsuite::collection |
||||
} errM]} { |
||||
puts stderr "error loading punk::mix::commandset::buildsuite" |
||||
puts stderr $errM |
||||
} |
||||
punk::overlay::import_commandset scriptwrap . ::punk::mix::commandset::scriptwrap |
||||
if {[catch { |
||||
package require punk::mix::commandset::doc |
||||
punk::overlay::import_commandset doc . ::punk::mix::commandset::doc |
||||
punk::overlay::import_commandset "" "" ::punk::mix::commandset::doc::collection |
||||
} errM]} { |
||||
puts stderr "error loading punk::mix::commandset::doc" |
||||
puts stderr $errM |
||||
} |
||||
|
||||
|
||||
proc help {args} { |
||||
#set basehelp [punk::mix::base::help -extension [namespace current] {*}$args] |
||||
set basehelp [punk::mix::base help {*}$args] |
||||
#puts stdout "punk::mix help" |
||||
return $basehelp |
||||
} |
||||
|
||||
proc stat {{workingdir ""} args} { |
||||
dict set args -v 0 |
||||
punk::mix::cli::lib::get_status $workingdir {*}$args |
||||
} |
||||
proc status {{workingdir ""} args} { |
||||
dict set args -v 1 |
||||
punk::mix::cli::lib::get_status $workingdir {*}$args |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
namespace eval punk::mix::cli { |
||||
|
||||
|
||||
#interp alias {} ::punk::mix::cli::project.new {} ::punk::mix::cli::new |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
proc make {args} { |
||||
set startdir [pwd] |
||||
set project_base "" ;#empty for unknown |
||||
if {[punk::repo::is_git $startdir]} { |
||||
set project_base [punk::repo::find_git] |
||||
set sourcefolder $project_base/src |
||||
} elseif {[punk::repo::is_fossil $startdir]} { |
||||
set project_base [punk::repo::find_fossil] |
||||
set sourcefolder $project_base/src |
||||
} else { |
||||
if {[punk::repo::is_candidate $startdir]} { |
||||
set project_base [punk::repo::find_candidate] |
||||
set sourcefolder $project_base/src |
||||
puts stderr "WARNING - project not under git or fossil control" |
||||
puts stderr "Using base folder $project_base" |
||||
} else { |
||||
set sourcefolder $startdir |
||||
} |
||||
} |
||||
|
||||
#review - why can't we be anywhere in the project? |
||||
if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { |
||||
puts stderr "pmix make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])" |
||||
if {[string length $project_base]} { |
||||
if {[file exists $project_base/src] && [string tolower [pwd]] ne [string tolower $project_base/src]} { |
||||
puts stderr "Try cd to $project_base/src" |
||||
} |
||||
} else { |
||||
if {[file exists $startdir/Makefile]} { |
||||
puts stdout "A Makefile exists at $startdir/Makefile." |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
puts stdout "Try running: msys2 -ucrt64 -here -c \"make build\" or bash -c \"make build\"" |
||||
} else { |
||||
puts stdout "Try runing: make build" |
||||
} |
||||
} |
||||
} |
||||
return false |
||||
} |
||||
|
||||
if {![string length $project_base]} { |
||||
puts stderr "WARNING no git or fossil repository detected." |
||||
puts stderr "Using base folder $startdir" |
||||
set project_base $startdir |
||||
} |
||||
|
||||
set lc_this_exe [string tolower [info nameofexecutable]] |
||||
set lc_proj_bin [string tolower $project_base/bin] |
||||
set lc_build_bin [string tolower $project_base/src/_build] |
||||
|
||||
if {"project" in $args} { |
||||
set is_own_exe 0 |
||||
if {[string match "${lc_proj_bin}*" $lc_this_exe] || [string match "${lc_build_bin}" $lc_this_exe]} { |
||||
set is_own_exe 1 |
||||
puts stderr "WARNING - running make using executable that may be created by the project being built" |
||||
set answer [util::askuser "Do you want to proceed using this executable? (build will probably stop when it is unable to update the executable) Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
} |
||||
cd $sourcefolder |
||||
#use run so that stdout visible as it goes |
||||
if {![catch {run --timeout=55000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} { |
||||
#todo - notify if exit because of timeout! |
||||
puts stderr "exitinfo: $exitinfo" |
||||
set exitcode [dict get $exitinfo exitcode] |
||||
} else { |
||||
puts stderr "Error unable to determine exitcode. err: $exitinfo" |
||||
cd $startdir |
||||
return false |
||||
} |
||||
|
||||
cd $startdir |
||||
if {$exitcode != 0} { |
||||
puts stderr "FAILED with exitcode $exitcode" |
||||
return false |
||||
} else { |
||||
puts stdout "OK make finished " |
||||
return true |
||||
} |
||||
} |
||||
|
||||
proc Kettle {args} { |
||||
tailcall lib::kettle_call lib {*}$args |
||||
} |
||||
proc KettleShell {args} { |
||||
tailcall lib::kettle_call shell {*}$args |
||||
} |
||||
|
||||
|
||||
|
||||
namespace eval lib { |
||||
namespace path ::punk::mix::util |
||||
|
||||
|
||||
proc module_types {} { |
||||
#first in list is default for unspecified -type when creating new module |
||||
return [list plain tarjar zipkit] |
||||
} |
||||
|
||||
proc validate_modulename {modulename args} { |
||||
set defaults [list\ |
||||
-name_description modulename\ |
||||
] |
||||
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} |
||||
set known_opts [dict keys $defaults] |
||||
foreach k [dict keys $args] { |
||||
if {$k ni $known_opts} { |
||||
error "validate_modulename error: unknown option $k. known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_name_description [dict get $opts -name_description] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
validate_name_not_empty_or_spaced $modulename -name_description $opt_name_description |
||||
set testname [string map [list :: ""] $modulename] |
||||
if {[string first : $testname] >=0} { |
||||
error "$opt_name_description '$modulename' can only contain paired colons" |
||||
} |
||||
set badchars [list - "$" "?" "*"] |
||||
foreach bc $badchars { |
||||
if {[string first $bc $modulename] >= 0} { |
||||
error "$opt_name_description '$modulename' can not contain character '$bc'" |
||||
} |
||||
} |
||||
return $modulename |
||||
} |
||||
|
||||
proc validate_projectname {projectname args} { |
||||
set defaults [list\ |
||||
-name_description projectname\ |
||||
] |
||||
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} |
||||
set known_opts [dict keys $defaults] |
||||
foreach k [dict keys $args] { |
||||
if {$k ni $known_opts} { |
||||
error "validate_modulename error: unknown option $k. known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_name_description [dict get $opts -name_description] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
validate_name_not_empty_or_spaced $projectname -name_description $opt_name_description |
||||
set reserved_words [list etc lib bin modules src doc vendorlib vendormodules embedded runtime _aside _build] |
||||
if {$projectname in $reserved_words } { |
||||
error "$opt_name_description '$projectname' cannot be one of reserved_words: $reserved_words" |
||||
} |
||||
if {[string first "::" $projectname] >= 0} { |
||||
error "$opt_name_description '$projectname' cannot contain namespace separator '::'" |
||||
} |
||||
return $projectname |
||||
} |
||||
proc validate_name_not_empty_or_spaced {name args} { |
||||
set defaults [list\ |
||||
-name_description projectname\ |
||||
] |
||||
if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} |
||||
set known_opts [dict keys $defaults] |
||||
foreach k [dict keys $args] { |
||||
if {$k ni $known_opts} { |
||||
error "validate_modulename error: unknown option $k. known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_name_description [dict get $opts -name_description] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
if {![string length $name]} { |
||||
error "$opt_name_description cannot be empty" |
||||
} |
||||
if {[string length [string map [list " " "" \n "" \r "" \t ""] $name]] != [string length $name]} { |
||||
error "$opt_name_description cannot contain whitespace" |
||||
} |
||||
return $name |
||||
} |
||||
|
||||
#split modulename (as present in a filename or namespaced name) into name/version ignoring leading namespace path |
||||
#ignore trailing .tm .TM if present |
||||
#if version doesn't pass validation - treat it as part of the modulename and return empty version string without error |
||||
#Up to caller to validate. |
||||
proc split_modulename_version {modulename} { |
||||
set lastpart [namespace tail $modulename] |
||||
set lastpart [file tail $lastpart] ;# should be ok to use file tail now that we've ensured no namespace components |
||||
if {[string equal -nocase [file extension $modulename] ".tm"]} { |
||||
set fileparts [split [file rootname $lastpart] -] |
||||
} else { |
||||
set fileparts [split $lastpart -] |
||||
} |
||||
if {[punk::mix::util::is_valid_tm_version [lindex $fileparts end]]} { |
||||
set versionsegment [lindex $fileparts end] |
||||
set namesegment [join [lrange $fileparts 0 end-1] -];#re-stitch |
||||
} else { |
||||
# |
||||
set namesegment [join $fileparts -] |
||||
set versionsegment "" |
||||
} |
||||
return [list $namesegment $versionsegment] |
||||
} |
||||
|
||||
proc get_status {{workingdir ""} args} { |
||||
set result "" |
||||
if {$workingdir ne ""} { |
||||
if {[file pathtype $workingdir] ne "absolute"} { |
||||
set workingdir [file normalize $workingdir] |
||||
} |
||||
set active_dir $workingdir |
||||
} else { |
||||
set active_dir [pwd] |
||||
} |
||||
set defaults [dict create\ |
||||
-v 1\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- |
||||
set opt_v [dict get $opts -v] |
||||
# -- --- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
set repopaths [punk::repo::find_repos [pwd]] |
||||
set repos [dict get $repopaths repos] |
||||
if {![llength $repos]} { |
||||
append result [dict get $repopaths warnings] |
||||
} else { |
||||
append result [dict get $repopaths warnings] |
||||
lassign [lindex $repos 0] repopath repotypes |
||||
if {"fossil" in $repotypes} { |
||||
#review - multiple process launches to fossil a bit slow on windows.. |
||||
#could we query global db in one go instead? |
||||
# |
||||
set fossil_prog [auto_execok fossil] |
||||
append result "FOSSIL project based at $repopath with revision: [punk::repo::fossil_revision $repopath]" \n |
||||
set fosinfo [exec {*}$fossil_prog info] |
||||
append result [join [punk::repo::grep {repository:*} $fosinfo] \n] \n |
||||
|
||||
set fosrem [exec {*}$fossil_prog remote ls] |
||||
if {[string length $fosrem]} { |
||||
append result "Remotes:\n" |
||||
append result " " $fosrem \n |
||||
} |
||||
|
||||
|
||||
append result [join [punk::repo::grep {tags:*} $fosinfo] \n] \n |
||||
|
||||
set dbinfo [exec {*}$fossil_prog dbstat] |
||||
append result [join [punk::repo::grep {project-name:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {tickets:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {project-age:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {latest-change:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {files:*} $dbinfo] \n] \n |
||||
append result [join [punk::repo::grep {check-ins:*} $dbinfo] \n] \n |
||||
if {"project" in $repotypes} { |
||||
#punk project |
||||
if {![catch {package require textblock; package require patternpunk}]} { |
||||
set result [textblock::join [textblock::join [>punk . logo] " "] $result] |
||||
append result \n |
||||
} |
||||
} |
||||
|
||||
set timeline [exec fossil timeline -n 5 -t ci] |
||||
set timeline [string map [list \r\n \n] $timeline] |
||||
append result $timeline |
||||
if {$opt_v} { |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
|
||||
} |
||||
#repotypes *could* be both git and fossil - so report both if so |
||||
if {"git" in $repotypes} { |
||||
append result "GIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n |
||||
if {[string length [set git_prog [auto_execok git]]]} { |
||||
set git_remotes [exec {*}$git_prog remote -v] |
||||
append result $git_remotes |
||||
if {$opt_v} { |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes git] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
return $result |
||||
} |
||||
|
||||
|
||||
proc build_modules_from_source_to_base {srcdir basedir args} { |
||||
set antidir [list "#*" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders we don't want to search in. |
||||
set defaults [list\ |
||||
-installer punk::mix::cli::build_modules_from_source_to_base\ |
||||
-call-depth-internal 0\ |
||||
-max_depth 1000\ |
||||
-subdirlist {}\ |
||||
-punkcheck_eventobj "\uFFFF"\ |
||||
-glob *.tm\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set installername [dict get $opts -installer] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set CALLDEPTH [dict get $opts -call-depth-internal] |
||||
set max_depth [dict get $opts -max_depth] |
||||
set subdirlist [dict get $opts -subdirlist] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set fileglob [dict get $opts -glob] |
||||
if {![string match "*.tm" $fileglob]} { |
||||
error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules." |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_punkcheck_eventobj [dict get $opts -punkcheck_eventobj] |
||||
|
||||
set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing |
||||
set module_list [list] |
||||
|
||||
if {[file tail [file dirname $srcdir]] ne "src"} { |
||||
puts stderr "ERROR build_modules_from_source_to_base can only be called with a srcdir that is a subfolder of your 'src' directory" |
||||
puts stderr "The .tm modules are namespaced based on their directory depth - so we need to start at the root" |
||||
puts stderr "To build a subtree of your modules - use an appropriate src/modules folder and pass in the -subdirlist." |
||||
puts stderr "e.g if your modules are based at /x/src/modules2 and you wish to build only the .tm files at /x/src/modules2/skunkworks/lib" |
||||
puts stderr "Use: >build_modules_from_source_to_base /x/src/modules2 /x/modules2 -subdirlist {skunkworks lib}" |
||||
exit 2 |
||||
} |
||||
set srcdirname [file tail $srcdir] |
||||
|
||||
set build [file dirname $srcdir]/_build/$srcdirname ;#relative to *original* srcdir - not current_source_dir |
||||
if {[llength $subdirlist] == 0} { |
||||
set target_module_dir $basedir |
||||
set current_source_dir $srcdir |
||||
} else { |
||||
set target_module_dir $basedir/[file join {*}$subdirlist] |
||||
set current_source_dir $srcdir/[file join {*}$subdirlist] |
||||
} |
||||
if {![file exists $target_module_dir]} { |
||||
error "build_modules_from_source_to_base from current source dir: '$current_source_dir'. Basedir:'$current_module_dir' doesn't exist or is empty" |
||||
} |
||||
if {![file exists $current_source_dir]} { |
||||
error "build_modules_from_source_to_base from current source dir:'$current_source_dir' doesn't exist or is empty" |
||||
} |
||||
|
||||
#---------------------------------------- |
||||
set punkcheck_file [file join $basedir/.punkcheck] |
||||
if {$CALLDEPTH == 0} { |
||||
|
||||
set config [dict create\ |
||||
-glob $fileglob\ |
||||
-max_depth 0\ |
||||
] |
||||
#lassign [punkcheck::start_installer_event $punkcheck_file $installername $srcdir $basedir $config] _eventid punkcheck_eventid _recordset record_list |
||||
# -- --- |
||||
set installer [punkcheck::installtrack new $installername $punkcheck_file] |
||||
$installer set_source_target $srcdir $basedir |
||||
set event [$installer start_event $config] |
||||
# -- --- |
||||
|
||||
} else { |
||||
set event $opt_punkcheck_eventobj |
||||
} |
||||
#---------------------------------------- |
||||
|
||||
|
||||
|
||||
set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] |
||||
|
||||
set did_skip 0 ;#flag for stdout/stderr formatting only |
||||
foreach m $src_modules { |
||||
set is_interesting 0 |
||||
if {[string match "foobar" $current_source_dir]} { |
||||
set is_interesting 1 |
||||
} |
||||
if {$is_interesting} { |
||||
puts "build_modules_from_source_to_base >>> module $current_source_dir/$m" |
||||
} |
||||
set fileparts [split [file rootname $m] -] |
||||
set tmfile_versionsegment [lindex $fileparts end] |
||||
if {$tmfile_versionsegment eq $magicversion} { |
||||
#rebuild the .tm from the #tarjar |
||||
set basename [join [lrange $fileparts 0 end-1] -] |
||||
set versionfile $current_source_dir/$basename-buildversion.txt |
||||
set versionfiledata "" |
||||
if {![file exists $versionfile]} { |
||||
puts stderr "\nWARNING: Missing buildversion text file: $versionfile" |
||||
puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n" |
||||
set module_build_version "0.1" |
||||
} else { |
||||
set fd [open $versionfile r] |
||||
set versionfiledata [read $fd]; close $fd |
||||
set ln0 [lindex [split $versionfiledata \n] 0] |
||||
set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] |
||||
if {![util::is_valid_tm_version $ln0]} { |
||||
puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" |
||||
exit 3 |
||||
} |
||||
set module_build_version $ln0 |
||||
} |
||||
|
||||
|
||||
if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { |
||||
#TODO |
||||
file mkdir $buildfolder |
||||
|
||||
if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { |
||||
|
||||
} else { |
||||
|
||||
} |
||||
#REVIEW - should be in same structure/depth as $target_module_dir in _build? |
||||
set tmfile $basedir/_build/$basename-$module_build_version.tm |
||||
file mkdir $basedir/_build |
||||
file delete -force $basedir/_build/#tarjar-$basename-$module_build_version |
||||
file delete -force $tmfile |
||||
|
||||
|
||||
file copy -force $current_source_dir/#tarjar-$basename-$magicversion $basedir/_build/#tarjar-$basename-$module_build_version |
||||
# |
||||
#bsdtar doesn't seem to work.. or I haven't worked out the right options? |
||||
#exec tar -cvf $basedir/_build/$basename-$module_build_version.tm $basedir/_build/#tarjar-$basename-$module_build_version |
||||
package require tar |
||||
tar::create $tmfile $basedir/_build/#tarjar-$basename-$module_build_version |
||||
if {![file exists $tmfile]} { |
||||
puts stdout "ERROR: Failed to build tarjar file $tmfile" |
||||
exit 4 |
||||
} |
||||
#copy the file? |
||||
#set target $target_module_dir/$basename-$module_build_version.tm |
||||
#file copy -force $tmfile $target |
||||
|
||||
lappend module_list $tmfile |
||||
} else { |
||||
#assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. |
||||
if {[file exists $current_source_dir/#tarjar-$basename-${magicversion}#]} { |
||||
puts stderr "\nWarning: found 'capped' folder #tarjar-$basename-${magicversion}# - No attempt being made to update version in description.txt" |
||||
} |
||||
|
||||
#------------------------------ |
||||
# |
||||
#set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] |
||||
#set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] |
||||
$event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm |
||||
$event targetset_addsource $versionfile |
||||
$event targetset_addsource $current_source_dir/$m |
||||
|
||||
#set changed_list [list] |
||||
## -- --- --- --- --- --- |
||||
#set source_relpath [punkcheck::lib::path_relative $basedir $versionfile] |
||||
#set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] |
||||
## -- --- --- --- --- --- |
||||
#set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] |
||||
#set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] |
||||
## -- --- --- --- --- --- |
||||
#set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] |
||||
#set changed_list [dict get $changed_unchanged changed] |
||||
|
||||
|
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ |
||||
} { |
||||
|
||||
#set file_record [punkcheck::installfile_started_install $basedir $file_record] |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
set target $target_module_dir/$basename-$module_build_version.tm |
||||
if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} |
||||
puts stdout "copying module $current_source_dir/$m to $target as version: $module_build_version ([file tail $target])" |
||||
set fd [open $current_source_dir/$m r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd |
||||
set data [string map [list $magicversion $module_build_version] $data] |
||||
set fdout [open $target w] |
||||
fconfigure $fdout -translation binary |
||||
puts -nonewline $fdout $data |
||||
close $fdout |
||||
#file copy -force $srcdir/$m $target |
||||
lappend module_list $target |
||||
# -- --- --- --- --- --- |
||||
#set file_record [punkcheck::installfile_finished_install $basedir $file_record] |
||||
$event targetset_end OK |
||||
} else { |
||||
if {$is_interesting} { |
||||
puts stdout "skipping module $current_source_dir/$m - no change in sources detected" |
||||
} |
||||
puts -nonewline stderr "." |
||||
set did_skip 1 |
||||
#set file_record [punkcheck::installfile_skipped_install $basedir $file_record] |
||||
$event targetset_end SKIPPED |
||||
} |
||||
|
||||
#------------------------------ |
||||
|
||||
} |
||||
|
||||
continue |
||||
} |
||||
|
||||
|
||||
if {![util::is_valid_tm_version $tmfile_versionsegment]} { |
||||
#last segment doesn't look even slightly versiony - fail. |
||||
puts stderr "ERROR: Unable to confirm file $current_source_dir/$m is a reasonably versioned .tm module - ABORTING." |
||||
exit 1 |
||||
} |
||||
|
||||
##------------------------------ |
||||
## |
||||
#set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$m] |
||||
#set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] |
||||
#set changed_list [list] |
||||
## -- --- --- --- --- --- |
||||
#set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] |
||||
#set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] |
||||
## -- --- --- --- --- --- |
||||
#set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] |
||||
#set changed_list [dict get $changed_unchanged changed] |
||||
|
||||
#---------- |
||||
$event targetset_init INSTALL $target_module_dir/$m |
||||
$event targetset_addsource $current_source_dir/$m |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ |
||||
} { |
||||
|
||||
#set file_record [punkcheck::installfile_started_install $basedir $file_record] |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} |
||||
lappend module_list $current_source_dir/$m |
||||
file copy -force $current_source_dir/$m $target_module_dir |
||||
puts stderr "Copied already versioned module $current_source_dir/$m to $target_module_dir" |
||||
# -- --- --- --- --- --- |
||||
#set file_record [punkcheck::installfile_finished_install $basedir $file_record] |
||||
$event targetset_end OK -note "already versioned module" |
||||
} else { |
||||
puts -nonewline stderr "." |
||||
set did_skip 1 |
||||
if {$is_interesting} { |
||||
puts stderr "$current_source_dir/$m [$event targetset_source_changes]" |
||||
} |
||||
#set file_record [punkcheck::installfile_skipped_install $basedir $file_record] |
||||
$event targetset_end SKIPPED |
||||
} |
||||
|
||||
} |
||||
if {$CALLDEPTH >= $max_depth} { |
||||
set subdirs [list] |
||||
} else { |
||||
set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] |
||||
} |
||||
#puts stderr "subdirs: $subdirs" |
||||
foreach d $subdirs { |
||||
set skipdir 0 |
||||
foreach dg $antidir { |
||||
if {[string match $dg $d]} { |
||||
set skipdir 1 |
||||
continue |
||||
} |
||||
} |
||||
if {$skipdir} { |
||||
continue |
||||
} |
||||
if {![file exists $target_module_dir/$d]} { |
||||
file mkdir $target_module_dir/$d |
||||
} |
||||
lappend module_list {*}[build_modules_from_source_to_base $srcdir $basedir\ |
||||
-call-depth-internal [expr {$CALLDEPTH +1}]\ |
||||
-subdirlist [list {*}$subdirlist $d]\ |
||||
-punkcheck_eventobj $event\ |
||||
-glob $fileglob\ |
||||
] |
||||
} |
||||
if {$did_skip} { |
||||
puts -nonewline stdout \n |
||||
} |
||||
if {$CALLDEPTH == 0} { |
||||
$event destroy |
||||
$installer destroy |
||||
} |
||||
return $module_list |
||||
} |
||||
|
||||
variable kettle_reset_bodies [dict create] |
||||
variable kettle_reset_args [dict create] |
||||
#We are abusing kettle to run in-process. |
||||
# when we change to another project we need recipes to be reloaded. |
||||
# Kettle rewrites some of it's own procs - stopping reloading of recipes when we change folders |
||||
#kettle_init stores the original proc bodies & args |
||||
proc kettle_init {} { |
||||
variable kettle_reset_bodies ;#dict |
||||
variable kettle_reset_args |
||||
set reset_procs [list\ |
||||
::kettle::benchmarks\ |
||||
::kettle::doc\ |
||||
::kettle::figures\ |
||||
::kettle::meta::scan\ |
||||
::kettle::testsuite\ |
||||
] |
||||
foreach p $reset_procs { |
||||
set b [info body $p] |
||||
if {[string match "*Overwrite self*" $b]} { |
||||
dict set kettle_reset_bodies $p $b |
||||
set argnames [info args $p] |
||||
set arglist [list] |
||||
foreach a $argnames { |
||||
if {[info default $p $a dval]} { |
||||
lappend arglist [list $a $dval] |
||||
} else { |
||||
lappend arglist $a |
||||
} |
||||
} |
||||
dict set kettle_reset_args $p $arglist |
||||
} |
||||
} |
||||
|
||||
} |
||||
#call kettle_reinit to ensure recipes point to current project |
||||
proc kettle_reinit {} { |
||||
variable kettle_reset_bodies |
||||
variable kettle_reset_args |
||||
foreach p [dict keys $kettle_reset_bodies] { |
||||
set b [dict get $kettle_reset_bodies $p] |
||||
set argl [dict get $kettle_reset_args $p] |
||||
uplevel 1 [list ::proc $p $argl $b] |
||||
} |
||||
#todo - determine standard recipes by examining standard.tcl instead of hard coding? |
||||
set standard_recipes [list\ |
||||
null\ |
||||
forever\ |
||||
list-recipes\ |
||||
help-recipes\ |
||||
help-dump\ |
||||
help-recipes\ |
||||
help\ |
||||
list\ |
||||
list-options\ |
||||
help-options\ |
||||
show-configuration\ |
||||
show-state\ |
||||
show\ |
||||
meta-status\ |
||||
gui\ |
||||
] |
||||
#set ::kettle::recipe::recipe [dict create] |
||||
foreach r [dict keys $::kettle::recipe::recipe] { |
||||
if {$r ni $standard_recipes} { |
||||
dict unset ::kettle::recipe::recipe $r |
||||
} |
||||
} |
||||
} |
||||
proc kettle_call {calltype args} { |
||||
variable kettle_reset_bodies |
||||
if {$calltype ni [list lib shell]} { |
||||
error "pmix kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process" |
||||
} |
||||
if {$calltype eq "shell"} { |
||||
set kettleappfile [file dirname [info nameofexecutable]]/kettle |
||||
set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat |
||||
|
||||
if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} { |
||||
error "pmix kettle_call unable to find installed kettle application file '$kettleappfile' (or '$kettlebatfile' if on windows)" |
||||
} |
||||
if {[file exists $kettleappfile]} { |
||||
set kettlescript $kettleappfile |
||||
} |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
if {[file exists $kettlebatfile]} { |
||||
set kettlescript $kettlebatfile |
||||
} |
||||
} |
||||
} |
||||
set startdir [pwd] |
||||
if {![file exists $startdir/build.tcl]} { |
||||
error "pmix kettle must be run from a folder containing build.tcl (cwd: [pwd])" |
||||
} |
||||
if {[package provide kettle] eq ""} { |
||||
puts stdout "Loading kettle package - may be delay on first load ..." |
||||
package require kettle |
||||
kettle_init ;#store original procs for those kettle procs that rewrite themselves |
||||
} else { |
||||
if {[dict size $kettle_reset_bodies] == 0} { |
||||
#presumably package require kettle was called without calling our kettle_init hack. |
||||
kettle_init |
||||
} else { |
||||
#undo proc rewrites |
||||
kettle_reinit |
||||
} |
||||
} |
||||
set first [lindex $args 0] |
||||
if {[string match @* $first]} { |
||||
error "pmix kettle doesn't support special operations - try calling tclsh kettle directly" |
||||
} |
||||
if {$first eq "-f"} { |
||||
set args [lassign $args __ path] |
||||
} else { |
||||
set path $startdir/build.tcl |
||||
} |
||||
set opts [list] |
||||
|
||||
if {[lindex $args 0] eq "-trace"} { |
||||
set args [lrange $args 1 end] |
||||
lappend opts --verbose on |
||||
} |
||||
set goals [list] |
||||
|
||||
if {$calltype eq "lib"} { |
||||
file mkdir ~/.kettle |
||||
set dotfile ~/.kettle/config |
||||
if {[file exists $dotfile] && |
||||
[file isfile $dotfile] && |
||||
[file readable $dotfile]} { |
||||
::kettle io trace {Loading dotfile $dotfile ...} |
||||
set args [list {*}[::kettle path cat $dotfile] {*}$args] |
||||
} |
||||
} |
||||
|
||||
#hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names |
||||
#This is done so we don't have to load kettle lib for shell call (both loading as module and running shell are annoyingly SLOW) |
||||
#REVIEW - needs to be updated to keep in sync with kettle. |
||||
set knownopts [list\ |
||||
--exec-prefix --bin-dir --lib-dir --prefix --man-dir --html-dir --markdown-dir --include-dir \ |
||||
--ignore-glob --dry --verbose --machine --color --state --config --with-shell --log \ |
||||
--log-append --log-mode --with-dia --constraints --file --limitconstraints --tmatch --notfile --single --valgrind --tskip --repeats \ |
||||
--iters --collate --match --rmatch --with-doc-destination --with-git --target --test-include \ |
||||
] |
||||
|
||||
while {[llength $args]} { |
||||
set o [lindex $args 0] |
||||
switch -glob -- $o { |
||||
--* { |
||||
#instead of using: kettle option known |
||||
if {$o ni $knownopts} { |
||||
error "Unable to process unknown option $o." {} [list KETTLE (pmix)] |
||||
} |
||||
lappend opts $o [lindex $args 1] |
||||
#::kettle::option set $o [lindex $args 1] |
||||
set args [lrange $args 2 end] |
||||
} |
||||
default { |
||||
lappend goals $o |
||||
set args [lrange $args 1 end] |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {![llength $goals]} { |
||||
lappend goals help |
||||
} |
||||
if {"--prefix" ni [dict keys $opts]} { |
||||
dict set opts --prefix [file dirname $startdir] |
||||
} |
||||
if {$calltype eq "lib"} { |
||||
::kettle status clear |
||||
::kettle::option::set @kettle $startdir |
||||
foreach {o v} $opts { |
||||
::kettle option set $o $v |
||||
} |
||||
::kettle option set @srcscript $path |
||||
::kettle option set @srcdir [file dirname $path] |
||||
::kettle option set @goals $goals |
||||
#load standard recipes as listed in build.tcl |
||||
::source $path |
||||
puts stderr "recipes: [::kettle recipe names]" |
||||
::kettle recipe run {*}[::kettle option get @goals] |
||||
|
||||
set state [::kettle option get --state] |
||||
if {$state ne {}} { |
||||
puts stderr "saving kettle state: $state" |
||||
::kettle status save $state |
||||
} |
||||
|
||||
} else { |
||||
#shell |
||||
puts stdout "Running external kettle process with args: $opts $goals" |
||||
run -n tclsh $kettlescript -f $path {*}$opts {*}$goals |
||||
} |
||||
|
||||
} |
||||
proc kettle_punk_recipes {} { |
||||
set txtdst ... |
||||
} |
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
namespace eval punk::mix::cli { |
||||
proc _cli {args} { |
||||
#don't use tailcall - base uses info level to determine caller |
||||
::punk::mix::base::_cli {*}$args |
||||
} |
||||
variable default_command help |
||||
package require punk::mix::base |
||||
package require punk::overlay |
||||
punk::overlay::custom_from_base [namespace current] ::punk::mix::base |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::cli [namespace eval punk::mix::cli { |
||||
variable version |
||||
set version 0.3 |
||||
}] |
||||
return |
@ -1,152 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::buildsuite 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::buildsuite { |
||||
namespace export * |
||||
proc projects {suite} { |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
set projectdir [dict get $pathinfo closest] |
||||
set suites_dir [file join $projectdir src buildsuites] |
||||
if {![file isdirectory [file join $suites_dir $suite]]} { |
||||
puts stderr "suite: $suite not found in buildsuites folder: $suites_dir" |
||||
return |
||||
} |
||||
set suite_dir [file join $suites_dir $suite] |
||||
set projects [glob -dir $suite_dir -type d -tails *] |
||||
|
||||
#use internal du which although breadth-first is generally faster |
||||
puts stdout "Examining source folders in $suite_dir." ;#A hint that something is happening in case sources are large |
||||
set du_info [punk::du::du -d 1 -b $suite_dir] |
||||
set du_sizes [dict create] |
||||
set suite_total_size "-" |
||||
foreach du_record $du_info { |
||||
if {[llength $du_record] != 2} { |
||||
#sanity precaution - punk::du::du should always output list of 2 element lists - at least with flags we're using |
||||
continue |
||||
} |
||||
set sz [lindex $du_record 0] |
||||
set path_parts [file split [lindex $du_record 1]] ;#should handle spaced-paths ok. |
||||
set s [lindex $path_parts end-1] |
||||
set p [lindex $path_parts end] |
||||
|
||||
#This handles case where a project folder is same name as suite e.g src/buildsuites/tcl/tcl |
||||
#so we can't just use tail as dict key. We could assume last record is always total - but |
||||
if {![string match -nocase $s $suite]} { |
||||
if {$s eq "buildsuites" && [string match -nocase $p $suite]} { |
||||
set suite_total_size $sz ;#this includes config files in suite base - so we don't really want to use this to report the total source size |
||||
} else { |
||||
#something else - shouldn't happen |
||||
puts stderr "Unexpected output from du in suite_dir: $suite_dir" |
||||
puts stderr "$du_record" |
||||
#try to continue anyway |
||||
} |
||||
} else { |
||||
dict set du_sizes $p $sz |
||||
} |
||||
} |
||||
|
||||
#build another dict for sizes where we ensure exactly one entry for each project exists and exclude total (don't blindly trust du output e.g in case weird filename/permission issue) |
||||
set psizes [list] |
||||
foreach p $projects { |
||||
if {[dict exists $du_sizes $p]} { |
||||
dict set psizes $p [dict get $du_sizes $p] |
||||
} else { |
||||
dict set psizes $p - |
||||
} |
||||
} |
||||
set total_source_size "-" |
||||
if {[catch { |
||||
set total_source_size [tcl::mathop::+ {*}[dict values $psizes]] |
||||
} errM]} { |
||||
puts stderr "Failed to calculate total source size. Errmsg: $errM" |
||||
} |
||||
package require overtype |
||||
|
||||
set title1 "Projects" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $projects] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
|
||||
set size_values [dict values $psizes] |
||||
# Title is probably widest - but go through the process anyway! |
||||
set title2 "Source Bytes" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $size_values] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
|
||||
|
||||
set output "" |
||||
append output "[overtype::left $col1 $title1] [overtype::right $col2 $title2]" \n |
||||
foreach p [lsort $projects] { |
||||
#todo - provide some basic info for each - last build time? last time-to-build? |
||||
append output "[overtype::left $col1 $p] [overtype::right $col2 [dict get $psizes $p]]" \n |
||||
} |
||||
append output "Total Source size: $total_source_size bytes" \n |
||||
return $output |
||||
} |
||||
|
||||
|
||||
namespace eval collection { |
||||
namespace export * |
||||
proc _default {{glob {}}} { |
||||
if {![string length $glob]} { |
||||
set glob * |
||||
} |
||||
#todo - review - we want the furthest not the closest if we are potentially inside a buildsuite project |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
set projectdir [dict get $pathinfo closest] |
||||
set suites_dir [file join $projectdir src buildsuites] |
||||
if {![file exists $suites_dir]} { |
||||
puts stderr "No buildsuites folder found at $suites_dir" |
||||
return |
||||
} |
||||
set suites [lsort [glob -dir $suites_dir -type d -tails *]] |
||||
if {$glob ne "*"} { |
||||
set suites [lsearch -all -inline $suites $glob] |
||||
} |
||||
return $suites |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::buildsuite [namespace eval punk::mix::commandset::buildsuite { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -1,92 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::debug 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::debug { |
||||
namespace export get paths |
||||
namespace path ::punk::mix::cli |
||||
|
||||
#Except for 'get' - all debug commands should emit to stdout |
||||
proc paths {} { |
||||
set out "" |
||||
puts stdout "find_repos output:" |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
pdict $pathinfo |
||||
|
||||
set projectdir [dict get $pathinfo closest] |
||||
set modulefolders [lib::find_source_module_paths $projectdir] |
||||
puts stdout "modulefolders: $modulefolders" |
||||
|
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
puts stdout "get_template_basefolders output:" |
||||
pdict $template_base_dict |
||||
return |
||||
} |
||||
|
||||
#call other debug command - but capture stdout as return value |
||||
proc get {args} { |
||||
set nm [lindex $args 0] |
||||
if {$nm eq ""} { |
||||
set nscmds [info commands [namespace current]::*] |
||||
set cmds [lmap v $nscmds {namespace tail $v}] |
||||
error "debug.get missing debug command argument. Try one of: $cmds" |
||||
return |
||||
} |
||||
set nextargs [lrange $args 1 end] |
||||
set out "" |
||||
if {[info commands [namespace current]::$nm] ne ""} { |
||||
append out [runout -n -tcl [namespace current]::$nm {*}$nextargs] \n |
||||
} else { |
||||
set nscmds [info commands [namespace current]::*] |
||||
set cmds [lmap v $nscmds {namespace tail $v}] |
||||
error "debug.get invalid debug command '$nm' Try one of: $cmds" |
||||
} |
||||
return $out |
||||
} |
||||
namespace eval lib { |
||||
|
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::debug [namespace eval punk::mix::commandset::debug { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -1,286 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::doc 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
package require punk::path ;# for treefilenames, relative |
||||
package require punk::repo |
||||
package require punk::docgen ;#inline doctools - generate doctools .man files at src/docgen prior to using kettle to producing .html .md etc |
||||
package require punk::mix::cli ;#punk::mix::cli::lib used for kettle_call |
||||
#package require punk::mix::util ;#for path_relative |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::doc { |
||||
namespace export * |
||||
|
||||
proc _default {} { |
||||
puts "documentation subsystem" |
||||
puts "commands: doc.build" |
||||
puts " build documentation from src/doc to src/embedded using the kettle build tool" |
||||
} |
||||
|
||||
proc build {} { |
||||
puts "build docs" |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to build docs" |
||||
return |
||||
} |
||||
#user may delete the comment containing "--- punk::docgen::overwrites" and then manually edit, and we won't overwrite |
||||
#we still generate output in src/docgen so user can diff and manually update if thats what they prefer |
||||
set oldfiles [punk::path::treefilenames $projectdir/src/doc _module_*.man] |
||||
foreach maybedoomed $oldfiles { |
||||
set fd [open $maybedoomed r] |
||||
set data [read $fd] |
||||
close $fd |
||||
if {[string match "*--- punk::docgen overwrites *" $data]} { |
||||
file delete -force $maybedoomed |
||||
} |
||||
} |
||||
set generated [lib::do_docgen modules] |
||||
if {[dict get $generated count] > 0} { |
||||
#review |
||||
set doclist [dict get $generated docs] |
||||
set source_base [dict get $generated base] |
||||
set target_base $projectdir/src/doc |
||||
foreach dinfo $doclist { |
||||
lassign $dinfo module fpath |
||||
set relpath [punk::path::relative $source_base $fpath] |
||||
set relfolder [file dirname $relpath] |
||||
if {$relfolder eq "."} { |
||||
set relfolder "" |
||||
} |
||||
file mkdir [file join $target_base $relfolder] |
||||
set target [file join $target_base $relfolder _module_[file tail $fpath]] |
||||
puts stderr "target --> $target" |
||||
if {![file exists $target]} { |
||||
file copy $fpath $target |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {[file exists $projectdir/src/doc]} { |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||
$event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
} { |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "BUILDING DOCS at $projectdir/src/embedded from src/doc" |
||||
if {[catch { |
||||
|
||||
punk::mix::cli::lib::kettle_call lib doc |
||||
#Kettle doc |
||||
|
||||
} errM]} { |
||||
$event targetset_end FAILED -note "kettle_build_doc failed: $errM" |
||||
} else { |
||||
$event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "No change detected in src/doc" |
||||
$event targetset_end SKIPPED |
||||
} |
||||
$event end |
||||
$event destroy |
||||
$installer destroy |
||||
cd $original_wd |
||||
} else { |
||||
puts stderr "No doc folder found at $projectdir/src/doc" |
||||
} |
||||
} |
||||
proc status {} { |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to check doc status" |
||||
return |
||||
} |
||||
if {![file exists $projectdir/src/doc]} { |
||||
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||
return $result |
||||
} |
||||
set original_wd [pwd] |
||||
cd $projectdir/src |
||||
puts stdout "Testing status of doctools source location $projectdir/src/doc ..." |
||||
flush stdout |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
#use same virtual id "kettle_build_doc" as project.new - review best way to keep identifiers like this in sync. |
||||
$event targetset_init QUERY kettle_build_doc ;#usually VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated - but here we use QUERY to ensure no writes to .punkcheck |
||||
set last_completion [$event targetset_last_complete] |
||||
|
||||
if {[llength $last_completion]} { |
||||
#adding a source causes it to be checksummed |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
set changeinfo [$event targetset_source_changes] |
||||
if {\ |
||||
[llength [dict get $changeinfo changed]]\ |
||||
} { |
||||
puts stdout "changed" |
||||
puts stdout $changeinfo |
||||
} else { |
||||
puts stdout "No changes detected in $projectdir/src/doc tree" |
||||
} |
||||
} else { |
||||
#no previous completion-record for this target - must assume changed - no need to trigger checksumming |
||||
puts stdout "No existing record of doc build in .punkcheck. Assume it needs to be rebuilt." |
||||
} |
||||
|
||||
|
||||
$event destroy |
||||
$installer destroy |
||||
|
||||
cd $original_wd |
||||
} |
||||
proc validate {} { |
||||
#todo - run and validate punk::docgen output |
||||
set projectdir [punk::repo::find_project] |
||||
if {$projectdir eq ""} { |
||||
puts stderr "No current project dir - unable to check doc status" |
||||
return |
||||
} |
||||
if {![file exists $projectdir/src/doc]} { |
||||
set result "No documentation source found. Expected .man files in doctools format at $projectdir/src/doc" |
||||
return $result |
||||
} |
||||
set original_wd [pwd] |
||||
set docroot $projectdir/src/doc |
||||
cd $docroot |
||||
|
||||
dtplite validate $docroot |
||||
|
||||
#punk::mix::cli::lib::kettle_call lib validate-doc |
||||
|
||||
cd $original_wd |
||||
} |
||||
|
||||
namespace eval collection { |
||||
variable pkg |
||||
set pkg punk::mix::commandset::doc |
||||
|
||||
namespace export * |
||||
namespace path [namespace parent] |
||||
|
||||
} |
||||
|
||||
namespace eval lib { |
||||
variable pkg |
||||
set pkg punk::mix::commandset::doc |
||||
proc do_docgen {{project_subpath modules}} { |
||||
#Extract doctools comments from source code |
||||
set projectdir [punk::repo::find_project] |
||||
set output_base [file join $projectdir src docgen] |
||||
set codesource_path [file join $projectdir $project_subpath] |
||||
if {![file isdirectory $codesource_path]} { |
||||
puts stderr "WARNING punk::mix::commandset::doc unable to find codesource_path $codesource_path during do_docgen - skipping inline doctools generation" |
||||
return |
||||
} |
||||
if {[file isdirectory $output_base]} { |
||||
if {[catch { |
||||
file delete -force $output_base |
||||
}]} { |
||||
error "do_docgen failed to delete existing output base folder: $output_base" |
||||
} |
||||
} |
||||
file mkdir $output_base |
||||
|
||||
set matched_paths [punk::path::treefilenames $codesource_path *.tm -antiglob_paths {**/mix/templates/** **/mixtemplates/**}] |
||||
set count 0 |
||||
set newdocs [list] |
||||
set docgen_header_comments "" |
||||
append docgen_header_comments {[comment {--- punk::docgen generated from inline doctools comments ---}]} \n |
||||
append docgen_header_comments {[comment {--- punk::docgen DO NOT EDIT DOCS HERE UNLESS YOU REMOVE THESE COMMENT LINES ---}]} \n |
||||
append docgen_header_comments {[comment {--- punk::docgen overwrites this file ---}]} \n |
||||
foreach fullpath $matched_paths { |
||||
set doctools [punk::docgen::get_doctools_comments $fullpath] |
||||
if {$doctools ne ""} { |
||||
set fname [file tail $fullpath] |
||||
set mod_tail [file rootname $fname] |
||||
set relpath [punk::path::relative $codesource_path [file dirname $fullpath]] |
||||
if {$relpath eq "."} { |
||||
set relpath "" |
||||
} |
||||
set tailsegs [file split $relpath] |
||||
set module_fullname [join $tailsegs ::]::$mod_tail |
||||
set target_docname $fname.man |
||||
set this_outdir [file join $output_base $relpath] |
||||
|
||||
if {[string length $fname] > 99} { |
||||
#output needs to be tarballed to do checksum change tests in a reasonably straightforward and not-too-terribly slow way. |
||||
#hack - review. Determine exact limit - test if tcllib tar fixed or if it's a limit of the particular tar format |
||||
#work around tcllib tar filename length limit ( somewhere around 100?) This seems to be a limit on the length of a particular segment in the path.. not whole path length? |
||||
#this case only came up because docgen used to path munge to long filenames - but left because we know there is a limit and renaming fixes it - even if it's ugly - but still allows doc generation. |
||||
#review - if we're checking fname - should also test length of whole path and determine limits for tar |
||||
package require md5 |
||||
set target_docname [md5::md5 -hex $fullpath]_overlongfilename.man |
||||
puts stderr "WARNING - overlong file name - renaming $fullpath" |
||||
puts stderr " to [file dirname $fullpath]/$target_docname" |
||||
} |
||||
|
||||
file mkdir $this_outdir |
||||
puts stdout "saving [string length $doctools] bytes of doctools output from file $relpath/$fname" |
||||
set outfile [file join $this_outdir $target_docname] |
||||
set fd [open $outfile w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $docgen_header_comments$doctools |
||||
close $fd |
||||
incr count |
||||
lappend newdocs [list $module_fullname $outfile] |
||||
} |
||||
} |
||||
return [list count $count docs $newdocs base $output_base] |
||||
} |
||||
|
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::doc [namespace eval punk::mix::commandset::doc { |
||||
variable pkg punk::mix::commandset::doc |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -1,188 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::layout 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
#sort of a circular dependency when commandset loaded by punk::mix::cli - that's ok, but this could theoretically be loaded by another cli and with another base |
||||
package require punk::mix |
||||
package require punk::mix::base |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::layout { |
||||
namespace export * |
||||
|
||||
#per layout functions |
||||
proc files {layout} { |
||||
set allfiles [lib::layout_all_files $layout] |
||||
return [join $allfiles \n] |
||||
} |
||||
proc templatefiles {layout} { |
||||
set templatefiles [lib::layout_scan_for_template_files $layout] |
||||
return [join $templatefiles \n] |
||||
} |
||||
proc templatefiles.relative {layout} { |
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
|
||||
set bases_containing_layout [list] |
||||
dict for {tbase folderinfo} $template_base_dict { |
||||
if {[file exists $tbase/layouts/$layout]} { |
||||
lappend bases_containing_layout $tbase |
||||
} |
||||
} |
||||
if {![llength $bases_containing_layout]} { |
||||
puts stderr "Unable to locate folder for layout '$layout'" |
||||
puts stderr "searched [dict size $template_base_dict] template folders" |
||||
return |
||||
} |
||||
set tpldir [lindex $bases_containing_layout end] |
||||
|
||||
set layout_base $tpldir/layouts |
||||
set layout_dir [file join $layout_base $layout] |
||||
|
||||
set stripprefix [file normalize $layout_dir] |
||||
set templatefiles [lib::layout_scan_for_template_files $layout] |
||||
set tails [list] |
||||
foreach templatefullpath $templatefiles { |
||||
lappend tails [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] |
||||
} |
||||
return [join $tails \n] |
||||
} |
||||
|
||||
#layout collection functions - to be imported with punk::overlay::import_commandset separately |
||||
namespace eval collection { |
||||
namespace export * |
||||
proc _default {{glob {}}} { |
||||
if {![string length $glob]} { |
||||
set glob * |
||||
} |
||||
set layouts [list] |
||||
#set tplfolderdict [punk::cap::call_handler punk.templates folders] |
||||
set tplfolderdict [punk::mix::base::lib::get_template_basefolders] |
||||
dict for {tdir folderinfo} $tplfolderdict { |
||||
set layout_base $tdir/layouts |
||||
#collect all layouts and use lsearch glob rather than the filesystem glob (avoid issues with dotted folder names) |
||||
set all_layouts [lsort [glob -nocomplain -dir $layout_base -type d -tail *]] |
||||
foreach match [lsearch -all -inline $all_layouts $glob] { |
||||
lappend layouts [list $match $folderinfo] |
||||
} |
||||
} |
||||
return [join [lsort -index 0 $layouts] \n] |
||||
} |
||||
|
||||
} |
||||
namespace eval lib { |
||||
proc layout_all_files {layout} { |
||||
set tplbasedict [punk::mix::base::lib::get_template_basefolders] |
||||
set layouts_found [list] |
||||
dict for {tplbase folderinfo} $tplbasedict { |
||||
if {[file isdirectory $tplbase/layouts/$layout]} { |
||||
lappend layouts_found $tplbase/layouts/$layout |
||||
} |
||||
} |
||||
if {![llength $layouts_found]} { |
||||
puts stderr "layout '$layout' not found." |
||||
puts stderr "searched [dict size $tplbasedict] template folders" |
||||
dict for {tplbase pkg} $tplbasedict { |
||||
puts stderr " - $tplbase $pkg" |
||||
} |
||||
return |
||||
} |
||||
set layoutfolder [lindex $layouts_found end] |
||||
|
||||
if {![file isdirectory $layoutfolder]} { |
||||
puts stderr "layout '$layout' not found in /layouts within one of template_folders. (get_template_folder returned: $tplbasedict)" |
||||
} |
||||
set file_list [list] |
||||
util::foreach-file $layoutfolder path { |
||||
lappend file_list $path |
||||
} |
||||
|
||||
return $file_list |
||||
} |
||||
|
||||
# |
||||
#todo - allow specifying which package the layout is from: e.g "punk::mix::templates project" ?? |
||||
proc layout_scan_for_template_files {layout {tags {}}} { |
||||
#equivalent for projects? punk::mix::commandset::module::lib::templates_dict -scriptpath "" |
||||
set tplbasedict [punk::mix::base::lib::get_template_basefolders] |
||||
set layouts_found [list] |
||||
dict for {tpldir pkg} $tplbasedict { |
||||
if {[file isdirectory $tpldir/layouts/$layout]} { |
||||
lappend layouts_found $tpldir/layouts/$layout |
||||
} |
||||
} |
||||
if {![llength $layouts_found]} { |
||||
puts stderr "layout '$layout' not found." |
||||
puts stderr "searched [dict size $tplbasedict] template folders" |
||||
dict for {tpldir pkg} $tplbasedict { |
||||
puts stderr " - $tpldir $pkg" |
||||
} |
||||
return |
||||
} |
||||
set layoutfolder [lindex $layouts_found end] |
||||
|
||||
#use last matching layout found. review silent if multiple? |
||||
if {![llength $tags]} { |
||||
#todo - get standard tags from somewhere |
||||
set tagnames [list project] |
||||
foreach tn $tagnames { |
||||
lappend tags [string cat % $tn %] |
||||
} |
||||
} |
||||
set file_list [list] |
||||
util::foreach-file $layoutfolder path { |
||||
set fd [open $path r] |
||||
fconfigure $fd -translation binary |
||||
set data [read $fd] |
||||
close $fd |
||||
foreach tag $tags { |
||||
if {[string match "*$tag*" $data]} { |
||||
lappend file_list $path |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $file_list |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::layout [namespace eval punk::mix::commandset::layout { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -1,529 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::loadedlib 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::ns |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::loadedlib { |
||||
namespace export * |
||||
#search automatically wrapped in * * - can contain inner * ? globs |
||||
proc search {searchstring} { |
||||
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything |
||||
if {[catch {package require natsort}]} { |
||||
set has_natsort 0 |
||||
} else { |
||||
set has_natsort 1 |
||||
} |
||||
if {[regexp {[?*]} $searchstring]} { |
||||
#caller has specified specific glob pattern - use it |
||||
#todo - respect supplied case only if uppers present? require another flag? |
||||
set matches [lsearch -all -inline -nocase [package names] $searchstring] |
||||
} else { |
||||
#make it easy to search for anything |
||||
set matches [lsearch -all -inline -nocase [package names] "*$searchstring*"] |
||||
} |
||||
|
||||
set matchinfo [list] |
||||
foreach m $matches { |
||||
set versions [package versions $m] |
||||
if {$has_natsort} { |
||||
set versions [natsort::sort $versions] |
||||
} else { |
||||
set versions [lsort $versions] |
||||
} |
||||
lappend matchinfo [list $m $versions] |
||||
} |
||||
return [join [lsort $matchinfo] \n] |
||||
} |
||||
proc loaded.search {searchstring} { |
||||
set search_result [search $searchstring] |
||||
set all_libs [split $search_result \n] |
||||
set col1items [list] |
||||
set col2items [list] |
||||
set col3items [list] |
||||
foreach libinfo $all_libs { |
||||
if {[string trim $libinfo] eq ""} { |
||||
continue |
||||
} |
||||
set versions [lassign $libinfo libname] |
||||
if {[set ver [package provide $libname]] ne ""} { |
||||
lappend col1items $libname |
||||
lappend col2items $versions |
||||
lappend col3items $ver |
||||
} |
||||
} |
||||
|
||||
package require overtype |
||||
set title1 "Library" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {string length $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
set title2 "Versions Avail." |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {string length $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
set title3 "Loaded Version" |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {string length $v}]] |
||||
set col3 [string repeat " " $widest3] |
||||
|
||||
|
||||
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}] |
||||
|
||||
set table "" |
||||
append table [string repeat - $tablewidth] \n |
||||
append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n |
||||
append table [string repeat - $tablewidth] \n |
||||
foreach c1 $col1items c2 $col2items c3 $col3items { |
||||
append table "[overtype::left $col1 $c1] [overtype::left $col2 $c2] [overtype::left $col3 $c3]" \n |
||||
} |
||||
|
||||
return $table |
||||
|
||||
|
||||
set loaded_libs [list] |
||||
foreach libinfo $all_libs { |
||||
if {[string trim $libinfo] eq ""} { |
||||
continue |
||||
} |
||||
set versions [lassign $libinfo libname] |
||||
if {[set ver [package provide $libname]] ne ""} { |
||||
lappend loaded_libs "$libname $versions (loaded $ver)" |
||||
} |
||||
} |
||||
return [join $loaded_libs \n] |
||||
} |
||||
|
||||
proc info {libname} { |
||||
if {[catch {package require natsort}]} { |
||||
set has_natsort 0 |
||||
} else { |
||||
set has_natsort 1 |
||||
} |
||||
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything |
||||
set pkgsknown [package names] |
||||
if {[set posn [lsearch $pkgsknown $libname]] >= 0} { |
||||
puts stdout "Found package [lindex $pkgsknown $posn]" |
||||
} else { |
||||
puts stderr "Package not found as available library/module - check tcl::tm::list and \$auto_path" |
||||
} |
||||
set versions [package versions [lindex $libname 0]] |
||||
if {$has_natsort} { |
||||
set versions [natsort::sort $versions] |
||||
} else { |
||||
set versions [lsort $versions] |
||||
} |
||||
if {![llength $versions]} { |
||||
puts stderr "No version numbers found for library/module $libname" |
||||
return false |
||||
} |
||||
puts stdout "Versions of $libname found: $versions" |
||||
set alphaposn [lsearch $versions "999999.*"] |
||||
if {$alphaposn >= 0} { |
||||
set alpha [lindex $versions $alphaposn] |
||||
#remove and tack onto beginning.. |
||||
set versions [lreplace $versions $alphaposn $alphaposn] |
||||
set versions [list $alpha {*}$versions] |
||||
} |
||||
foreach ver $versions { |
||||
set loadinfo [package ifneeded $libname $ver] |
||||
puts stdout "$libname $ver" |
||||
puts stdout "--- 'package ifneeded' script ---" |
||||
puts stdout $loadinfo |
||||
puts stdout "---" |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc copyasmodule {library modulefoldername args} { |
||||
set defaults [list -askme 1] |
||||
set opts [dict merge $defaults $args] |
||||
set opt_askme [dict get $opts -askme] |
||||
|
||||
if {[catch {package require natsort}]} { |
||||
set has_natsort 0 |
||||
} else { |
||||
set has_natsort 1 |
||||
} |
||||
|
||||
catch {package require frobznodule666} ;#ensure pkg system has loaded/searched for everything |
||||
|
||||
if {[file pathtype $modulefoldername] eq "absolute"} { |
||||
if {![file exists $modulefoldername]} { |
||||
error "Path '$modulefoldername' not found. Enter a fully qualified path, or just the tail such as 'modules' if you are within the project to use <projectdir>/src/modules" |
||||
} |
||||
#use the target folder as the source of projectdir info |
||||
set pathinfo [punk::repo::find_repos $modulefoldername] |
||||
set projectdir [dict get $pathinfo closest] |
||||
set modulefolder_path $modulefoldername |
||||
} else { |
||||
#use the current working directory as the source of projectdir info |
||||
set pathinfo [punk::repo::find_repos [pwd]] |
||||
set projectdir [dict get $pathinfo closest] |
||||
if {$projectdir ne ""} { |
||||
set modulefolders [punk::mix::cli::lib::find_source_module_paths $projectdir] |
||||
foreach k [list modules vendormodules] { |
||||
set knownfolder [file join $projectdir src $k] |
||||
if {$knownfolder ni $modulefolders} { |
||||
lappend modulefolders $knownfolder |
||||
} |
||||
} |
||||
set mtails [list] |
||||
foreach path $modulefolders { |
||||
lappend mtails [file tail $path] |
||||
} |
||||
|
||||
#special case bootsupport/modules so it can be referred to as just bootsupport or bootsupport/modules |
||||
lappend modulefolders [file join $projectdir src bootsupport/modules] |
||||
|
||||
if {$modulefoldername ni $mtails && $modulefoldername ni "bootsupport bootsupport/modules"} { |
||||
set msg "Suplied modulefoldername '$modulefoldername' doesn't appear to be a known module folder within the project at $projectdir\n" |
||||
append msg "Known module folders: [lsort $mtails]\n" |
||||
append msg "Use a name from the above list, or a fully qualified path\n" |
||||
error $msg |
||||
} |
||||
|
||||
if {$modulefoldername eq "bootsupport"} { |
||||
set modulefoldername "bootsupport/modules" |
||||
} |
||||
set modulefolder_path [file join $projectdir src $modulefoldername] |
||||
} else { |
||||
set msg "No current project found at or above current directory\n" |
||||
append msg "Supplied modulefoldername '$modulefoldername' is a name or relative path - cannot use when outside a project." \n |
||||
append msg "Supply an absolute path for the target modulefolder, or try again from within a project directory" \n |
||||
error $msg |
||||
} |
||||
} |
||||
puts stdout "-----------------------------" |
||||
if {$projectdir ne ""} { |
||||
puts stdout "Using projectdir: $projectdir for lib.copyasmodule" |
||||
} else { |
||||
puts stdout "No current project." |
||||
} |
||||
puts stdout "-----------------------------" |
||||
if {![file exists $modulefolder_path]} { |
||||
error "Selected module folder path '$modulefolder_path' doesn't exist. Required subdirectories for namespaced modules will be created automatically - but base selected folder must exist first" |
||||
} |
||||
|
||||
|
||||
set libfound [lsearch -all -inline [package names] $library] |
||||
if {[llength $libfound] != 1 || ![string length $libfound]} { |
||||
error "Library must match exactly one entry in the list of package names visible to the current interpretor: found '$libfound'" |
||||
} |
||||
|
||||
set versions [package versions [lindex $libfound 0]] |
||||
if {$has_natsort} { |
||||
set versions [natsort::sort $versions] |
||||
} else { |
||||
set versions [lsort $versions] |
||||
} |
||||
if {![llength $versions]} { |
||||
error "No version numbers found for library/module $libfound - sorry, you will need to copy it across manually" |
||||
} |
||||
puts stdout "Versions of $libfound found: $versions" |
||||
set alphaposn [lsearch $versions "999999.*"] |
||||
if {$alphaposn >= 0} { |
||||
set alpha [lindex $versions $alphaposn] |
||||
#remove and tack onto beginning.. |
||||
set versions [lreplace $versions $alphaposn $alphaposn] |
||||
set versions [list $alpha {*}$versions] |
||||
} |
||||
|
||||
set ver [lindex $versions end] ;# todo - make selectable! don't assume tail is latest?.. package vcompare? |
||||
if {[llength $versions] > 1} { |
||||
puts stdout "Version selected: $ver" |
||||
} |
||||
|
||||
set loadinfo [package ifneeded $libfound $ver] |
||||
set loadinfo [string map [list \r\n \n] $loadinfo] |
||||
set loadinfo_lines [split $loadinfo \n] |
||||
if {[catch {llength $loadinfo}]} { |
||||
set loadinfo_is_listshaped 0 |
||||
} else { |
||||
set loadinfo_is_listshaped 1 |
||||
} |
||||
|
||||
#check for redirection to differently cased version of self - this is only detected if this is the only command in the package ifneeded result |
||||
#- must have matching version. REVIEW this requirement. Is there a legitimate reason to divert to a differently cased other-version? |
||||
set is_package_require_self_recased 0 |
||||
set is_package_require_diversion 0 |
||||
set lib_diversion_name "" |
||||
if {[llength $loadinfo_lines] == 1} { |
||||
#e.g Thread 3.0b1 diverts to thread 3.0b1 |
||||
set line1 [lindex $loadinfo_lines 0] |
||||
#check if multiparted with semicolon |
||||
#We need to distinguish "package require <lib> <ver>; more stuff" from "package require <lib> ver> ;" possibly with trailing comment? |
||||
set parts [list] |
||||
if {[regexp {;} $line1]} { |
||||
foreach p [split $line1 {;}] { |
||||
set p [string trim $p] |
||||
if {[string length $p]} { |
||||
#only append parts with some content that doesn't look like a comment |
||||
if {![string match "#*" $p]} { |
||||
lappend parts $p |
||||
} |
||||
} |
||||
} |
||||
|
||||
} |
||||
if {[llength $parts] == 1} { |
||||
#seems like a lone package require statement. |
||||
#check if package require, package\trequire etc |
||||
if {[string match "package*require" [lrange $line1 0 1]]} { |
||||
set is_package_require_diversion 1 |
||||
if {[lindex $line1 2] eq "-exact"} { |
||||
#package require -exact <pkg> <ver> |
||||
set lib_diversion_name [lindex $line1 3] |
||||
#check not an exact match - but is a -nocase match - i.e differs in case only |
||||
if {($lib_diversion_name ne $libfound) && [string match -nocase $lib_diversion_name $libfound]} { |
||||
if {[lindex $line1 4] eq $ver} { |
||||
set is_package_require_self_recased 1 |
||||
} |
||||
} |
||||
} else { |
||||
#may be package require <pkg> <ver> |
||||
#or package require <pkg> <ver> ?<ver>?... |
||||
set lib_diversion_name [lindex $line1 2] |
||||
#check not an exact match - but is a -nocase match - i.e differs in case only |
||||
if {($lib_diversion_name ne $libfound) && [string match -nocase $lib_diversion_name $libfound]} { |
||||
set requiredversions [lrange $line1 3 end] |
||||
if {$ver in $requiredversions} { |
||||
set is_package_require_self_recased 1 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$is_package_require_self_recased && [string length $lib_diversion_name]} { |
||||
#we only follow one level of package require redirection - seems unlikely/imprudent to follow arbitrarily in a while loop(?) |
||||
set libfound $lib_diversion_name |
||||
set loadinfo [package ifneeded $libfound $ver] |
||||
set loadinfo [string map [list \r\n \n] $loadinfo] |
||||
set loadinfo_lines [split $loadinfo \n] |
||||
if {[catch {llength $loadinfo}]} { |
||||
set loadinfo_is_listshaped 0 |
||||
} else { |
||||
set loadinfo_is_listshaped 1 |
||||
} |
||||
|
||||
|
||||
} else { |
||||
if {$is_package_require_diversion} { |
||||
#single |
||||
#for now - we'll abort and tell the user to run again with specified pkg/version |
||||
#We could automate - but it seems likely to be surprising. |
||||
puts stderr "Loadinfo for $libfound seems to be diverting to another pkg/version: $loadinfo_lines" |
||||
puts stderr "Review and consider trying with the pkg/version described in the result above." |
||||
return |
||||
} |
||||
} |
||||
|
||||
|
||||
if {$loadinfo_is_listshaped && ([llength $loadinfo] == 2 && [lindex $loadinfo 0] eq "source")} { |
||||
set source_file [lindex $loadinfo 1] |
||||
} elseif {[string match "*source*" $loadinfo]} { |
||||
set parts [list] |
||||
foreach ln $loadinfo_lines { |
||||
if {![string length $ln]} {continue} |
||||
lappend parts {*}[split $ln ";"] |
||||
} |
||||
set sources_found [list] |
||||
set loads_found [list] |
||||
set dependencies [list] |
||||
set incomplete_lines [list] |
||||
foreach p $parts { |
||||
set p [string trim $p] |
||||
if {![string length $p]} { |
||||
continue ;#empty line or trailing colon |
||||
} |
||||
if {[string match "*tclPkgSetup*" $p]} { |
||||
puts stderr "Unable to process load script for library $libfound" |
||||
puts stderr "The library appears to use the deprecated tcl library support utility 'tclPkgSetup'" |
||||
return false |
||||
} |
||||
if {![::info complete $p]} { |
||||
# |
||||
#probably a perfectly valid script - but slightly more complicated than we can handle |
||||
#better to defer to manual processing |
||||
lappend incomplete_lines $p |
||||
continue |
||||
} |
||||
if {[lindex $p 0] eq "source"} { |
||||
#may have args.. e.g -encoding utf-8 |
||||
lappend sources_found [lindex $p end] |
||||
} |
||||
if {[lindex $p 0] eq "load"} { |
||||
lappend loads_found [lrange $p 1 end] |
||||
} |
||||
if {[lrange $p 0 1] eq "package require"} { |
||||
lappend dependencies [lrange $p 2 end] |
||||
} |
||||
} |
||||
if {[llength $incomplete_lines]} { |
||||
puts stderr "unable to interpret load script for library $libfound" |
||||
puts stderr "Load info: $loadinfo" |
||||
return false |
||||
} |
||||
if {[llength $loads_found]} { |
||||
puts stderr "package $libfound appears to have binary components" |
||||
foreach l $loads_found { |
||||
puts stderr " binary - $l" |
||||
} |
||||
foreach s $sources_found { |
||||
puts stderr " script - $s" |
||||
} |
||||
puts stderr "Unable to automatically copy binary libraries to your module folder." |
||||
return false |
||||
} |
||||
|
||||
if {[llength $sources_found] != 1} { |
||||
puts stderr "sorry - unable to interpret source library location" |
||||
puts stderr "Only 1 source supported for now" |
||||
puts stderr "Load info: $loadinfo" |
||||
return false |
||||
} |
||||
if {[llength $dependencies]} { |
||||
#todo - check/ignore if dependency is Tcl ? |
||||
puts stderr "WARNING the package appears to depend on at least one other. Review and copy dependencies if required." |
||||
foreach d $dependencies { |
||||
puts stderr " - $d" |
||||
} |
||||
} |
||||
|
||||
set source_file [lindex $sources_found 0] |
||||
} else { |
||||
puts stderr "sorry - unable to interpret source library location" |
||||
puts stderr "Load info: $loadinfo" |
||||
return false |
||||
} |
||||
|
||||
# -- --------------------------------------- |
||||
#Analyse source file |
||||
if {![file exists $source_file]} { |
||||
error "Unable to verify source file existence at: $source_file" |
||||
} |
||||
set source_data [fcat -translation binary $source_file] |
||||
if {![string match "*package provide*" $source_data]} { |
||||
puts stderr "Sorry - unable to verify source file contains 'package provide' statement of some sort - copy manually" |
||||
return false |
||||
} else { |
||||
if {![string match "*$libfound*" $source_data]} { |
||||
# as an exception - look for the specific 'package provide $pkg $version' as occurs in the auto-name auto-version modules |
||||
#e.g anyname-0.1.tm example |
||||
if {![string match "*package provide \$pkg \$version*" $source_data]} { |
||||
puts stderr "Sorry - unable to verify source file contains 'package provide' and '$libfound' - copy manually" |
||||
return false |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
if {[string match "*lappend ::auto_path*" $source_data] || [string match "*lappend auto_path*" $source_data] || [string match "*set ::auto_path*" $source_data]} { |
||||
puts stderr "Sorry - '$libfound' source file '$source_file' appears to rely on ::auto_path and can't be automatically copied as a .tm module" |
||||
puts stderr "Copy the library across to a lib folder instead" |
||||
return false |
||||
} |
||||
# -- --------------------------------------- |
||||
|
||||
set moduleprefix [punk::ns::nsprefix $libfound] |
||||
if {[string length $moduleprefix]} { |
||||
set moduleprefix_parts [punk::ns::nsparts $moduleprefix] |
||||
set relative_path [file join {*}$moduleprefix_parts] |
||||
} else { |
||||
set relative_path "" |
||||
} |
||||
set pkgtail [punk::ns::nstail $libfound] |
||||
set target_path [file join $modulefolder_path $relative_path ${pkgtail}-${ver}.tm] |
||||
|
||||
if {$opt_askme} { |
||||
puts stdout "WARNING - you should check that there aren't extra required files for the library/modules" |
||||
puts stdout "" |
||||
puts stdout "This is not intended for binary modules - use at own risk and check results" |
||||
puts stdout "" |
||||
puts stdout "Base module path: $modulefolder_path" |
||||
puts stdout "Target path : $target_path" |
||||
puts stdout "results of 'package ifneeded $libfound'" |
||||
puts stdout "---" |
||||
puts stdout "$loadinfo" |
||||
puts stdout "---" |
||||
puts stdout "Proceed to create ${pkgtail}-${ver}.tm module? Y|N" |
||||
set stdin_state [fconfigure stdin] |
||||
fconfigure stdin -blocking 1 |
||||
set answer [string tolower [gets stdin]] |
||||
fconfigure stdin -blocking [dict get $stdin_state -blocking] |
||||
if {$answer ne "y"} { |
||||
puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
|
||||
if {![file exists $modulefolder_path]} { |
||||
puts stdout "Creating module base folder at $modulefolder_path" |
||||
file mkdir $modulefolder_path |
||||
} |
||||
if {![file exists [file dirname $target_path]]} { |
||||
puts stdout "Creating relative folder at [file dirname $target_path]" |
||||
file mkdir [file dirname $target_path] |
||||
} |
||||
|
||||
if {[file exists $target_path]} { |
||||
puts stdout "WARNING - module already exists at $target_path" |
||||
if {$opt_askme} { |
||||
puts stdout "Copy anyway? Y|N" |
||||
set stdin_state [fconfigure stdin] |
||||
fconfigure stdin -blocking 1 |
||||
set answer [string tolower [gets stdin]] |
||||
fconfigure stdin -blocking [dict get $stdin_state -blocking] |
||||
if {$answer ne "y"} { |
||||
puts stderr "mix libcopy.asmodule aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
} |
||||
|
||||
file copy -force $source_file $target_path |
||||
|
||||
return $target_path |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::loadedlib [namespace eval punk::mix::commandset::loadedlib { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -1,419 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::module 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::module { |
||||
namespace export * |
||||
|
||||
proc paths {} { |
||||
set roots [punk::repo::find_repos ""] |
||||
set project [lindex [dict get $roots project] 0] |
||||
if {$project ne ""} { |
||||
set is_project 1 |
||||
set searchbase $project |
||||
} else { |
||||
set is_project 0 |
||||
set searchbase [pwd] |
||||
} |
||||
|
||||
if {[catch { |
||||
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $searchbase] |
||||
} errMsg]} { |
||||
set source_module_folderlist [list] |
||||
} |
||||
|
||||
set tm_folders [tcl::tm::list] |
||||
package require overtype |
||||
|
||||
set result "" |
||||
if {$is_project} { |
||||
append result "Project module source paths:" \n |
||||
foreach f $source_module_folderlist { |
||||
append result "$f" \n |
||||
} |
||||
} |
||||
append result \n |
||||
append result "tcl::tm::list" \n |
||||
foreach f $tm_folders { |
||||
if {$is_project} { |
||||
if {[punk::mix::cli::lib::path_a_aboveorat_b $project $f]} { |
||||
set pinfo "(within project)" |
||||
} else { |
||||
set pinfo "" |
||||
} |
||||
} else { |
||||
set pinfo "" |
||||
} |
||||
set warning "" |
||||
if {![file isdirectory $f]} { |
||||
set warning "(PATH NOT FOUND)" |
||||
} |
||||
append result "$f $pinfo $warning" \n |
||||
} |
||||
|
||||
|
||||
return $result |
||||
} |
||||
#require current dir when calling to be the projectdir, or |
||||
proc templates {args} { |
||||
set tdict [templates_dict {*}$args] |
||||
|
||||
package require overtype |
||||
set paths [dict values $tdict] |
||||
set names [dict keys $tdict] |
||||
|
||||
set title1 "Path" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $paths] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
|
||||
set title2 "Template Name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $names] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
|
||||
set tablewidth [expr {$widest1 + 1 + $widest2}] |
||||
set table "" |
||||
append table [string repeat - $tablewidth] \n |
||||
append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2]" \n |
||||
append table [string repeat - $tablewidth] \n |
||||
|
||||
foreach p $paths n $names { |
||||
append table "[overtype::left $col1 $p] [overtype::left $col2 $n]" \n |
||||
} |
||||
|
||||
return $table |
||||
} |
||||
#return all module templates with repeated ones suffixed with .2 .3 etc |
||||
proc templates_dict {args} { |
||||
tailcall lib::templates_dict {*}$args |
||||
} |
||||
proc new {module args} { |
||||
set year [clock format [clock seconds] -format %Y] |
||||
set defaults [list\ |
||||
-project \uFFFF\ |
||||
-version \uFFFF\ |
||||
-license <unspecified>\ |
||||
-template module-0.0.1.tm\ |
||||
-type \uFFFF\ |
||||
-force 0\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
|
||||
#todo - review compatibility between -template and -type |
||||
#-type is the wrapping technology e.g 'plain' for none or tarjar/zipkit etc (consider also snappy/snappy-tcl) |
||||
#-template may be a folder - but only if the selected -type suports it |
||||
|
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
# option -version |
||||
# we need this value before looking at the named argument |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_version_supplied [dict get $opts -version] |
||||
if {$opt_version_supplied eq "\uFFFF"} { |
||||
set opt_version "0.1.0" |
||||
} else { |
||||
set opt_version $opt_version_supplied |
||||
if {![util::is_valid_tm_version $opt_version]} { |
||||
error "pmix module.new error - supplied -version $opt_version doesn't appear to be a valid Tcl module version" |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
#named argument |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set mversion_supplied "" ;#version supplied directly in module argument |
||||
if {[string first - $module]> 0} { |
||||
#if it has a dash then version is required to be valid |
||||
lassign [punk::mix::cli::lib::split_modulename_version $module] modulename mversion |
||||
if {![util::is_valid_tm_version $mversion]} { |
||||
error "pmix module.new error - unable to determine modulename-version from supplied value '$module'" |
||||
} |
||||
set mversion_supplied $mversion ;#record as may need to compare to version from templatefile name |
||||
set vcompare_is_mversion_bigger [package vcompare $mversion $opt_version] |
||||
if {$vcompare_is_mversion_bigger > 0} { |
||||
set opt_version $mversion; #module parameter has higher value than -version |
||||
set vmsg "from module argument: $module" |
||||
} else { |
||||
set vmsg "from -version option: $opt_version_supplied" |
||||
} |
||||
if {$opt_version_supplied ne "\uFFFF"} { |
||||
if {$vcompare_is_mversion_bigger != 0} { |
||||
#is bigger or smaller |
||||
puts stderr "module.new WARNING: version supplied in module argument as well as -version option. Using the higher version number $vmsg" |
||||
} |
||||
} |
||||
} else { |
||||
set modulename $module |
||||
} |
||||
punk::mix::cli::lib::validate_modulename $modulename -name_description "mix module.new name" |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
#options |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_project [dict get $opts -project] |
||||
set testdir [pwd] |
||||
if {![string length [set projectdir [punk::repo::find_project $testdir]]]} { |
||||
if {![string length [set projectdir [punk::repo::find_candidate $testdir]]]} { |
||||
set msg [punkc::repo::is_candidate_root_requirements_msg] |
||||
error "module.new unable to create module in projectdir:$projectdir - directory doesn't appear to meet basic standards $msg" |
||||
} |
||||
} |
||||
if {$opt_project == "\uFFFF"} { |
||||
set projectname [file tail $projectdir] |
||||
} else { |
||||
set projectname $opt_project |
||||
if {$projectname ne [file tail $projectdir]} { |
||||
error "module.new -project '$opt_project' doesn't match detected projectname '$projectname' at path: $projectdir" |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_license [dict get $opts -license] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_template [dict get $opts -template] |
||||
|
||||
set templates_dict [templates_dict] ;#possibly suffixed with .2 .3 etc |
||||
#todo - allow versionless name - pick latest which isn't suffixed with .2 etc |
||||
if {![dict exists $templates_dict $opt_template]} { |
||||
error "module.new unable to find template '$opt_template'. Known templates: [dict keys $templates_dict]" |
||||
} |
||||
set templatefile [dict get $templates_dict $opt_template] |
||||
set tpldir [file dirname $templatefile] ;#use same folder for modulename_buildversion.txt, modulename_description.txt if they exist |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_type [dict get $opts -type] |
||||
if {$opt_type eq "\uFFFF"} { |
||||
set opt_type [lindex [punk::mix::cli::lib::module_types] 0] ;#default to plain |
||||
} |
||||
if {$opt_type ni [punk::mix::cli::lib::module_types]} { |
||||
error "module.new - error - unknown -type '$opt_type' known-types: [punk::mix::cli::lib::module_types]" |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
set subpath [punk::mix::cli::lib::module_subpath $modulename] ;#commonly empty string for simple modulename e.g "mymodule" but x::mymodule has subpath 'x' and x::y::mymodule has subpath 'x/y' |
||||
if {![string length $subpath]} { |
||||
set modulefolder $projectdir/src/modules |
||||
} else { |
||||
set modulefolder $projectdir/src/modules/$subpath |
||||
} |
||||
file mkdir $modulefolder |
||||
|
||||
set moduletail [namespace tail $modulename] |
||||
set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing |
||||
|
||||
|
||||
|
||||
|
||||
set template_tail [file tail $templatefile] ;#convert template_xxx-version.tm.x to {xxx version} |
||||
set template_tail [string range $template_tail [string length template_] end] |
||||
set ext [string tolower [file extension $template_tail]] |
||||
if {$ext eq ".tm"} { |
||||
set template_modulename_part [file rootname $template_tail] |
||||
} elseif {[string is integer -strict [string range $ext 1 end]]} { |
||||
#something like modulename-0.0.1.tm.2 |
||||
#strip of last 2 dotted parts |
||||
set shortened [file rootname $template_tail] |
||||
if {![string equal -nocase [file extension $shortened] ".tm"]} { |
||||
error "module.new error: Unable to interpret filename components of template file '$templatefile' (expected .tm as second-last or last component)" |
||||
} |
||||
set template_modulename_part [file rootname $shortened] |
||||
} else { |
||||
error "module.new error: Unable to interpret filename components of template file '$templatefile'" |
||||
} |
||||
lassign [punk::mix::cli::lib::split_modulename_version $template_modulename_part] t_mname t_version |
||||
#t_version may be empty string if template is unversioned e.g template_whatever.tm |
||||
|
||||
set fd [open $templatefile r]; set template_filedata [read $fd]; close $fd |
||||
if {[string match "*$magicversion*" $template_filedata]} { |
||||
set use_magic 1 |
||||
set build_version $opt_version |
||||
set infile_version $magicversion |
||||
} else { |
||||
set use_magic 0 |
||||
if {$opt_version_supplied ne "\uFFFF"} { |
||||
set build_version $opt_version |
||||
} else { |
||||
if {[util::is_valid_tm_version $t_version]} { |
||||
if {$mversion_supplied eq ""} { |
||||
set build_version $t_version |
||||
} else { |
||||
#we have a version from the named argument 'module' |
||||
if {[package vcompare $mversion_supplied $t_version] > 0} { |
||||
set build_version $mversion_supplied |
||||
} else { |
||||
set build_version $t_version |
||||
} |
||||
} |
||||
} else { |
||||
#probably an unversioned module template |
||||
#use opt_version default from above |
||||
set build_version $opt_version |
||||
} |
||||
} |
||||
set infile_version $build_version |
||||
} |
||||
|
||||
set template_filedata [string map [list %project% $projectname %pkg% $modulename %year% $year %license% $opt_license %version% $infile_version] $template_filedata] |
||||
|
||||
set modulefile $modulefolder/${moduletail}-$infile_version.tm |
||||
if {[file exists $modulefile]} { |
||||
set errmsg "module.new error: module file $modulefile already exists - aborting" |
||||
if {[string match "*$magicversion*" $modulefile]} { |
||||
append errmsg \n "If you are attempting to create a module file with a specific version in the source-file name - you will need to use a template that doesn't contain the string '$magicversion' e.g the provided template moduleexactversion-0.0.1.tm" |
||||
} |
||||
error $errmsg |
||||
} |
||||
|
||||
|
||||
if {[file exists $tpldir/modulename_buildversion.txt]} { |
||||
set fd [open $tpldir/modulename_buildversion.txt r]; set buildversion_filedata [read $fd]; close $fd |
||||
} else { |
||||
#mix_templates_dir warns of deprecation - review |
||||
set lib_tpldir [file join [punk::mix::cli::lib::mix_templates_dir] modules];#fallback for modulename_buildversion.txt, modulename_description.txt |
||||
set fd [open $lib_tpldir/modulename_buildversion.txt r]; set buildversion_filedata [read $fd]; close $fd |
||||
} |
||||
set buildversionfile [file join $modulefolder ${moduletail}-buildversion.txt] |
||||
set existing_build_version "" |
||||
if {[file exists $buildversionfile]} { |
||||
set buildversiondata [punk::mix::util::fcat $buildversionfile] |
||||
set lines [split $buildversiondata \n] |
||||
set existing_build_version [string trim [lindex $lines 0]] |
||||
if {[package vcompare $existing_build_version $build_version] >= 0} { |
||||
#existing version in -buildversion.txt file is lower than the module version we are creating |
||||
error "module.new error: there is an existing buildversion file $buildversionfile with version $existing_build_version equal to or higher than $build_version - unable to continue" |
||||
} |
||||
} |
||||
|
||||
set existing_versions [glob -nocomplain -dir $modulefolder -tails ${moduletail}-*.tm] |
||||
#it shouldn't be possible to overmatch with the glob - because '-' is not valid in a Tcl module name |
||||
if {[llength $existing_versions]} { |
||||
set name_version_pairs [list] |
||||
lappend name_version_pairs [list $moduletail $infile_version] |
||||
foreach existing $existing_versions { |
||||
lappend name_version_pairs [punk::mix::cli::lib::split_modulename_version $existing] ;# .tm is stripped and ignored |
||||
} |
||||
set name_version_pairs [lsort -command {package vcompare} -index 1 $name_version_pairs] ;#while plain lsort will often work with versions - it can get order wrong with some - so use package vcompare |
||||
if {[lindex $name_version_pairs end] ne [list $moduletail $infile_version]} { |
||||
set thisposn [lsearch -index 1 $name_version_pairs $infile_version] |
||||
set name_version_pairs [lreplace $name_version_pairs $thisposn $thisposn] |
||||
set other_versions [lsearch -all -inline -index 1 -subindices $name_version_pairs *] |
||||
set errmsg "module.new error: There are existing modules in the target folder with higher versions than $infile_version." |
||||
append errmsg \n "Other versions found: $other_versions" |
||||
if {$magicversion in $other_versions} { |
||||
append errmsg \n "Existing build version for special source file name: '$magicversion' is: '$existing_build_version'" |
||||
append errmsg \n "If '$magicversion' file doesn't represent the latest source it should be removed or the filename and contents adjusted to be a specific version" |
||||
} |
||||
error $errmsg |
||||
} else { |
||||
puts stderr "module.new WARNING: There are existing modules in the target folder with lower versions than $infile_version - manual review recommended" |
||||
puts stderr "Other versions found: [lsearch -all -inline -index 1 -subindices [lrange $name_version_pairs 0 end-1] *]" |
||||
} |
||||
} |
||||
|
||||
|
||||
set fd [open $modulefile w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $template_filedata |
||||
close $fd |
||||
|
||||
|
||||
set buildversion_filedata [string map [list %Major.Minor.Level% $build_version] $buildversion_filedata] |
||||
set fd [open $buildversionfile w] |
||||
fconfigure $fd -translation binary |
||||
puts -nonewline $fd $buildversion_filedata |
||||
close $fd |
||||
|
||||
return [list file $modulefile version $build_version] |
||||
} |
||||
|
||||
namespace eval lib { |
||||
proc templates_dict {args} { |
||||
set defaults [list -scriptpath ""] |
||||
set opts [dict merge $defaults $args] |
||||
set opt_scriptpath [dict get $opts -scriptpath] |
||||
|
||||
set module_template_bases [list] |
||||
set tbasedict [punk::mix::base::lib::get_template_basefolders $opt_scriptpath] |
||||
dict for {tbase folderinfo} $tbasedict { |
||||
lappend module_template_bases [file join $tbase modules] |
||||
} |
||||
|
||||
|
||||
|
||||
set template_files [list] |
||||
foreach basefld $module_template_bases { |
||||
set matched_files [glob -nocomplain -dir $basefld -type f template_*] |
||||
foreach tf $matched_files { |
||||
if {[string match ignore* $tf]} { |
||||
continue |
||||
} |
||||
set ext [file extension $tf] |
||||
if {$ext in [list ".tm"]} { |
||||
lappend template_files $tf |
||||
} |
||||
} |
||||
} |
||||
|
||||
set tdict [dict create] |
||||
set seen_dict [dict create] |
||||
foreach fullpath $template_files { |
||||
set ftail [file tail $fullpath] |
||||
set tname [string range $ftail [string length template_] end] |
||||
if {![dict exists $seen_dict $tname]} { |
||||
dict set seen_dict $tname 1 |
||||
dict set tdict $tname $fullpath ; #first seen of filename gets no number |
||||
} else { |
||||
set n [dict get $seen_dict $tname] |
||||
incr n |
||||
dict incr seen_dict $tname |
||||
dict set tdict ${tname}.$n $fullpath |
||||
} |
||||
} |
||||
return $tdict |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::module [namespace eval punk::mix::commandset::module { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -1,983 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::project 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin punkshell_module_punk::mix::commandset::project 0 0.1.0] |
||||
#[copyright "2023"] |
||||
#[titledesc {pmix commandset - project}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {pmix CLI commandset - project}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::mix::commandset::project] |
||||
#[description] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::mix::commandset::project |
||||
#[para]Import into an ensemble namespace similarly to the way it is done with punk::mix::cli e.g |
||||
#[example { |
||||
# namespace eval myproject::cli { |
||||
# namespace export * |
||||
# namespace ensemble create |
||||
# package require punk::overlay |
||||
# |
||||
# package require punk::mix::commandset::project |
||||
# punk::overlay::import_commandset project . ::punk::mix::commandset::project |
||||
# punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection |
||||
# } |
||||
#}] |
||||
#[para] Where the . in the above example is the prefix/command separator |
||||
#[para]The prefix ('project' in the above example) can be any string desired to disambiguate commands imported from other commandsets. |
||||
#[para]The above results in the availability of the ensemble command: ::myproject::cli project.new, which is implemented in ::punk::mix::commandset::project::new |
||||
#[para]Similarly, procs under ::punk::mix::commandset::project::collection will be available as subcommands of the ensemble as <ensemblecommand> projects.<procname> |
||||
#[para] |
||||
#[subsection Concepts] |
||||
#[para] see punk::overlay |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::mix::commandset::project |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6 |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
#[item] [package punk::ns] |
||||
#[item] [package sqlite3] (binary) |
||||
#[item] [package overtype] |
||||
#[item] [package textutil] (tcllib) |
||||
|
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::project { |
||||
namespace export * |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::mix::commandset::project}] |
||||
#[para] core commandset functions for punk::mix::commandset::project |
||||
#[list_begin definitions] |
||||
|
||||
proc _default {} { |
||||
package require punk::ns |
||||
set dispatched_to [lindex [info level 2] 0] ;#e.g ::punk::mix::cli::project |
||||
set dispatch_tail [punk::ns::nstail $dispatched_to] |
||||
set dispatch_ensemble [punk::ns::nsprefix $dispatched_to] ;#e.g ::punk::mix::cli |
||||
set sibling_commands [namespace eval $dispatch_ensemble {namespace export}] |
||||
#todo - get separator? |
||||
set sep "." |
||||
set result [list] |
||||
foreach sib $sibling_commands { |
||||
if {[string match ${dispatch_tail}${sep}* $sib]} { |
||||
lappend result $sib |
||||
} |
||||
} |
||||
return [lsort $result] |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
proc new {newprojectpath_or_name args} { |
||||
#*** !doctools |
||||
# [call [fun new] [arg newprojectpath_or_name] [opt args]] |
||||
#new project structure - may be dedicated to one module, or contain many. |
||||
#create minimal folder structure only by specifying in args: -modules {} |
||||
if {[file pathtype $newprojectpath_or_name] eq "absolute"} { |
||||
set projectfullpath [file normalize $newprojectpath_or_name] |
||||
set projectname [file tail $projectfullpath] |
||||
set projectparentdir [file dirname $newprojectpath_or_name] |
||||
} else { |
||||
set projectfullpath [file join [pwd] $newprojectpath_or_name] |
||||
set projectname [file tail $projectfullpath] |
||||
set projectparentdir [file dirname $projectfullpath] |
||||
} |
||||
if {[file type $projectparentdir] ne "directory"} { |
||||
error "punk::mix::cli::new error: unable to determine containing folder for '$newprojectpath_or_name'" |
||||
} |
||||
|
||||
punk::mix::cli::lib::validate_projectname $projectname -name_description "punk mix project.new" |
||||
|
||||
|
||||
set defaults [list\ |
||||
-type plain\ |
||||
-empty 0\ |
||||
-force 0\ |
||||
-update 0\ |
||||
-confirm 1\ |
||||
-modules \uFFFF\ |
||||
-layout project |
||||
] ;#todo |
||||
set known_opts [dict keys $defaults] |
||||
foreach {k v} $args { |
||||
if {$k ni $known_opts} { |
||||
error "project.new error: option '$k' not known. Known options: $known_opts" |
||||
} |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_type [dict get $opts -type] |
||||
if {$opt_type ni [punk::mix::cli::lib::module_types]} { |
||||
error "pmix new error - unknown type '$opt_type' known types: [punk::mix::cli::lib::module_types]" |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_force [dict get $opts -force] |
||||
set opt_confirm [string tolower [dict get $opts -confirm]] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_modules [dict get $opts -modules] |
||||
if {[llength $opt_modules] == 1 && [lindex $opt_modules 0] eq "\uFFFF"} { |
||||
#if not specified - add a single module matching project name |
||||
set opt_modules [list $projectname] |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_layout [dict get $opts -layout] |
||||
set opt_update [dict get $opts -update] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
set fossil_prog [auto_execok fossil] |
||||
if {![string length $fossil_prog]} { |
||||
puts stderr "The fossil program was not found. A fossil executable is required to use most pmix features." |
||||
if {[string length [set scoop_prog [auto_execok scoop]]]} { |
||||
#restrict to windows? |
||||
set answer [util::askuser "scoop detected. Would you like pmix to install fossil now using scoop? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
#we don't assume 'unknown' is configured to run shell commands |
||||
if {[string length [package provide shellrun]]} { |
||||
set exitinfo [run {*}$scoop_prog install fossil] |
||||
#scoop tends to return successful exitcode (0) even when packages not found etc. - so exitinfo not much use. |
||||
puts stdout "scoop install fossil ran with result: $exitinfo" |
||||
} else { |
||||
puts stdout "Please wait while scoop runs - there may be a slight delay and then scoop output will be shown. (use punk shellrun package for )" |
||||
set result [exec {*}$scoop_prog install fossil] |
||||
puts stdout $result |
||||
} |
||||
catch {::auto_reset} ;#can be missing (unsure under what circumstances - but I've seen it raise error 'invalid command name "auto_reset"') |
||||
if {![string length [auto_execok fossil]]} { |
||||
puts stderr "Fossil still not detected. If it was successfully installed, try restarting your punk/tcl shell." |
||||
return |
||||
} |
||||
#todo - ask user if they want to configure fosssil first.. |
||||
set answer [util::askuser "Fossil command now appears to be available. You may wish to answer N to exit and customize it - but default config may be ok. Type the word 'continue' to proceed with default configuration."] |
||||
if {[string tolower $answer] ne "continue"} { |
||||
return |
||||
} |
||||
|
||||
} else { |
||||
puts stdout "See: https://fossil-scm.org/home/uv/download.html" |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
puts stdout "Consider using a package manager such as scoop: https://scoop.sh" |
||||
puts stdout "(Then: scoop install fossil)" |
||||
} |
||||
return |
||||
} |
||||
} |
||||
set startdir [pwd] |
||||
if {[set in_project [punk::repo::find_project $startdir]] ne ""} { |
||||
# use this project as source of templates |
||||
puts stdout "-------------------------------------------" |
||||
puts stdout "Currently in a project directory '$in_project'" |
||||
puts stdout "This project will be searched for templates" |
||||
puts stdout "-------------------------------------------" |
||||
} |
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
set template_bases_containing_layout [list] |
||||
dict for {tbase folderinfo} $template_base_dict { |
||||
if {[file exists $tbase/layouts/$opt_layout]} { |
||||
lappend template_bases_containing_layout $tbase |
||||
} |
||||
} |
||||
if {![llength $template_bases_containing_layout]} { |
||||
puts stderr "layout '$opt_layout' was not found in template dirs" |
||||
puts stderr "searched [dict size $template_base_dict] template folders" |
||||
dict for {tbase folderinfo} $template_base_dict { |
||||
puts stderr " - $tbase $folderinfo" |
||||
} |
||||
return |
||||
} |
||||
#review: silently use last entry which had the layout (?) |
||||
set templatebase [lindex $template_bases_containing_layout end] |
||||
|
||||
|
||||
|
||||
#todo - detect whether inside cwd-project or inside a different project |
||||
set projectdir $projectparentdir/$projectname |
||||
if {[set target_in_project [punk::repo::find_project $projectparentdir]] ne ""} { |
||||
puts stderr "Target location for new project is already within a project: $target_in_project" |
||||
error "Nested projects not yet supported aborting" |
||||
} |
||||
|
||||
|
||||
|
||||
if {[punk::repo::is_git $projectparentdir]} { |
||||
puts stderr "mix new WARNING: target project location is within a git repo based at [punk::repo::find_git $projectparentdir]" |
||||
puts stderr "The new project will create a fossil repository (which you are free to ignore - but but will be used to confirm project base)" |
||||
puts stderr "If you intend to use both git and fossil in the same project space - you should research and understand the details and any possible interactions/issues" |
||||
set answer [util::askuser "Do you want to proceed to create a project based at: $projectdir? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
set is_nested_fossil 0 ;#default assumption |
||||
if {[punk::repo::is_fossil $projectparentdir]} { |
||||
puts stderr "mix new WARNING: target project location is within an open fossil repo based at [punk::repo::find_fossil $projectparentdir] NESTED fossil repository" |
||||
if {$opt_confirm ni [list 0 no false]} { |
||||
puts stderr "If you proceed - the new project's fossil repo will be created using the --nested flag" |
||||
set answer [util::askuser "Do you want to proceed to create a NESTED project based at: $projectdir? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
set is_nested_fossil 1 |
||||
} |
||||
} |
||||
|
||||
|
||||
set project_dir_exists [file exists $projectdir] |
||||
if {$project_dir_exists && !($opt_force || $opt_update)} { |
||||
puts stderr "Unable to create new project at $projectdir - file/folder already exists use -update 1 to fill in missing items from template use -force 1 to overwrite from template" |
||||
return |
||||
} elseif {$project_dir_exists && $opt_force} { |
||||
puts stderr "mix new WARNING: -force 1 was supplied. Will copy layout $templatebase/layouts/$opt_layout using -force option to overwrite from template" |
||||
if {$opt_confirm ni [list 0 no false]} { |
||||
set answer [util::askuser "Do you want to proceed to possibly overwrite existing files in $projectdir? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
} elseif {$project_dir_exists && $opt_update} { |
||||
puts stderr "mix new WARNING: -update 1 was supplied. Will copy layout $templatebase/layouts/$opt_layout using -update option to add missing items" |
||||
} |
||||
|
||||
set fossil_repo_file "" |
||||
set is_fossil_root 0 |
||||
if {$project_dir_exists && [punk::repo::is_fossil_root $projectdir]} { |
||||
set is_fossil_root 1 |
||||
set fossil_repo_file [punk::repo::fossil_get_repository_file $projectdir] |
||||
if {$fossil_repo_file ne ""} { |
||||
set repodb_folder [file dirname $fossil_repo_file] |
||||
} |
||||
} |
||||
|
||||
if {$fossil_repo_file eq ""} { |
||||
set repodb_folder [punk::repo::fossil_get_repository_folder_for_project $projectname -parentfolder $startdir] |
||||
if {![string length $repodb_folder]} { |
||||
puts stderr "No usable repository database folder selected for $projectname.fossil file" |
||||
return |
||||
} |
||||
} |
||||
if {[file exists $repodb_folder/$projectname.fossil]} { |
||||
puts stdout "NOTICE: $repodb_folder/$projectname.fossil already exists" |
||||
if {!($opt_force || $opt_update)} { |
||||
puts stderr "-force 1 or -update 1 not specified - aborting" |
||||
return |
||||
} |
||||
} |
||||
|
||||
if {$fossil_repo_file eq ""} { |
||||
puts stdout "Initialising fossil repo: $repodb_folder/$projectname.fossil" |
||||
set fossilinit [runx -n {*}$fossil_prog init $repodb_folder/$projectname.fossil -project-name $projectname] |
||||
if {[dict get $fossilinit exitcode] != 0} { |
||||
puts stderr "fossil init failed:" |
||||
puts stderr [dict get $fossilinit stderr] |
||||
return |
||||
} else { |
||||
puts stdout "fossil init result:" |
||||
puts stdout [dict get $fossilinit stdout] |
||||
} |
||||
} |
||||
|
||||
file mkdir $projectdir |
||||
|
||||
set layout_dir $templatebase/layouts/$opt_layout |
||||
puts stdout ">>> about to call punkcheck::install $layout_dir $projectdir" |
||||
set resultdict [dict create] |
||||
set antipaths [list\ |
||||
src/doc/*\ |
||||
src/doc/include/*\ |
||||
] |
||||
|
||||
#default antiglob_dir_core will stop .fossil* from being updated - which is generally desirable as these are likely to be customized |
||||
if {$opt_force} { |
||||
puts stdout "copying layout files - with force applied - overwrite all-targets" |
||||
set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -overwrite ALL-TARGETS -antiglob_paths $antipaths] |
||||
#file copy -force $layout_dir $projectdir |
||||
} else { |
||||
puts stdout "copying layout files - (if source file changed)" |
||||
set resultdict [punkcheck::install $layout_dir $projectdir -installer project.new -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] |
||||
} |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
puts stdout "copying layout src/doc files (if target missing)" |
||||
set resultdict [punkcheck::install $layout_dir/src/doc $projectdir/src/doc -punkcheck_folder $projectdir -installer project.new -overwrite SYNCED-TARGETS] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
#target folders .fossil-custom and .fossil-settings may not exist. use -createdir 1 to ensure existence. |
||||
#In this case we need to override the default dir antiglob - as .fossil-xxx folders need to be installed from template if missing, or if target is uncustomized. |
||||
## default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] |
||||
set override_antiglob_dir_core [list #* _aside .git] |
||||
puts stdout "copying layout src/.fossil-custom files (if target missing or uncustomised)" |
||||
set resultdict [punkcheck::install $layout_dir/.fossil-custom $projectdir/.fossil-custom -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
puts stdout "copying layout src/.fossil-settings files (if target missing or uncustomised)" |
||||
set resultdict [punkcheck::install $layout_dir/.fossil-settings $projectdir/.fossil-settings -createdir 1 -punkcheck_folder $projectdir -installer project.new -antiglob_dir_core $override_antiglob_dir_core -overwrite SYNCED-TARGETS] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
|
||||
|
||||
|
||||
#lappend substfiles $projectdir/README.md |
||||
#lappend substfiles $projectdir/src/README.md |
||||
#lappend substfiles $projectdir/src/doc/main.man |
||||
#expect this in all templates? - todo make these substitutions independent of specific paths and filenames? |
||||
#scan all files in template |
||||
# |
||||
#TODO - pmix command to substitute templates? |
||||
set templatefiles [punk::mix::commandset::layout::lib::layout_scan_for_template_files $opt_layout] |
||||
set stripprefix [file normalize $layout_dir] |
||||
|
||||
foreach templatefullpath $templatefiles { |
||||
set templatetail [punk::repo::path_strip_alreadynormalized_prefixdepth $templatefullpath $stripprefix] |
||||
|
||||
set fpath [file join $projectdir $templatetail] |
||||
if {[file exists $fpath]} { |
||||
set fd [open $fpath r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd |
||||
set data2 [string map [list [lib::template_tag project] $projectname] $data] |
||||
if {$data2 ne $data} { |
||||
puts stdout "updated template file: $fpath" |
||||
set fdout [open $fpath w]; fconfigure $fdout -translation binary; puts -nonewline $fdout $data2; close $fdout |
||||
} |
||||
} else { |
||||
puts stderr "warning: Missing template file $fpath" |
||||
} |
||||
} |
||||
#todo - tag substitutions in src/doc tree |
||||
|
||||
|
||||
::cd $projectdir |
||||
|
||||
if {[file exists $projectdir/src/modules]} { |
||||
foreach m $opt_modules { |
||||
if {![file exists $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm]} { |
||||
punk::mix::commandset::module::new $m -project $projectname -type $opt_type |
||||
} else { |
||||
if {$opt_force} { |
||||
punk::mix::commandset::module::new $m -project $projectname -type $opt_type -force 1 |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
puts stderr "project.new WARNING template hasn't created src/modules - skipping creation of new module(s) for project" |
||||
} |
||||
|
||||
#generate www/man/md output in 'embedded' folder which should be checked into repo for online documentation |
||||
if {[file exists $projectdir/src]} { |
||||
::cd $projectdir/src |
||||
#---------- |
||||
set installer [punkcheck::installtrack new project.new $projectdir/src/.punkcheck] |
||||
$installer set_source_target $projectdir/src/doc $projectdir/src/embedded |
||||
set event [$installer start_event {-install_step kettledoc}] |
||||
$event targetset_init VIRTUAL kettle_build_doc ;#VIRTUAL - since there is no specific target file - and we don't know all the files that will be generated |
||||
$event targetset_addsource $projectdir/src/doc ;#whole doc tree is considered the source |
||||
#---------- |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
} { |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "BUILDING DOCS at src/embedded from src/doc" |
||||
if {[catch { |
||||
|
||||
punk::mix::cli::lib::kettle_call lib doc |
||||
#Kettle doc |
||||
|
||||
} errM]} { |
||||
$event targetset_end FAILED -note "kettle_build_doc failed: $errM" |
||||
} else { |
||||
$event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "No change detected in src/doc" |
||||
$event targetset_end SKIPPED |
||||
} |
||||
$event end |
||||
$event destroy |
||||
$installer destroy |
||||
} |
||||
|
||||
::cd $projectdir |
||||
|
||||
if {![punk::repo::is_fossil_root $projectdir]} { |
||||
set first_fossil 1 |
||||
#-k = keep. (only modify the manifest file(s)) |
||||
if {$is_nested_fossil} { |
||||
set fossilopen [runx -n {*}$fossil_prog open --nested $repodb_folder/$projectname.fossil -k --workdir $projectdir] |
||||
} else { |
||||
set fossilopen [runx -n {*}$fossil_prog open $repodb_folder/$projectname.fossil -k --workdir $projectdir] |
||||
} |
||||
if {[file exists $projectdir/_FOSSIL_] && ![file exists $projectdir/.fslckout]} { |
||||
file rename $projectdir/_FOSSIL_ $projectdir/.fslckout |
||||
} |
||||
if {[dict get $fossilopen exitcode] != 0} { |
||||
puts stderr "fossil open in project workdir '$projectdir' FAILED:" |
||||
puts stderr [dict get $fossilopen stderr] |
||||
return |
||||
} else { |
||||
puts stdout "fossil open in project workdir '$projectdir' OK:" |
||||
puts stdout [dict get $fossilopen stdout] |
||||
} |
||||
} else { |
||||
set first_fossil 0 |
||||
} |
||||
set fossiladd [runx -n {*}$fossil_prog add --dotfiles $projectdir] |
||||
if {[dict get $fossiladd exitcode] != 0} { |
||||
puts stderr "fossil add workfiles in workdir '$projectdir' FAILED:" |
||||
puts stderr [dict get $fossiladd stderr] |
||||
return |
||||
} else { |
||||
puts stdout "fossil add workfiles in workdir '$projectdir' OK:" |
||||
puts stdout [dict get $fossiladd stdout] |
||||
} |
||||
if {$first_fossil} { |
||||
#fossil commit may prompt user for input.. runx runout etc will pause with no prompts |
||||
util::do_in_path $projectdir { |
||||
set fossilcommit [run -n {*}$fossil_prog commit -m "initial project commit"] |
||||
} |
||||
if {[dict get $fossilcommit exitcode] != 0} { |
||||
puts stderr "fossil commit in workdir '$projectdir' FAILED" |
||||
return |
||||
} else { |
||||
puts stdout "fossil commit in workdir '$projectdir' OK" |
||||
} |
||||
} |
||||
|
||||
puts stdout "-done- project:$projectname projectdir: $projectdir" |
||||
} |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::mix::commandset::project ---}] |
||||
|
||||
namespace eval collection { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::mix::commandset::project::collection}] |
||||
#[para] commandset functions for operating with multiple projects. |
||||
#[para] It would usually be imported with the prefix "projects" and separator "." to result in commands such as: <ensemblecommand> projects.detail |
||||
#[list_begin definitions] |
||||
namespace export * |
||||
namespace path [namespace parent] |
||||
|
||||
#e.g imported as 'projects' |
||||
proc _default {{glob {}} args} { |
||||
#*** !doctools |
||||
#[call [fun _default] [arg glob] [opt {option value...}]] |
||||
#[para]List projects under fossil management, showing fossil db location and number of checkouts |
||||
#[para]The glob argument is optional unless option/value pairs are also supplied, in which case * should be explicitly supplied |
||||
#[para]glob restricts output based on the name of the fossil db file e.g s* for all projects beginning with s |
||||
#[para]The _default function is made available in the ensemble by the name of the prefix used when importing the commandset. |
||||
#[para]e.g |
||||
#[para] punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection |
||||
#[para]Will result in the command being available as <ensemblecommand> projects |
||||
package require overtype |
||||
set db_projects [lib::get_projects $glob] |
||||
set col1items [lsearch -all -inline -index 0 -subindices $db_projects *] |
||||
set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] |
||||
set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] |
||||
set col3items [lmap v $checkouts {llength $v}] |
||||
|
||||
set title1 "Fossil Repo DB" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1items] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
set title2 "File Name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
set title3 "Checkouts" |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {punk::strlen $v}]] |
||||
set col3 [string repeat " " $widest3] |
||||
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3}] |
||||
|
||||
|
||||
append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]" \n |
||||
append msg [string repeat "=" $tablewidth] \n |
||||
foreach p $col1items n $col2items c $col3items { |
||||
append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]" \n |
||||
} |
||||
return $msg |
||||
#return [list_as_lines [lib::get_projects $glob]] |
||||
} |
||||
proc detail {{glob {}} args} { |
||||
package require overtype |
||||
package require textutil |
||||
set defaults [dict create\ |
||||
-description 0\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- |
||||
set opt_description [dict get $opts -description] |
||||
# -- --- --- --- --- --- --- |
||||
|
||||
|
||||
set db_projects [lib::get_projects $glob] |
||||
set col1_dbfiles [lsearch -all -inline -index 0 -subindices $db_projects *] |
||||
set col2items [lsearch -all -inline -index 1 -subindices $db_projects *] |
||||
set checkouts [lsearch -all -inline -index 2 -subindices $db_projects *] |
||||
set col3items [lmap v $checkouts {llength $v}] |
||||
|
||||
set col4_pnames [list] |
||||
set col5_pcodes [list] |
||||
set col6_dupids [list] |
||||
set col7_pdescs [list] |
||||
set codes [dict create] |
||||
foreach dbfile $col1_dbfiles { |
||||
set project_name "" |
||||
set project_code "" |
||||
set project_desc "" |
||||
sqlite3 dbp $dbfile |
||||
dbp eval {select name,value from config where name like 'project-%';} r { |
||||
if {$r(name) eq "project-name"} { |
||||
set project_name $r(value) |
||||
} elseif {$r(name) eq "project-code"} { |
||||
set project_code $r(value) |
||||
} elseif {$r(name) eq "project-description"} { |
||||
set project_desc $r(value) |
||||
} |
||||
} |
||||
dbp close |
||||
lappend col4_pnames $project_name |
||||
lappend col5_pcodes $project_code |
||||
dict lappend codes $project_code $dbfile |
||||
lappend col7_pdescs $project_desc |
||||
} |
||||
|
||||
set setid 1 |
||||
set codeset [dict create] |
||||
dict for {code dbs} $codes { |
||||
if {[llength $dbs]>1} { |
||||
dict set codeset $code setid $setid |
||||
dict set codeset $code count [llength $dbs] |
||||
dict set codeset $code seen 0 |
||||
incr setid |
||||
} |
||||
} |
||||
set dupid 1 |
||||
foreach pc $col5_pcodes { |
||||
if {[dict exists $codeset $pc]} { |
||||
set seen [dict get $codeset $pc seen] |
||||
set this_seen [expr {$seen + 1}] |
||||
dict set codeset $pc seen $this_seen |
||||
lappend col6_dupids "[dict get $codeset $pc setid].${this_seen}/[dict get $codeset $pc count]" |
||||
} else { |
||||
lappend col6_dupids "" |
||||
} |
||||
} |
||||
|
||||
set title1 "Fossil Repo DB" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $col1_dbfiles] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
set title2 "File Name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col2items] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
set title3 "Checkouts" |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col3items] {punk::strlen $v}]] |
||||
set col3 [string repeat " " $widest3] |
||||
set title4 "Project Name" |
||||
set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col4_pnames] {punk::strlen $v}]] |
||||
set col4 [string repeat " " $widest4] |
||||
set title5 "Project Code" |
||||
set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col5_pcodes] {punk::strlen $v}]] |
||||
set col5 [string repeat " " $widest5] |
||||
set title6 "Dup" |
||||
set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col6_dupids] {punk::strlen $v}]] |
||||
set col6 [string repeat " " $widest6] |
||||
set title7 "Description" |
||||
#set widest7 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col7_pdescs] {punk::strlen $v}]] |
||||
set widest7 35 |
||||
set col7 [string repeat " " $widest7] |
||||
|
||||
|
||||
set tablewidth [expr {$widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5 + 1 + $widest6}] |
||||
|
||||
append msg "[overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3]\ |
||||
[overtype::left $col4 $title4] [overtype::left $col5 $title5] [overtype::left $col6 $title6]" |
||||
if {!$opt_description} { |
||||
append msg \n |
||||
} else { |
||||
append msg "[overtype::left $col7 $title7]" \n |
||||
set tablewidth [expr {$tablewidth + 1 + $widest7}] |
||||
} |
||||
|
||||
append msg [string repeat "=" $tablewidth] \n |
||||
foreach p $col1_dbfiles n $col2items c $col3items pn $col4_pnames pc $col5_pcodes dup $col6_dupids desc $col7_pdescs { |
||||
set desclines [split [textutil::adjust $desc -length $widest7] \n] |
||||
set desc1 [lindex $desclines 0] |
||||
append msg "[overtype::left $col1 $p] [overtype::left $col2 $n] [overtype::right $col3 $c]\ |
||||
[overtype::left $col4 $pn] [overtype::left $col5 $pc] [overtype::left $col6 $dup]" |
||||
if {!$opt_description} { |
||||
append msg \n |
||||
} else { |
||||
append msg " [overtype::left $col7 $desc1]" \n |
||||
foreach dline [lrange $desclines 1 end] { |
||||
append msg "$col1 $col2 $col3 $col4 $col5 $col6 [overtype::left $col7 $dline]" \n |
||||
} |
||||
} |
||||
} |
||||
return $msg |
||||
#return [list_as_lines [lib::get_projects $glob]] |
||||
} |
||||
proc cd {{glob {}} args} { |
||||
dict set args -cd 1 |
||||
work $glob {*}$args |
||||
} |
||||
proc work {{glob {}} args} { |
||||
package require sqlite3 |
||||
set db_projects [lib::get_projects $glob] |
||||
if {[llength $db_projects] == 0} { |
||||
puts stderr "::punk::mix::commandset::project::work No Repo DB name matches found for '$glob'" |
||||
return "" |
||||
} |
||||
#list of lists of the form: |
||||
#{fosdb fname workdirlist} |
||||
set defaults [dict create\ |
||||
-cd 0\ |
||||
-detail "\uFFFF"\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- |
||||
set opt_cd [dict get $opts -cd] |
||||
# -- --- --- --- --- --- --- |
||||
set opt_detail [dict get $opts -detail] |
||||
set opt_detail_explicit_zero 1 ;#default assumption only |
||||
if {$opt_detail eq "\uFFFF"} { |
||||
set opt_detail_explicit_zero 0 |
||||
set opt_detail 0; #default |
||||
} |
||||
# -- --- --- --- --- --- --- |
||||
set workdir_dict [dict create] |
||||
set all_workdirs [list] |
||||
foreach pinfo $db_projects { |
||||
lassign $pinfo fosdb name workdirs |
||||
foreach wdir $workdirs { |
||||
dict set workdir_dict $wdir $pinfo |
||||
lappend all_workdirs $wdir |
||||
} |
||||
} |
||||
set col_rowids [list] |
||||
set workdirs [lsort -index 0 $all_workdirs] |
||||
set col_dupids [list] |
||||
set col_fnames [list] |
||||
set col_pnames [list] |
||||
set col_pcodes [list] |
||||
set col_dupids [list] |
||||
|
||||
set fosdb_count [dict create] |
||||
set fosdb_dupset [dict create] |
||||
set fosdb_cache [dict create] |
||||
set dupset 0 |
||||
set rowid 1 |
||||
foreach wd $workdirs { |
||||
set wdinfo [dict get $workdir_dict $wd] |
||||
lassign $wdinfo fosdb nm siblingworkdirs |
||||
dict incr fosdb_count $fosdb |
||||
set dbcount [dict get $fosdb_count $fosdb] |
||||
if {[llength $siblingworkdirs] > 1} { |
||||
if {![dict exists $fosdb_dupset $fosdb]} { |
||||
#first time this multi-checkout fosdb seen |
||||
dict set fosdb_dupset $fosdb [incr dupset] |
||||
} |
||||
set dupid "[dict get $fosdb_dupset $fosdb].$dbcount/[llength $siblingworkdirs]" |
||||
} else { |
||||
set dupid "" |
||||
} |
||||
if {$dbcount == 1} { |
||||
set pname "" |
||||
set pcode "" |
||||
if {[file exists $fosdb]} { |
||||
if {[catch { |
||||
sqlite3 fdb $fosdb |
||||
set pname [lindex [fdb eval {select value from config where name = 'project-name'}] 0] |
||||
set pcode [lindex [fdb eval {select value from config where name = 'project-code'}] 0] |
||||
fdb close |
||||
dict set fosdb_cache $fosdb [list name $pname code $pcode] |
||||
} errM]} { |
||||
puts stderr "!!! problem with fossil db: $fosdb when examining workdir $wd" |
||||
puts stderr "!!! error: $errM" |
||||
} |
||||
} else { |
||||
puts stderr "!!! missing fossil db $fosdb" |
||||
} |
||||
} else { |
||||
set info [dict get $fosdb_cache $fosdb] |
||||
lassign $info _name pname _code pcode |
||||
} |
||||
lappend col_rowids $rowid |
||||
lappend col_fnames $nm |
||||
lappend col_dupids $dupid |
||||
lappend col_pnames $pname |
||||
lappend col_pcodes [string range $pcode 0 9] |
||||
incr rowid |
||||
} |
||||
|
||||
set col_states [list] |
||||
set state_title "" |
||||
#if only one set of fossil checkouts in the resultset and opt_detail is 0 and not explicit - retrieve workingdir state for each co |
||||
if {([llength [dict keys $fosdb_cache]] == 1)} { |
||||
if {!$opt_detail_explicit_zero} { |
||||
set opt_detail 1 |
||||
} |
||||
puts stderr "Result is from a single repo db [dict keys $fosdb_cache]" |
||||
} |
||||
if {$opt_detail} { |
||||
puts stderr "Gathering file state for [llength $workdirs] checkout folder(s). Use -detail 0 to omit file state" |
||||
set c_rev [list] |
||||
set c_rev_iso [list] |
||||
set c_unchanged [list] |
||||
set c_changed [list] |
||||
set c_new [list] |
||||
set c_missing [list] |
||||
set c_extra [list] |
||||
foreach wd $workdirs { |
||||
set wd_state [punk::repo::workingdir_state $wd] |
||||
set state_dict [punk::repo::workingdir_state_summary_dict $wd_state] |
||||
lappend c_rev [string range [dict get $state_dict revision] 0 9] |
||||
lappend c_rev_iso [dict get $state_dict revision_iso8601] |
||||
lappend c_unchanged [dict get $state_dict unchanged] |
||||
lappend c_changed [dict get $state_dict changed] |
||||
lappend c_new [dict get $state_dict new] |
||||
lappend c_missing [dict get $state_dict missing] |
||||
lappend c_extra [dict get $state_dict extra] |
||||
puts -nonewline stderr "." |
||||
} |
||||
puts -nonewline stderr \n |
||||
set t0 "Revision" |
||||
set w0 [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev] {string length $v}]] |
||||
set c0 [string repeat " " $w0] |
||||
set t0b "Revision iso8601" |
||||
set w0b [tcl::mathfunc::max {*}[lmap v [concat [list $t0] $c_rev_iso] {string length $v}]] |
||||
set c0b [string repeat " " $w0b] |
||||
set t1 "Unch" |
||||
set w1 [tcl::mathfunc::max {*}[lmap v [concat [list $t1] $c_unchanged] {string length $v}]] |
||||
set c1 [string repeat " " $w1] |
||||
set t2 "Chgd" |
||||
set w2 [tcl::mathfunc::max {*}[lmap v [concat [list $t2] $c_changed] {string length $v}]] |
||||
set c2 [string repeat " " $w2] |
||||
set t3 "New" |
||||
set w3 [tcl::mathfunc::max {*}[lmap v [concat [list $t3] $c_new] {string length $v}]] |
||||
set c3 [string repeat " " $w3] |
||||
set t4 "Miss" |
||||
set w4 [tcl::mathfunc::max {*}[lmap v [concat [list $t4] $c_missing] {string length $v}]] |
||||
set c4 [string repeat " " $w4] |
||||
set t5 "Extr" |
||||
set w5 [tcl::mathfunc::max {*}[lmap v [concat [list $t5] $c_extra] {string length $v}]] |
||||
set c5 [string repeat " " $w5] |
||||
|
||||
set state_title "[overtype::left $c0 $t0] [overtype::left $c0b $t0b] [overtype::right $c1 $t1] [overtype::right $c2 $t2] [overtype::right $c3 $t3] [overtype::right $c4 $t4] [overtype::right $c5 $t5]" |
||||
foreach r $c_rev iso $c_rev_iso u $c_unchanged c $c_changed n $c_new m $c_missing e $c_extra { |
||||
lappend col_states "[overtype::left $c0 $r] [overtype::left $c0b $iso] [overtype::right $c1 $u] [overtype::right $c2 $c] [overtype::right $c3 $n] [overtype::right $c4 $m] [overtype::right $c5 $e]" |
||||
} |
||||
} |
||||
|
||||
set msg "" |
||||
if {$opt_cd} { |
||||
set title0 "CD" |
||||
} else { |
||||
set title0 "" |
||||
} |
||||
set widest0 [tcl::mathfunc::max {*}[lmap v [concat [list $title0] $col_rowids] {punk::strlen $v}]] |
||||
set col0 [string repeat " " $widest0] |
||||
set title1 "Checkout dir" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $workdirs] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
set title2 "Repo DB name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $col_fnames] {string length $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
set title3 "CO dup" |
||||
set widest3 [tcl::mathfunc::max {*}[lmap v [concat [list $title3] $col_dupids] {string length $v}]] |
||||
set col3 [string repeat " " $widest3] |
||||
set title4 "Project Name" |
||||
set widest4 [tcl::mathfunc::max {*}[lmap v [concat [list $title4] $col_pnames] {string length $v}]] |
||||
set col4 [string repeat " " $widest4] |
||||
set title5 "Project Code" |
||||
set widest5 [tcl::mathfunc::max {*}[lmap v [concat [list $title5] $col_pcodes] {string length $v}]] |
||||
set col5 [string repeat " " $widest5] |
||||
|
||||
set tablewidth [expr {$widest0 + 1 + $widest1 + 1 + $widest2 + 1 + $widest3 +1 + $widest4 + 1 + $widest5}] |
||||
append msg "[overtype::right $col0 $title0] [overtype::left $col1 $title1] [overtype::left $col2 $title2] [overtype::left $col3 $title3] [overtype::left $col4 $title4] [overtype::left $col5 $title5]" |
||||
|
||||
if {[llength $col_states]} { |
||||
set title6 $state_title |
||||
set widest6 [tcl::mathfunc::max {*}[lmap v [concat [list $title6] $col_states] {string length $v}]] |
||||
set col6 [string repeat " " $widest6] |
||||
incr tablewidth [expr {$widest6 + 1}] |
||||
append msg " [overtype::left $col6 $title6]" \n |
||||
} else { |
||||
append msg \n |
||||
} |
||||
append msg [string repeat "=" $tablewidth] \n |
||||
|
||||
if {[llength $col_states]} { |
||||
foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes s $col_states { |
||||
append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode] [overtype::left $col6 $s]" \n |
||||
} |
||||
} else { |
||||
foreach row $col_rowids wd $workdirs db $col_fnames dup $col_dupids pname $col_pnames pcode $col_pcodes { |
||||
append msg "[overtype::right $col0 $row] [overtype::left $col1 $wd] [overtype::left $col2 $db] [overtype::right $col3 $dup] [overtype::left $col4 $pname] [overtype::left $col5 $pcode]" \n |
||||
} |
||||
} |
||||
set numrows [llength $col_rowids] |
||||
if {$opt_cd && $numrows >= 1} { |
||||
puts stdout $msg |
||||
if {$numrows == 1} { |
||||
set workingdir [lindex $workdirs 0] |
||||
puts stdout "1 result. Changing dir to $workingdir" |
||||
if {[file exists $workingdir]} { |
||||
::cd $workingdir |
||||
return $workingdir |
||||
} else { |
||||
puts stderr "path $workingdir doesn't appear to exist" |
||||
return [pwd] |
||||
} |
||||
} else { |
||||
set answer [util::askuser "Change directory to working folder - select a number from 1 to [llength $col_rowids] or any other key to cancel."] |
||||
if {[string trim $answer] in $col_rowids} { |
||||
set index [expr {$answer - 1}] |
||||
set workingdir [lindex $workdirs $index] |
||||
::cd $workingdir |
||||
puts stdout [pmix stat] |
||||
return $workingdir |
||||
} |
||||
} |
||||
} |
||||
return $msg |
||||
} |
||||
#*** !doctools |
||||
#[list_end] [comment {-- end collection namespace definitions --}] |
||||
} |
||||
|
||||
namespace eval lib { |
||||
proc template_tag {tagname} { |
||||
#todo - support different tagwrappers - it shouldn't be so likely to collide with common code idioms etc. |
||||
#we need to detect presence of tags intended for punk::mix system |
||||
#consider using punk::cap to enable multiple template-substitution providers with their own set of tagnames and/or tag wrappers, where substitution providers are all run |
||||
return [string cat % $tagname %] |
||||
} |
||||
#get project info only by opening the central confg-db |
||||
#(will not have proper project-name etc) |
||||
proc get_projects {{globlist {}} args} { |
||||
if {![llength $globlist]} { |
||||
set globlist [list *] |
||||
} |
||||
set fossil_prog [auto_execok fossil] |
||||
|
||||
set fossilinfo [exec {*}$fossil_prog info] ;#will give us the necessary config-db info whether in a project folder or not |
||||
set matching_lines [punk::repo::grep {config-db:*} $fossilinfo] |
||||
if {[llength $matching_lines] != 1} { |
||||
puts stderr "Unable to find config-db info from fossil. Check your fossil installation." |
||||
puts stderr "Fossil output was:" |
||||
puts stderr "-------------" |
||||
puts stderr "$fossilinfo" |
||||
puts stderr "-------------" |
||||
puts stderr "config-db info:" |
||||
puts stderr "$matching_lines" |
||||
return |
||||
} |
||||
set ln [lindex $matching_lines 0] |
||||
set configdb [string trim [string range $ln [string length "config-db: "] end]] |
||||
if {![file exists $configdb]} { |
||||
error "config-db not found at path $configdb" |
||||
} |
||||
package require sqlite3 |
||||
::sqlite3 fosconf $configdb |
||||
#set testresult [fosconf eval {select name,value from global_config;}] |
||||
#puts stderr $testresult |
||||
set project_repos [fosconf eval {select name from global_config where name like 'repo:%';}] |
||||
set paths_and_names [list] |
||||
foreach pr $project_repos { |
||||
set path [string trim [string range $pr 5 end]] |
||||
set nm [file rootname [file tail $path]] |
||||
set ckouts [fosconf eval {select name from global_config where value = $path;}] |
||||
set checkout_paths [list] |
||||
#strip "ckout:" |
||||
foreach ck $ckouts { |
||||
lappend checkout_paths [string trim [string range $ck 6 end]] |
||||
} |
||||
lappend paths_and_names [list $path $nm $checkout_paths] |
||||
} |
||||
set filtered_list [list] |
||||
foreach glob $globlist { |
||||
set matches [lsearch -all -inline -index 1 $paths_and_names $glob] |
||||
foreach m $matches { |
||||
if {$m ni $filtered_list} { |
||||
lappend filtered_list $m |
||||
} |
||||
} |
||||
} |
||||
set projects [lsort -index 1 $filtered_list] |
||||
return $projects |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::project [namespace eval punk::mix::commandset::project { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -1,92 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::repo 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::repo { |
||||
namespace export * |
||||
proc tickets {{project ""}} { |
||||
set result "" |
||||
if {[string length $project]} { |
||||
puts stderr "project status unimplemented" |
||||
return |
||||
} |
||||
set active_dir [pwd] |
||||
append result "Retrieving top 10 tickets only (for more, use fossil timeline -n <int> -t t)" \n |
||||
append result [exec fossil timeline -n 10 -t t] |
||||
|
||||
return $result |
||||
} |
||||
|
||||
proc fossilize { args} { |
||||
#check if project already managed by fossil.. initialise and check in if not. |
||||
puts stderr "unimplemented" |
||||
} |
||||
|
||||
proc unfossilize {projectname args} { |
||||
#remove/archive .fossil |
||||
puts stderr "unimplemented" |
||||
} |
||||
proc state {} { |
||||
set result "" |
||||
set repopaths [punk::repo::find_repos [pwd]] |
||||
set repos [dict get $repopaths repos] |
||||
if {![llength $repos]} { |
||||
append result [dict get $repopaths warnings] |
||||
} else { |
||||
append result [dict get $repopaths warnings] |
||||
lassign [lindex $repos 0] repopath repotypes |
||||
if {"fossil" in $repotypes} { |
||||
append result \n "Fossil repo based at $repopath" |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
if {"git" in $repotypes} { |
||||
append result \n "Git repo based at $repopath" |
||||
set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes git] |
||||
append result \n [punk::repo::workingdir_state_summary $repostate] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::repo [namespace eval punk::mix::commandset::repo { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -1,681 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::commandset::scriptwrap 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
package require punk::mix |
||||
package require punk::mix::base |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::commandset::scriptwrap { |
||||
namespace export * |
||||
|
||||
|
||||
#scriptpath allows templates command to use same custom template set as when multishell pointed to a filepath |
||||
#it may or may not be within a project |
||||
#by using the same folder or path, the same project root will be discovered. REVIEW. |
||||
proc templates_dict {args} { |
||||
set defaults [list -scriptpath ""] |
||||
set opts [dict merge $defaults $args] |
||||
set opt_scriptpath [dict get $opts -scriptpath] |
||||
|
||||
set wrapper_folders [lib::get_wrapper_folders $opt_scriptpath] |
||||
|
||||
set wrapper_templates [list] |
||||
foreach fld $wrapper_folders { |
||||
set templates [glob -nocomplain -dir $fld -type f *] |
||||
foreach tf $templates { |
||||
if {[string match ignore* $tf]} { |
||||
continue |
||||
} |
||||
set ext [file extension $tf] |
||||
if {$ext in [list "" ".bat" ".cmd" ".sh"]} { |
||||
lappend wrapper_templates $tf |
||||
} |
||||
} |
||||
} |
||||
|
||||
set tdict [dict create] |
||||
set seen_dict [dict create] |
||||
foreach fullpath $wrapper_templates { |
||||
set ftail [file tail $fullpath] |
||||
if {![dict exists $seen_dict $ftail]} { |
||||
dict set seen_dict $ftail 1 |
||||
dict set tdict $ftail $fullpath ; #first seen of filename gets no number |
||||
} else { |
||||
set n [dict get $seen_dict $ftail] |
||||
incr n |
||||
dict incr seen_dict $ftail |
||||
dict set tdict ${ftail}.$n $fullpath |
||||
} |
||||
} |
||||
return $tdict |
||||
} |
||||
proc templates {args} { |
||||
package require overtype |
||||
set tdict [templates_dict {*}$args] |
||||
|
||||
|
||||
set paths [dict values $tdict] |
||||
set names [dict keys $tdict] |
||||
|
||||
set title1 "Path" |
||||
set widest1 [tcl::mathfunc::max {*}[lmap v [concat [list $title1] $paths] {punk::strlen $v}]] |
||||
set col1 [string repeat " " $widest1] |
||||
|
||||
set title2 "Template Name" |
||||
set widest2 [tcl::mathfunc::max {*}[lmap v [concat [list $title2] $names] {punk::strlen $v}]] |
||||
set col2 [string repeat " " $widest2] |
||||
|
||||
set tablewidth [expr {$widest1 + 1 + $widest2}] |
||||
set table "" |
||||
append table [string repeat - $tablewidth] \n |
||||
append table "[overtype::left $col1 $title1] [overtype::left $col2 $title2]" \n |
||||
append table [string repeat - $tablewidth] \n |
||||
|
||||
foreach p $paths n $names { |
||||
append table "[overtype::left $col1 $p] [overtype::left $col2 $n]" \n |
||||
} |
||||
|
||||
|
||||
return $table |
||||
} |
||||
#specific filepath to just wrap one script at the tcl-payload or xxx-payload-pre-tcl site |
||||
#scriptset name to substiture multiple scriptset.xxx files at the default locations - or as specified in scriptset.wrapconf |
||||
proc multishell {filepath_or_scriptset args} { |
||||
set defaults [dict create\ |
||||
-askme 1\ |
||||
-outputfolder "\uFFFF"\ |
||||
-template "\uFFFF"\ |
||||
] |
||||
set known_opts [dict keys $defaults] |
||||
dict for {k v} $args { |
||||
if {$k ni $known_opts} { |
||||
|
||||
error "punk::mix::commandset::scriptwrap error. Unrecognized option '$k'. Known-options: $known_opts" |
||||
} |
||||
} |
||||
set usage "" |
||||
append usage "Use directly with the script file to wrap, or supply the name of a scriptset" \n |
||||
append usage "The scriptset name will be used to search for yourname.sh|tcl|ps1 or names as you specify in yourname.wrapconfig if it exists" \n |
||||
append usage "If no template is specified in a .wrapconfig and no -template argument is supplied, it will default to punk-multishell.cmd" \n |
||||
if {![string length $filepath_or_scriptset]} { |
||||
puts stderr "No filepath_or_scriptset specified" |
||||
puts stderr $usage |
||||
return false |
||||
} |
||||
set opts [dict merge $defaults $args] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- |
||||
set opt_askme [dict get $opts -askme] |
||||
set opt_template [dict get $opts -template] |
||||
set opt_outputfolder [dict get $opts -outputfolder] |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
|
||||
set ext [file extension $filepath_or_scriptset] |
||||
set startdir [pwd] |
||||
|
||||
|
||||
|
||||
#first check if relative or absolute path matches a file |
||||
if {[file pathtype $filepath_or_scriptset] eq "absolute"} { |
||||
set specified_path $filepath_or_scriptset |
||||
} else { |
||||
set specified_path [file join $startdir $filepath_or_scriptset] |
||||
} |
||||
set ext [string trim [file extension $filepath_or_scriptset] .] |
||||
set allowed_extensions [list wrapconfig tcl ps1 sh bash] |
||||
#set allowed_extensions [list tcl] |
||||
set found_script 0 |
||||
if {[file exists $specified_path]} { |
||||
set found_script 1 |
||||
} else { |
||||
foreach e $allowed_extensions { |
||||
if {[file exists $filepath_or_scriptset.$e]} { |
||||
set found_script 1 |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
#TODO! - use get_wrapper_folders - multishell should use same available templates as the 'templates' function |
||||
set scriptset [file rootname [file tail $specified_path]] |
||||
if {$found_script} { |
||||
if {[file type $specified_path] eq "file"} { |
||||
set specified_root [file dirname $specified_path] |
||||
set pathinfo [punk::repo::find_repos [file dirname $specified_path]] |
||||
set projectroot [dict get $pathinfo closest] |
||||
if {[string length $projectroot]} { |
||||
#use the specified files folder - but use the main scriptapps/wrappers folder if specified one has no wrappers subfolder |
||||
set scriptroot [file dirname $specified_path] |
||||
if {[file exists $scriptroot/wrappers]} { |
||||
set customwrapper_folder $scriptroot/wrappers |
||||
} else { |
||||
set customwrapper_folder $projectroot/src/scriptapps/wrappers |
||||
} |
||||
} else { |
||||
#outside of any project |
||||
set scriptroot [file dirname $specified_path] |
||||
if {[file exists $scriptroot/wrappers]} { |
||||
set customwrapper_folder $scriptroot/wrappers |
||||
} else { |
||||
#no customwrapper folder available |
||||
set customwrapper_folder "" |
||||
} |
||||
} |
||||
} else { |
||||
puts stderr "wrap_in_multishell doesn't currently support a directory as the path." |
||||
puts stderr $usage |
||||
return false |
||||
} |
||||
} else { |
||||
set pathinfo [punk::repo::find_repos $startdir] |
||||
set projectroot [dict get $pathinfo closest] |
||||
if {[string length $projectroot]} { |
||||
if {[llength [file split $filepath_or_scriptset]] > 1} { |
||||
puts stderr "filepath_or_scriptset looks like a path - but doesn't seem to point to a file" |
||||
puts stderr "Ensure you are within a project and use just the name of the scriptset, or pass in the full correct path or relative path to current directory" |
||||
puts stderr $usage |
||||
return false |
||||
} else { |
||||
#we've already ruled out empty string - so must have a single element representing scriptset - possibly with file extension |
||||
set scriptroot $projectroot/src/scriptapps |
||||
set customwrapper_folder $projectroot/src/scriptapps/wrappers |
||||
#check something matches the scriptset.. |
||||
set something_found "" |
||||
if {[file exists $scriptroot/$scriptset]} { |
||||
set found_script 1 |
||||
set something_found $scriptroot/$scriptset ;#extensionless file - that's ok too |
||||
} else { |
||||
foreach e $allowed_extensions { |
||||
if {[file exists $scriptroot/$scriptset.$e]} { |
||||
set found_script 1 |
||||
set something_found $scriptroot/$scriptset.$e |
||||
break |
||||
} |
||||
} |
||||
} |
||||
if {!$found_script} { |
||||
puts stderr "Searched within $scriptroot" |
||||
puts stderr "Unable to find a file matching $scriptset or one of the extensions: $allowed_extensions" |
||||
puts stderr $usage |
||||
return false |
||||
} else { |
||||
if {[file type $something_found] ne "file"} { |
||||
puts stderr "Found '$something_found'" |
||||
puts stderr "wrap_in_multishell doesn't currently support a directory as the path." |
||||
puts stderr $usage |
||||
return false |
||||
} |
||||
} |
||||
} |
||||
|
||||
} else { |
||||
puts stderr "filepath_or_scriptset parameter doesn't seem to refer to a file, and you are not within a directory where projectroot and src/scriptapps/wrappers can be determined" |
||||
puts stderr $usage |
||||
return false |
||||
} |
||||
} |
||||
#assert - customwrapper_folder var exists - but might be empty |
||||
|
||||
|
||||
if {[string length $ext]} { |
||||
#If there was an explicitly supplied extension - then that file should exist |
||||
if {![file exists $scriptroot/$scriptset.$ext]} { |
||||
puts stderr "Explicit extension .$ext was supplied - but matching file not found." |
||||
puts stderr $usage |
||||
return false |
||||
} else { |
||||
if {$ext eq "wrapconfig"} { |
||||
set process_extensions ALLFOUNDORCONFIGURED |
||||
} else { |
||||
set process_extensions $ext |
||||
} |
||||
} |
||||
} else { |
||||
#no explicit extension - process all for scriptset |
||||
set process_extensions ALLFOUNDORCONFIGURED |
||||
} |
||||
#process_extensions - either a single one - or all found or as per .wrapconfig |
||||
|
||||
if {$opt_template eq "\uFFFF"} { |
||||
set templatename punk-multishell.cmd |
||||
} else { |
||||
set templatename $opt_template |
||||
} |
||||
|
||||
|
||||
|
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
set tpldirs [list] |
||||
dict for {tdir tsourceinfo} $template_base_dict { |
||||
if {[file exists $tdir/utility/scriptappwrappers/$templatename]} { |
||||
lappend tpldirs $tdir |
||||
} |
||||
} |
||||
|
||||
if {[string length $customwrapper_folder] && [file exists [file join $customwrapper_folder $templatename] ]} { |
||||
set wrapper_template [file join $customwrapper_folder $templatename] |
||||
} else { |
||||
if {![llength $tpldirs]} { |
||||
set msg "No template named '$templatename' found in src/scriptapps/wrappers or in template dirs from packages" |
||||
append msg \n "Searched [dict size $template_base_dict] template dirs" |
||||
error $msg |
||||
} |
||||
|
||||
#last pkg with templates cap which was loaded has highest precedence |
||||
set wrapper_template "" |
||||
foreach tdir [lreverse $tpldirs] { |
||||
set ftest [file join $tdir utility scriptappwrappers $templatename] |
||||
if {[file exists $ftest]} { |
||||
set wrapper_template $ftest |
||||
break |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$wrapper_template eq "" || ![file exists $wrapper_template]} { |
||||
error "wrap_in_multishell: unable to find multishell template $templatename in template folders [concat $tpldirs $customwrapper_folder]" |
||||
} |
||||
|
||||
|
||||
if {$opt_outputfolder eq "\uFFFF"} { |
||||
#outputfolder not explicitly specified by caller |
||||
if {[string length $projectroot]} { |
||||
set output_folder [file join $projectroot/bin] |
||||
} else { |
||||
set output_folder $startdir |
||||
} |
||||
} else { |
||||
if {[file pathtype $opt_outputfolder] eq "relative"} { |
||||
if {[string length $projectroot]} { |
||||
set output_folder [file join $projectroot $opt_outputfolder] |
||||
} else { |
||||
set output_folder [file join $startdir $opt_outputfolder] |
||||
} |
||||
} else { |
||||
set output_folder $opt_outputfolder |
||||
} |
||||
} |
||||
if {![file isdirectory $output_folder]} { |
||||
error "wrap_in_multishell: output folder '$output_folder' not found. Please ensure target directory exists" |
||||
} |
||||
|
||||
|
||||
#todo |
||||
#output_file extension may also depend on the template being used.. and/or the .wrapconfig |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
set output_extension cmd |
||||
} else { |
||||
set output_extension sh |
||||
} |
||||
set output_file [file join $output_folder $scriptset.$output_extension] |
||||
if {[file exists $output_file]} { |
||||
error "wrap_in_multishell: target file $output_file already exists.. aborting" |
||||
} |
||||
|
||||
|
||||
set fdt [open $wrapper_template r] |
||||
fconfigure $fdt -translation binary |
||||
set template_data [read $fdt] |
||||
close $fdt |
||||
puts stdout "Read [string length $template_data] bytes of template data.." |
||||
set template_lines [split $template_data \n] |
||||
puts stdout "Displaying first 3 lines of template between dashed lines..." |
||||
puts stdout "-----------------------------------------------" |
||||
foreach ln [lrange $template_lines 0 3] { |
||||
puts stdout $ln |
||||
} |
||||
puts stdout "-----------------------------------------------\n" |
||||
#foreach ln $template_lines { |
||||
#} |
||||
|
||||
set list_input_files [list] |
||||
if {$process_extensions eq "ALLFOUNDORCONFIGURED"} { |
||||
#todo - look for .wrapconfig or all extensions for the scriptset |
||||
puts stderr "Sorry - only single input file supported. Supply a file extension or use a .wrapconfig with a single input file for now - implementation incomplete" |
||||
return false |
||||
} else { |
||||
lappend list_input_files $scriptroot/$scriptset.$ext |
||||
} |
||||
|
||||
#todo - split template at each <ext-payload> etc marker and build a dict of parts |
||||
|
||||
|
||||
#hack - process one input |
||||
set filepath [lindex $list_input_files 0] |
||||
|
||||
set fdscript [open $filepath r] |
||||
fconfigure $fdscript -translation binary |
||||
set script_data [read $fdscript] |
||||
close $fdscript |
||||
puts stdout "Read [string length $script_data] bytes of template data.." |
||||
set script_lines [split $script_data \n] |
||||
puts stdout "Displaying first 3 lines of your script between dashed lines..." |
||||
puts stdout "-----------------------------------------------" |
||||
foreach ln [lrange $script_lines 0 3] { |
||||
puts stdout $ln |
||||
} |
||||
puts stdout "-----------------------------------------------\n" |
||||
puts stdout "Target for above data is '$output_file'" |
||||
if {$opt_askme} { |
||||
set answer [util::askuser "Does this look correct? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y or y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
|
||||
set start_idx 0 |
||||
set end_idx 0 |
||||
set line_idx 0 |
||||
set existing_payload [list] |
||||
foreach ln $template_lines { |
||||
|
||||
if {[string match "#<tcl-payload>*" $ln]} { |
||||
set start_idx $line_idx |
||||
} elseif {[string match "#</tcl-payload>*" $ln]} { |
||||
set end_idx $line_idx |
||||
break |
||||
} elseif {$start_idx > 0} { |
||||
if {$end_idx > 0} { |
||||
lappend existing_payload [string trim $ln] |
||||
} |
||||
} else { |
||||
|
||||
} |
||||
incr line_idx |
||||
} |
||||
if {($start_idx == 0) || ($end_idx == 0)} { |
||||
error "wrap_in_multishell was unable to find payload area in template marked with #<tcl-payload> and #</tcl-payload> on separate lines" |
||||
} |
||||
set existing_string [join $existing_payload \n] |
||||
if {[string length [string trim $existing_string]]} { |
||||
puts stdout "EXISTING PAYLOAD!!" |
||||
puts stdout "-----------------------------------------------\n" |
||||
puts stdout $existing_string |
||||
puts stdout "-----------------------------------------------\n" |
||||
error "wrap_in_multishell found existing payload.. aborting." |
||||
#todo - allow overwrite only in files outside of punkshell distribution? |
||||
if 0 { |
||||
puts stderr "Found existing payload.. overwrite?" |
||||
if {$opt_askme} { |
||||
set answer [util::askuser "Are you sure you want to replace the tcl payload shown above? Y|N"] |
||||
if {[string tolower $answer] ne "y"} { |
||||
puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -askme 0 to avoid prompts." |
||||
return |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
set tpl_head_lines [lrange $template_lines 0 $start_idx] ;#include tag line |
||||
set tpl_tail_lines [lrange $template_lines $end_idx end] |
||||
set newscript [join $tpl_head_lines \n]\n[join $script_lines \n]\n[join $tpl_tail_lines \n] |
||||
puts stdout "New script is [string length $newscript] bytes" |
||||
puts stdout $newscript |
||||
set fdtarget [open $output_file w] |
||||
fconfigure $fdtarget -translation binary |
||||
puts -nonewline $fdtarget $newscript |
||||
close $fdtarget |
||||
puts stdout "Wrote script file at $output_file" |
||||
|
||||
#even though chmod might exist on windows - we will leave permissions alone |
||||
if {$::tcl_platform(platform) ne "windows"} { |
||||
catch {exec chmod +x $output_file} |
||||
} |
||||
puts stdout "-done-" |
||||
return $output_file |
||||
} |
||||
|
||||
namespace eval lib { |
||||
|
||||
#get_wrapper_folders |
||||
# scriptpath - file or folder |
||||
# It represents the base point from which to search for /wrapper folders either directly above the scriptpath or in the containing project if any |
||||
# The cwd will also be searched for /wrapper folder and project - but with lower precedence in the resultset (later in list) |
||||
proc get_wrapper_folders {{scriptpath ""}} { |
||||
set wrapper_folders [list] |
||||
if {$scriptpath ne ""} { |
||||
if {[file type $scriptpath] eq "file"} { |
||||
set searchbase [file dirname $scriptpath] |
||||
} else { |
||||
set searchbase $scriptpath |
||||
} |
||||
if {[file isdirectory [file join $searchbase wrappers]]} { |
||||
lappend wrapper_folders [file join $searchbase wrappers] |
||||
} |
||||
set pathinfo [punk::repo::find_repos $searchbase] |
||||
set scriptpath_projectroot [dict get $pathinfo closest] |
||||
if {$scriptpath_projectroot ne ""} { |
||||
set fld [file join $scriptpath_projectroot src/scriptapps/wrappers] |
||||
if {[file isdirectory $fld]} { |
||||
if {$fld ni $wrapper_folders} { |
||||
lappend wrapper_folders $fld |
||||
} |
||||
} |
||||
} |
||||
} |
||||
set searchbase [pwd] |
||||
set fld [file join $searchbase wrappers] |
||||
if {[file isdirectory $fld]} { |
||||
if {$fld ni $wrapper_folders} { |
||||
lappend wrapper_folders $fld |
||||
} |
||||
} |
||||
set pathinfo [punk::repo::find_repos $searchbase] |
||||
set pwd_projectroot [dict get $pathinfo closest] |
||||
if {$pwd_projectroot ne ""} { |
||||
set fld [file join $pwd_projectroot src/scriptapps/wrappers] |
||||
if {[file isdirectory $fld]} { |
||||
if {$fld ni $wrapper_folders} { |
||||
lappend wrapper_folders $fld |
||||
} |
||||
} |
||||
} |
||||
|
||||
set template_base_dict [punk::mix::base::lib::get_template_basefolders] |
||||
set tpldirs [list] |
||||
dict for {tdir tsourceinfo} $template_base_dict { |
||||
if {[file exists $tdir/utility/scriptappwrappers]} { |
||||
lappend tpldirs $tdir |
||||
} |
||||
} |
||||
foreach tpldir $tpldirs { |
||||
set fld [file join $tpldir utility scriptappwrappers] |
||||
if {[file isdirectory $fld]} { |
||||
if {$fld ni $wrapper_folders} { |
||||
lappend wrapper_folders $fld |
||||
} |
||||
} |
||||
} |
||||
return $wrapper_folders |
||||
} |
||||
proc _scriptapp_tag_from_line {line} { |
||||
set result [list istag 0 raw ""] ;#default assumption. All |
||||
#---- |
||||
set startc [string first "#" $line] ;#tags must be commented |
||||
#todo - review. next line is valid - note # doesn't have to be the only one before <tagname> |
||||
# @REM # etc < blah # <tagname> etc |
||||
#--- |
||||
#fix - we should use a regexp on at least <tagname> </tagname> <tagname/> and only catch tagname without whitespace |
||||
regexp {(\s*).*} $line _ln indent ;#will match on empty line, whitespace only line - or anything really. |
||||
set indent [string map [list \t " "] $indent] ;#opinionated I guess - but need to normalize to something. The spec is that spaces should be used anyway. |
||||
dict set result indent [string length $indent] |
||||
set starttag [string first "<" $line] |
||||
set pretag [string range $line $startc $starttag-1] |
||||
if {[string match "*>*" $pretag]} { |
||||
return [list istag 0 raw $line reason pretag_contents] |
||||
} |
||||
set closetag [string first ">" $line] |
||||
set inelement [string range $line $starttag+1 $closetag-1] |
||||
if {[string match "*<*" $inelement]} { |
||||
return [list istag 0 raw $line reason tag_malformed_angles] |
||||
} |
||||
set elementchars [split $inelement ""] |
||||
set numslashes [llength [lsearch -all $elementchars "/"]] |
||||
if {$numslashes == 0} { |
||||
dict set result type "open" |
||||
} elseif {$numslashes == 1} { |
||||
if {[lindex $elementchars 0] eq "/"} { |
||||
dict set result type "close" |
||||
} elseif {[lindex $elementchars end] eq "/"} { |
||||
dict set result type "openclose" |
||||
} else { |
||||
return [list istag 0 raw $line reason tag_malformed_slashes] |
||||
} |
||||
} else { |
||||
return [list istag 0 raw $line reason tag_malformed_extraslashes] |
||||
} |
||||
if {[dict get $result type] eq "open"} { |
||||
dict set result name $inelement |
||||
} elseif {[dict get $result type] eq "close"} { |
||||
dict set result name [string range $inelement 1 end] |
||||
} else { |
||||
dict set result name [string range $inelement 0 end-1] |
||||
} |
||||
dict set result istag 1 |
||||
dict set result raw $line |
||||
return $result |
||||
} |
||||
|
||||
#get all \n#<something>\n ...\n#</something> data - where number of intervening newlines is at least one (and whitespace and/or other data can precede #) |
||||
#we don't verify 'something' against known tags - as custom templates can have own tags |
||||
#An openclose tag #<xxx/> is used to substitute a specific line in its entirety - but the tag *must* remain in the line |
||||
# |
||||
#e.g for the line: |
||||
# @set "nextshell=pwsh" & :: #<batch-nextshell-line/> |
||||
#The .wrapconfig might contain |
||||
# tag <batch-nextshell-line> line {@set "nextshell=tclsh" & :: @<batch-nextshell-line/>} |
||||
# |
||||
proc scriptapp_wrapper_get_tags {wrapperdata} { |
||||
set wrapperdata [string map [list \r\n \n] $wrapperdata] |
||||
set lines [split $wrapperdata \n] |
||||
#set tags_in_data [dict create];#active tags - list of lines accumulating. supports nested tags |
||||
set status 0 |
||||
set tags [dict create] |
||||
set errors [list] |
||||
set errortags [dict create] ;#mark names invalid on first error so that more than 2 tags can't obscure config problem |
||||
set linenum 1 ;#editors and other utils use 1-based indexing when referencing files - we should too to avoid confusion, despite it being less natural for lindex operations on the result. |
||||
foreach ln $lines { |
||||
set lntrim [string trim $ln] |
||||
if {![string length $lntrim]} { |
||||
incr linenum |
||||
continue |
||||
} |
||||
if {[string match "*#*<*>*" $lntrim]} { |
||||
set taginfo [_scriptapp_tag_from_line $ln] ;#use untrimmed line - to get indent |
||||
if {[dict get $taginfo istag]} { |
||||
set nm [dict get $taginfo name] |
||||
if {[dict exists $errortags $nm]} { |
||||
#tag is already in error condition - |
||||
} else { |
||||
set tp [dict get $taginfo type] ;# type singular - related to just one line |
||||
#set raw [dict get $taginfo raw] #equivalent to $ln |
||||
if {[dict exists $tags $nm]} { |
||||
#already seen tag name |
||||
#tags dict has types key *plural* - need to track whether we have type open and type close (or openclose for self-closing tags) |
||||
if {[dict get $tags $nm types] ne "open"} { |
||||
lappend errors "line: $linenum tag $nm encountered type $tp after existing type [dict get $tags $nm types]" |
||||
dict incr errortags $nm |
||||
} else { |
||||
#we already have open - expect only close |
||||
if {$tp ne "close"} { |
||||
lappend errors "line: $linenum tag $nm encountered type $tp after existing type [dict get $tags $nm types]" |
||||
dict incr errortags $nm |
||||
} else { |
||||
#close after open |
||||
dict set tags $nm types [list open close] |
||||
dict set tags $nm end $linenum |
||||
set taglines [dict get $tags $nm taglines] |
||||
if {[llength $taglines] != 1} { |
||||
error "Unexpected result when closing tag $nm. Existing taglines length not 1." |
||||
} |
||||
dict set tags $nm taglines [concat $taglines $ln] |
||||
} |
||||
} |
||||
} else { |
||||
#first seen of tag name |
||||
if {$tp eq "close"} { |
||||
lappend errors "line: $linenum tag $nm encountered type $p close first" |
||||
dict incr errortags $nm |
||||
} else { |
||||
dict set tags $nm types $tp |
||||
dict set tags $nm indent [dict get $taginfo indent] |
||||
if {$tp eq "open"} { |
||||
dict set tags $nm start $linenum |
||||
dict set tags $nm taglines [list $ln] ;#first entry - another will be added on encountering matching closing tag |
||||
} elseif {$tp eq "openclose"} { |
||||
dict set tags $nm start $linenum |
||||
dict set tags $nm end $linenum |
||||
dict set tags $nm taglines [list $ln] ;#single entry is final result for self-closing tag |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} else { |
||||
#looks like it should be a tag.. but failed to even parse for some reason.. just add to errorlist |
||||
lappend errors "line: $linenum tag parse failure reason: [dict get $taginfo reason] raw line: [dict get $taginfo raw]" |
||||
} |
||||
} |
||||
#whether the line is tag or not append to any tags_in_data |
||||
#foreach t [dict keys $tags_in_data] { |
||||
# dict lappend tags_in_data $t $ln ;#accumulate raw lines - written to the tag entry in tags only on encountering a closing tag, then removed from tags_in_data |
||||
#} |
||||
incr linenum |
||||
} |
||||
#assert [expr {$linenum -1 == [llength $lines]}] |
||||
if {[llength $errors]} { |
||||
set status 0 |
||||
} else { |
||||
set status 1 |
||||
} |
||||
if {$linenum == 0} { |
||||
|
||||
} |
||||
return [dict create ok $status linecount [llength $lines] data $tags errors $errors] |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::commandset::scriptwrap [namespace eval punk::mix::commandset::scriptwrap { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -1,84 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::templates 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
package require punk::cap |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::templates { |
||||
variable pkg punk::mix::templates |
||||
variable cap_provider |
||||
|
||||
#punk::cap::register_package punk::mix::templates [list\ |
||||
# {punk.templates {relpath ../templates}}\ |
||||
#] |
||||
|
||||
namespace eval capsystem { |
||||
if {[info commands capprovider.registration] eq ""} { |
||||
punk::cap::class::interface_capprovider.registration create capprovider.registration |
||||
oo::objdefine capprovider.registration { |
||||
method get_declarations {} { |
||||
set decls [list] |
||||
lappend decls [list punk.templates {relpath ../templates}] |
||||
lappend decls [list punk.templates {relpath ../templates2}] |
||||
lappend decls [list punk.test {something blah}] |
||||
return $decls |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {[info commands provider] eq ""} { |
||||
punk::cap::class::interface_capprovider.provider create provider punk::mix::templates |
||||
oo::objdefine provider { |
||||
method register {{capabilityname_glob *}} { |
||||
#puts registering punk::mix::templates $capabilityname |
||||
next |
||||
} |
||||
method capabilities {} { |
||||
next |
||||
} |
||||
} |
||||
} |
||||
|
||||
# -- --- |
||||
#provider api |
||||
# -- --- |
||||
#none - declarations only |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::templates [namespace eval punk::mix::templates { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -1,350 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::mix::util 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
namespace eval punk::mix::util { |
||||
variable has_winpath 0 |
||||
} |
||||
|
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
if {![catch {package require punk::winpath}]} { |
||||
set punk::mix::util::has_winpath 1 |
||||
} |
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::mix::util { |
||||
variable tmpfile_counter 0 ;#additional tmpfile collision avoidance |
||||
|
||||
namespace export * |
||||
|
||||
|
||||
proc fcat {args} { |
||||
variable has_winpath |
||||
|
||||
if {$::tcl_platform(platform) ne "windows"} { |
||||
return [fileutil::cat {*}$args] |
||||
} |
||||
|
||||
set knownopts [list -eofchar -translation -encoding --] |
||||
set last_opt 0 |
||||
for {set i 0} {$i < [llength $args]} {incr i} { |
||||
set ival [lindex $args $i] |
||||
#puts stdout "i:$i a: $ival known: [expr {$ival in $knownopts}]" |
||||
if {$ival eq "--"} { |
||||
set last_opt $i |
||||
break |
||||
} else { |
||||
if {$ival in $knownopts} { |
||||
#puts ">known at $i : [lindex $args $i]" |
||||
if {($i % 2) != 0} { |
||||
error "unexpected option at index $i. known options: $knownopts must come in -opt val pairs." |
||||
} |
||||
incr i |
||||
set last_opt $i |
||||
} else { |
||||
set last_opt [expr {$i - 1}] |
||||
break |
||||
} |
||||
} |
||||
} |
||||
set first_non_opt [expr {$last_opt + 1}] |
||||
|
||||
#puts stderr "first_non_opt: $first_non_opt" |
||||
set opts [lrange $args -1 $first_non_opt-1] |
||||
set paths [lrange $args $first_non_opt end] |
||||
if {![llength $paths]} { |
||||
error "Unable to find file in the supplied arguments: $args. Ensure options are all -opt val pairs and that file name(s) follow" |
||||
} |
||||
#puts stderr "opts: $opts paths: $paths" |
||||
set finalpaths [list] |
||||
foreach p $paths { |
||||
if {$has_winpath && [punk::winpath::illegalname_test $p]} { |
||||
lappend finalpaths [punk::winpath::illegalname_fix $p] |
||||
} else { |
||||
lappend finalpaths $p |
||||
} |
||||
} |
||||
fileutil::cat {*}$opts {*}$finalpaths |
||||
} |
||||
|
||||
#---------------------------------------- |
||||
namespace eval internal { |
||||
proc path_common_prefix_pop {varname} { |
||||
upvar 1 $varname var |
||||
set var [lassign $var head] |
||||
return $head |
||||
} |
||||
} |
||||
proc path_common_prefix {args} { |
||||
set dirs $args |
||||
set parts [file split [internal::path_common_prefix_pop dirs]] |
||||
while {[llength $dirs]} { |
||||
set r {} |
||||
foreach cmp $parts elt [file split [internal::path_common_prefix_pop dirs]] { |
||||
if {$cmp ne $elt} break |
||||
lappend r $cmp |
||||
} |
||||
set parts $r |
||||
} |
||||
if {[llength $parts]} { |
||||
return [file join {*}$parts] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
|
||||
#retains case from first argument only - caseless comparison |
||||
proc path_common_prefix_nocase {args} { |
||||
set dirs $args |
||||
set parts [file split [internal::path_common_prefix_pop dirs]] |
||||
while {[llength $dirs]} { |
||||
set r {} |
||||
foreach cmp $parts elt [file split [internal::path_common_prefix_pop dirs]] { |
||||
if {![string equal -nocase $cmp $elt]} break |
||||
lappend r $cmp |
||||
} |
||||
set parts $r |
||||
} |
||||
if {[llength $parts]} { |
||||
return [file join {*}$parts] |
||||
} else { |
||||
return "" |
||||
} |
||||
} |
||||
#---------------------------------------- |
||||
|
||||
#namespace import ::punk::ns::nsimport_noclobber |
||||
|
||||
proc namespace_import_pattern_to_namespace_noclobber {pattern ns} { |
||||
set source_ns [namespace qualifiers $pattern] |
||||
if {![namespace exists $source_ns]} { |
||||
error "namespace_import_pattern_to_namespace_noclobber error namespace $source_ns not found" |
||||
} |
||||
if {![string match ::* $ns]} { |
||||
set nscaller [uplevel 1 {namespace current}] |
||||
set ns [punk::nsjoin $nscaller $ns] |
||||
} |
||||
set a_export_patterns [namespace eval $source_ns {namespace export}] |
||||
set a_commands [info commands $pattern] |
||||
set a_tails [lmap v $a_commands {namespace tail $v}] |
||||
set a_exported_tails [list] |
||||
foreach pattern $a_export_patterns { |
||||
set matches [lsearch -all -inline $a_tails $pattern] |
||||
foreach m $matches { |
||||
if {$m ni $a_exported_tails} { |
||||
lappend a_exported_tails $m |
||||
} |
||||
} |
||||
} |
||||
set imported_commands [list] |
||||
foreach e $a_exported_tails { |
||||
set imported [namespace eval $ns [string map [list <func> $e <a> $source_ns] { |
||||
set cmd "" |
||||
if {![catch {namespace import <a>::<func>}]} { |
||||
set cmd <func> |
||||
} |
||||
set cmd |
||||
}]] |
||||
if {[string length $imported]} { |
||||
lappend imported_commands $imported |
||||
} |
||||
} |
||||
return $imported_commands |
||||
} |
||||
|
||||
proc askuser {question} { |
||||
puts stdout $question |
||||
flush stdout |
||||
set stdin_state [fconfigure stdin] |
||||
fconfigure stdin -blocking 1 |
||||
set answer [gets stdin] |
||||
fconfigure stdin -blocking [dict get $stdin_state -blocking] |
||||
return $answer |
||||
} |
||||
|
||||
proc do_in_path {path script} { |
||||
#from ::kettle::path::in |
||||
set here [pwd] |
||||
try { |
||||
cd $path |
||||
uplevel 1 $script |
||||
} finally { |
||||
cd $here |
||||
} |
||||
} |
||||
|
||||
proc foreach-file {path script_pathvariable script} { |
||||
upvar 1 $script_pathvariable thepath |
||||
|
||||
set known {} |
||||
lappend waiting $path |
||||
while {[llength $waiting]} { |
||||
set pending $waiting |
||||
set waiting {} |
||||
set at 0 |
||||
while {$at < [llength $pending]} { |
||||
set current [lindex $pending $at] |
||||
incr at |
||||
|
||||
# Do not follow into parent. |
||||
if {[string match *.. $current]} continue |
||||
|
||||
# Ignore what we have visited already. |
||||
set c [file dirname [file normalize $current/___]] |
||||
if {[dict exists $known $c]} continue |
||||
dict set known $c . |
||||
|
||||
if {[file tail $c] eq ".git"} { |
||||
continue |
||||
} |
||||
|
||||
# Expand directories. |
||||
if {[file isdirectory $c]} { |
||||
lappend waiting {*}[lsort -unique [glob -directory $c * .*]] |
||||
continue |
||||
} |
||||
|
||||
# Handle files as per the user's will. |
||||
set thepath $current |
||||
switch -exact -- [catch { uplevel 1 $script } result] { |
||||
0 - 4 { |
||||
# ok, continue - nothing |
||||
} |
||||
2 { |
||||
# return, abort, rethrow |
||||
return -code return |
||||
} |
||||
3 { |
||||
# break, abort |
||||
return |
||||
} |
||||
1 - default { |
||||
# error, any thing else - rethrow |
||||
return -code error $result |
||||
} |
||||
} |
||||
} |
||||
} |
||||
return |
||||
} |
||||
|
||||
proc is_valid_tm_version {versionpart} { |
||||
#Needs to be suitable for use with Tcl's 'package vcompare' |
||||
if {![catch [list package vcompare $versionpart $versionpart]]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
#Note that semver only has a small overlap with tcl tm versions. |
||||
#todo - work out what overlap and whether it's even useful |
||||
#see also TIP #439: Semantic Versioning (tcl 9??) |
||||
proc semver {versionstring} { |
||||
set re {^(0|[1-9]\d*)\.(0|[1-9]\d*)\.(0|[1-9]\d*)(?:-((?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*)(?:\.(?:0|[1-9]\d*|\d*[a-zA-Z-][0-9a-zA-Z-]*))*))?(?:\+([0-9a-zA-Z-]+(?:\.[0-9a-zA-Z-]+)*))?$} |
||||
} |
||||
#todo - semver conversion/validation for other systems? |
||||
proc magic_tm_version {} { |
||||
set magicbase 999999 ;#deliberately large so given load-preference when testing! |
||||
#we split the literal to avoid the literal appearing here - reduce risk of accidentally converting to a release version |
||||
return ${magicbase}.0a1.0 |
||||
} |
||||
|
||||
|
||||
|
||||
proc tmpfile {{prefix tmp_}} { |
||||
#note risk of collision if pregenerating a list of tmpfile names |
||||
#we will maintain an icrementing id so the caller doesn't have to bear that in mind |
||||
variable tmpfile_counter |
||||
global tcl_platform |
||||
return .punkutil_$prefix[pid]_[clock microseconds]_[incr tmpfile_counter]_[info hostname]_$tcl_platform(user) |
||||
} |
||||
|
||||
proc tmpdir {} { |
||||
# Taken from tcllib fileutil. |
||||
global tcl_platform env |
||||
|
||||
set attempdirs [list] |
||||
set problems {} |
||||
|
||||
foreach tmp {TEMP TMP TMPDIR} { |
||||
if { [info exists env($tmp)] } { |
||||
lappend attempdirs $env($tmp) |
||||
} else { |
||||
lappend problems "No environment variable $tmp" |
||||
} |
||||
} |
||||
|
||||
switch $tcl_platform(platform) { |
||||
windows { |
||||
lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP" |
||||
} |
||||
macintosh { |
||||
lappend attempdirs $env(TRASH_FOLDER) ;# a better place? |
||||
} |
||||
default { |
||||
lappend attempdirs \ |
||||
[file join / tmp] \ |
||||
[file join / var tmp] \ |
||||
[file join / usr tmp] |
||||
} |
||||
} |
||||
|
||||
lappend attempdirs [pwd] |
||||
|
||||
foreach tmp $attempdirs { |
||||
if { [file isdirectory $tmp] && |
||||
[file writable $tmp] } { |
||||
return [file normalize $tmp] |
||||
} elseif { ![file isdirectory $tmp] } { |
||||
lappend problems "Not a directory: $tmp" |
||||
} else { |
||||
lappend problems "Not writable: $tmp" |
||||
} |
||||
} |
||||
|
||||
# Fail if nothing worked. |
||||
return -code error "Unable to determine a proper directory for temporary files\n[join $problems \n]" |
||||
} |
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::mix::util [namespace eval punk::mix::util { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
File diff suppressed because it is too large
Load Diff
@ -1,159 +0,0 @@
|
||||
|
||||
|
||||
package require punk::mix::util |
||||
|
||||
namespace eval ::punk::overlay { |
||||
#based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend |
||||
# extend an ensemble-like routine with the routines in some namespace |
||||
# |
||||
# e.g custom_from_base ::punk::mix::cli ::punk::mix::base |
||||
# |
||||
proc custom_from_base {routine base} { |
||||
if {![string match ::* $routine]} { |
||||
set resolved [uplevel 1 [list ::namespace which $routine]] |
||||
if {$resolved eq {}} { |
||||
error [list {no such routine} $routine] |
||||
} |
||||
set routine $resolved |
||||
} |
||||
set routinens [namespace qualifiers $routine] |
||||
if {$routinens eq {::}} { |
||||
set routinens {} |
||||
} |
||||
set routinetail [namespace tail $routine] |
||||
|
||||
if {![string match ::* $base]} { |
||||
set base [uplevel 1 [ |
||||
list [namespace which namespace] current]]::$base |
||||
} |
||||
|
||||
if {![namespace exists $base]} { |
||||
error [list {no such namespace} $base] |
||||
} |
||||
|
||||
set base [namespace eval $base [ |
||||
list [namespace which namespace] current]] |
||||
|
||||
|
||||
#while 1 { |
||||
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||
# if {[namespace which $renamed] eq {}} break |
||||
#} |
||||
|
||||
namespace eval $routine [ |
||||
list namespace ensemble configure $routine -unknown [ |
||||
list apply {{base ensemble subcommand args} { |
||||
list ${base}::_redirected $ensemble $subcommand |
||||
}} $base |
||||
] |
||||
] |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util |
||||
#namespace eval ${routine}::util { |
||||
#namespace import ::punk::mix::util::* |
||||
#} |
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib |
||||
#namespace eval ${routine}::lib [string map [list <base> $base] { |
||||
# namespace import <base>::lib::* |
||||
#}] |
||||
|
||||
namespace eval ${routine}::lib [string map [list <base> $base <routine> $routine] { |
||||
if {[namespace exists <base>::lib]} { |
||||
set current_paths [namespace path] |
||||
if {"<routine>" ni $current_paths} { |
||||
lappend current_paths <routine> |
||||
} |
||||
namespace path $current_paths |
||||
} |
||||
}] |
||||
|
||||
namespace eval $routine { |
||||
set exportlist [list] |
||||
foreach cmd [info commands [namespace current]::*] { |
||||
set c [namespace tail $cmd] |
||||
if {![string match _* $c]} { |
||||
lappend exportlist $c |
||||
} |
||||
} |
||||
namespace export {*}$exportlist |
||||
} |
||||
|
||||
return $routine |
||||
} |
||||
#load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix |
||||
#Note: commandset may be imported by different CLIs with different bases *at the same time* |
||||
#so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) |
||||
#we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. |
||||
#commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they |
||||
#want the convenience of using lib:xxx with commands coming from those packages. |
||||
#This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. |
||||
#The basic principle is that the commandset is loaded into the caller(s) with a prefix |
||||
#- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) |
||||
proc import_commandset {prefix separator cmdnamespace} { |
||||
set bad_seps [list "::"] |
||||
if {$separator in $bad_seps} { |
||||
error "import_commandset invalid separator '$separator'" |
||||
} |
||||
#namespace may or may not be a package |
||||
# allow with or without leading :: |
||||
if {[string range $cmdnamespace 0 1] eq "::"} { |
||||
set cmdpackage [string range $cmdnamespace 2 end] |
||||
} else { |
||||
set cmdpackage $cmdnamespace |
||||
set cmdnamespace ::$cmdnamespace |
||||
} |
||||
|
||||
if {![namespace exists $cmdnamespace]} { |
||||
#only do package require if the namespace not already present |
||||
catch {package require $cmdpackage} pkg_load_info |
||||
#recheck |
||||
if {![namespace exists $cmdnamespace]} { |
||||
set prov [package provide $cmdpackage] |
||||
if {[string length $prov]} { |
||||
set provinfo "(package $cmdpackage is present with version $prov)" |
||||
} else { |
||||
set provinfo "(package $cmdpackage not present)" |
||||
} |
||||
error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" |
||||
} |
||||
} |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util |
||||
|
||||
#let child namespace 'lib' resolve parent namespace and thus util::xxx |
||||
namespace eval ${cmdnamespace}::lib [string map [list <cmdns> $cmdnamespace] { |
||||
set nspaths [namespace path] |
||||
if {"<cmdns>" ni $nspaths} { |
||||
lappend nspaths <cmdns> |
||||
} |
||||
namespace path $nspaths |
||||
}] |
||||
|
||||
set imported_commands [list] |
||||
set nscaller [uplevel 1 [list namespace current]] |
||||
if {[catch { |
||||
#review - noclobber? |
||||
namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] |
||||
foreach cmd [info commands ${nscaller}::temp_import::*] { |
||||
set cmdtail [namespace tail $cmd] |
||||
if {$cmdtail eq "_default"} { |
||||
set import_as ${nscaller}::${prefix} |
||||
} else { |
||||
set import_as ${nscaller}::${prefix}${separator}${cmdtail} |
||||
} |
||||
rename $cmd $import_as |
||||
lappend imported_commands $import_as |
||||
} |
||||
} errM]} { |
||||
puts stderr "Error loading commandset $prefix $separator $cmdnamespace" |
||||
puts stderr "err: $errM" |
||||
} |
||||
return $imported_commands |
||||
} |
||||
} |
||||
|
||||
|
||||
package provide punk::overlay [namespace eval punk::overlay { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
@ -1,397 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::path 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin punkshell_module_punk::path 0 0.1.0] |
||||
#[copyright "2023"] |
||||
#[titledesc {Filesystem path utilities}] [comment {-- Name section and table of contents description --}] |
||||
#[moddesc {punk path filesystem utils}] [comment {-- Description at end of page heading --}] |
||||
#[require punk::path] |
||||
#[description] |
||||
#[keywords module path filesystem] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section Overview] |
||||
#[para] overview of punk::path |
||||
#[para] Filesystem path utility functions |
||||
#[subsection Concepts] |
||||
#[para] - |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[subsection dependencies] |
||||
#[para] packages used by punk::path |
||||
#[list_begin itemized] |
||||
|
||||
package require Tcl 8.6 |
||||
#*** !doctools |
||||
#[item] [package {Tcl 8.6}] |
||||
|
||||
# #package require frobz |
||||
# #*** !doctools |
||||
# #[item] [package {frobz}] |
||||
|
||||
#*** !doctools |
||||
#[list_end] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
#*** !doctools |
||||
#[section API] |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# oo::class namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::path::class { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::path::class}] |
||||
#[para] class definitions |
||||
if {[info commands [namespace current]::interface_sample1] eq ""} { |
||||
#*** !doctools |
||||
#[list_begin enumerated] |
||||
|
||||
# oo::class create interface_sample1 { |
||||
# #*** !doctools |
||||
# #[enum] CLASS [class interface_sample1] |
||||
# #[list_begin definitions] |
||||
|
||||
# method test {arg1} { |
||||
# #*** !doctools |
||||
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||
# #[para] test method |
||||
# puts "test: $arg1" |
||||
# } |
||||
|
||||
# #*** !doctools |
||||
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||
# } |
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end class enumeration ---}] |
||||
} |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Base namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::path { |
||||
namespace export * |
||||
#variable xyz |
||||
|
||||
#*** !doctools |
||||
#[subsection {Namespace punk::path}] |
||||
#[para] Core API functions for punk::path |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
proc pathglob_as_re {pathglob} { |
||||
#*** !doctools |
||||
#[call [fun pathglob_as_re] [arg pathglob]] |
||||
#[para] Returns a regular expression for matching a path to a glob pattern which can contain glob chars *|? in any segment of the path structure |
||||
#[para] ** matches any number of subdirectories. |
||||
#[para] e.g /etc/**/*.txt will match any .txt files at any depth below /etc (except directly within /etc itself) |
||||
#[para] e.g /etc/**.txt will match any .txt files at any depth below /etc |
||||
#[para] any segment that does not contain ** must match exactly one segment in the path |
||||
#[para] e.g the glob /etc/*/*.doc - will match any .doc files that are exactly one tree level below /etc |
||||
#[para] The pathglob doesn't have to contain glob characters, in which case the returned regex will match the pathglob exactly as specified. |
||||
#[para] Regular expression syntax is deliberateley not supported within the pathglob string so that supplied regex characters will be treated as literals |
||||
|
||||
|
||||
#todo - consider whether a way to escape the glob chars ? * is practical - to allow literals ? * |
||||
# - would require counting immediately-preceding backslashes |
||||
set pats [list] |
||||
foreach seg [file split $pathglob] { |
||||
if {[string range $seg end end] eq "/"} { |
||||
set seg [string range $seg 0 end-1] ;# e.g c:/ -> c: / -> "" so that join at end doesn't double up |
||||
} |
||||
if {$seg eq "*"} { |
||||
lappend pats {[^/]*} |
||||
} elseif {$seg eq "**"} { |
||||
lappend pats {.*} |
||||
} else { |
||||
set seg [string map [list {^ {\^} $ {\$} [} {\[} ( {\(} \{ \\\{ \\ {\\}] $seg] ;#treat regex characters in the input as literals |
||||
set seg [string map [list . {[.]}] $seg] |
||||
if {[regexp {[*?]} $seg]} { |
||||
set pat [string map [list ** {.*} * {[^/]*} ? {[^/]}] $seg] |
||||
lappend pats "$pat" |
||||
} else { |
||||
lappend pats "$seg" |
||||
} |
||||
} |
||||
} |
||||
return "^[join $pats /]\$" |
||||
} |
||||
proc globmatchpath {pathglob path args} { |
||||
#*** !doctools |
||||
#[call [fun globmatchpath] [arg pathglob] [arg path] [opt {option value...}]] |
||||
#[para] Return true if the pathglob matches the path |
||||
#[para] see [fun pathglob_as_re] for pathglob description |
||||
#[para] Caller must ensure that file separator is forward slash. (e.g use file normalize on windows) |
||||
#[para] |
||||
#[para] Known options: |
||||
#[para] -nocase 0|1 (default 0 - case sensitive) |
||||
#[para] If -nocase is not supplied - default to case sensitive *except for driveletter* |
||||
#[para] ie - the driveletter alone in paths such as c:/etc will still be case insensitive. (ie c:/ETC/* will match C:/ETC/blah but not C:/etc/blah) |
||||
#[para] Explicitly specifying -nocase 0 will require the entire case to match including the driveletter. |
||||
|
||||
set defaults [dict create\ |
||||
-nocase \uFFFF\ |
||||
] |
||||
set known_opts [dict keys $defaults] |
||||
set opts [dict merge $defaults $args] |
||||
dict for {k v} $args { |
||||
if {$k ni $known_opts} { |
||||
error "Unrecognised options $k - known options: $known_opts" |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- |
||||
set opt_nocase [dict get $opts -nocase] |
||||
set explicit_nocase 1 ;#default to disprove |
||||
if {$opt_nocase eq "\uFFFF"} { |
||||
set opt_nocase 0 |
||||
set explicit_nocase 0 |
||||
} |
||||
# -- --- --- --- --- --- |
||||
if {$opt_nocase} { |
||||
return [regexp -nocase [pathglob_as_re $pathglob] $path] |
||||
} else { |
||||
set re [pathglob_as_re $pathglob] |
||||
if {$explicit_nocase} { |
||||
set ismatch [regexp $re $path] ;#explicit -nocase 0 - require exact match of path literals including driveletter |
||||
} else { |
||||
#caller is using default for -nocase - which indicates case sensitivity - but we have an exception for the driveletter. |
||||
set re_segments [file split $re] ;#Note that file split c:/etc gives {c:/ etc} but file split ^c:/etc gives {^c: etc} |
||||
set first_seg [lindex $re_segments 0] |
||||
if {[regexp {^\^(.{1}):$} $first_seg _match driveletter]} { |
||||
#first part of re is like "^c:" i.e a drive letter |
||||
set chars [string tolower $driveletter][string toupper $driveletter] |
||||
set re [join [concat "^\[$chars\]:" [lrange $re_segments 1 end]] /] ;#rebuild re with case insensitive driveletter only - use join - not file join. file join will misinterpret leading re segment. |
||||
} |
||||
#puts stderr "-->re: $re" |
||||
set ismatch [regexp $re $path] |
||||
} |
||||
} |
||||
return $ismatch |
||||
} |
||||
|
||||
#todo - implement treefiles which acts like dirfiles but allows path globbing in the same way as punk::ns::ns/ |
||||
#then review if treefiles can replace dirfiles or if both should exist (dirfiles can have literal glob chars in path segments - but that is a rare usecase) |
||||
proc treefilenames {basepath tailglob args} { |
||||
#*** !doctools |
||||
#[call [fun treefilenames] [arg basepath] [arg tailglob] [opt {option value...}]] |
||||
#basic (glob based) list of filenames matching tailglob - recursive |
||||
#no natsorting - so order is dependent on filesystem |
||||
set defaults [dict create\ |
||||
-call-depth-internal 0\ |
||||
-antiglob_paths {}\ |
||||
] |
||||
set opts [dict merge $defaults $args] |
||||
set opt_antiglob_paths [dict get $opts -antiglob_paths] |
||||
set CALLDEPTH [dict get $opts -call-depth-internal] |
||||
|
||||
set files [list] |
||||
if {$CALLDEPTH == 0} { |
||||
if {![file isdirectory $basepath]} { |
||||
return [list] |
||||
} |
||||
} |
||||
|
||||
set skip 0 |
||||
foreach anti $opt_antiglob_paths { |
||||
if {[globmatchpath $anti $basepath]} { |
||||
set skip 1 |
||||
break |
||||
} |
||||
} |
||||
if {$skip} { |
||||
return [list] |
||||
} |
||||
|
||||
#todo - account for vfs where matched path could appear to be a directory but is mounted so could be a desired match? |
||||
set dirfiles [glob -nocomplain -dir $basepath -type f $tailglob] |
||||
lappend files {*}$dirfiles |
||||
set dirdirs [glob -nocomplain -dir $basepath -type d *] |
||||
foreach dir $dirdirs { |
||||
set skip 0 |
||||
foreach anti $opt_antiglob_paths { |
||||
if {[globmatchpath $anti $dir]} { |
||||
set skip 1 |
||||
break |
||||
} |
||||
} |
||||
if {$skip} { |
||||
continue |
||||
} |
||||
set nextargs [dict merge $args [list -call-depth-internal [incr CALLDEPTH]]] |
||||
lappend files {*}[treefilenames $dir $tailglob {*}$nextargs] |
||||
} |
||||
return $files |
||||
} |
||||
|
||||
#maint warning - also in punkcheck |
||||
proc relative {reference location} { |
||||
#*** !doctools |
||||
#[call [fun relative] [arg reference] [arg location]] |
||||
#[para] Taking two directory paths, a reference and a location, computes the path |
||||
# of the location relative to the reference. |
||||
#[list_begin itemized] |
||||
#[item] |
||||
#[para] Arguments: |
||||
# [list_begin arguments] |
||||
# [arg_def string reference] The path from which the relative path to location is determined. |
||||
# [arg_def string location] The location path which may be above or below the reference path |
||||
# [list_end] |
||||
#[item] |
||||
#[para] Results: |
||||
#[para] The relative path of the location to the reference path. |
||||
#[para] Will return a single dot "." if the paths are the same |
||||
#[item] |
||||
#[para] Notes: |
||||
#[para] Both paths must be the same type - ie both absolute or both relative |
||||
#[para] Case sensitive. ie relative /etc /etC |
||||
# will return ../etC |
||||
#[para] On windows, the drive-letter component (only) is not case sensitive |
||||
#[para] ie relative c:/etc C:/etc returns . |
||||
#[para] but relative c:/etc C:/Etc returns ../Etc |
||||
#[para] On windows, if the paths are absolute and specifiy different volumes, only the location will be returned. |
||||
# ie relative c:/etc d:/etc/blah |
||||
# returns d:/etc/blah |
||||
#[list_end] |
||||
|
||||
#see also kettle |
||||
# Modified copy of ::fileutil::relative (tcllib) |
||||
# Adapted to 8.5 ({*}). |
||||
|
||||
#review - check volume info on windows.. UNC paths? |
||||
if {[file pathtype $reference] ne [file pathtype $location]} { |
||||
return -code error "Unable to compute relation for paths of different pathtypes: [file pathtype $reference] vs. [file pathtype $location], ($reference vs. $location)" |
||||
} |
||||
|
||||
#avoid normalizing if possible (file normalize *very* expensive on windows) |
||||
set do_normalize 0 |
||||
if {[file pathtype $reference] eq "relative"} { |
||||
#if reference is relative so is location |
||||
if {[regexp {[.]{2}} [list $reference $location]]} { |
||||
set do_normalize 1 |
||||
} |
||||
if {[regexp {[.]/} [list $reference $location]]} { |
||||
set do_normalize 1 |
||||
} |
||||
} else { |
||||
set do_normalize 1 |
||||
} |
||||
if {$do_normalize} { |
||||
set reference [file normalize $reference] |
||||
set location [file normalize $location] |
||||
} |
||||
|
||||
set save $location |
||||
set reference [file split $reference] |
||||
set location [file split $location] |
||||
|
||||
while {[lindex $location 0] eq [lindex $reference 0]} { |
||||
set location [lrange $location 1 end] |
||||
set reference [lrange $reference 1 end] |
||||
if {![llength $location]} {break} |
||||
} |
||||
|
||||
set location_len [llength $location] |
||||
set reference_len [llength $reference] |
||||
|
||||
if {($location_len == 0) && ($reference_len == 0)} { |
||||
# Cases: |
||||
# (a) reference == location |
||||
|
||||
set location . |
||||
} else { |
||||
# Cases: |
||||
# (b) ref is: ref/sub = sub |
||||
# loc is: ref = {} |
||||
|
||||
# (c) ref is: ref = {} |
||||
# loc is: ref/sub = sub |
||||
|
||||
while {$reference_len > 0} { |
||||
set location [linsert $location 0 ..] |
||||
incr reference_len -1 |
||||
} |
||||
set location [file join {*}$location] |
||||
} |
||||
return $location |
||||
} |
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::path ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::path::lib { |
||||
namespace export * |
||||
namespace path [namespace parent] |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::path::lib}] |
||||
#[para] Secondary functions that are part of the API |
||||
#[list_begin definitions] |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
#*** !doctools |
||||
#[list_end] [comment {--- end definitions namespace punk::path::lib ---}] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[section Internal] |
||||
namespace eval punk::path::system { |
||||
#*** !doctools |
||||
#[subsection {Namespace punk::path::system}] |
||||
#[para] Internal functions that are not part of the API |
||||
|
||||
|
||||
|
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::path [namespace eval punk::path { |
||||
variable pkg punk::path |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
File diff suppressed because it is too large
Load Diff
@ -1,104 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::tdl 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::tdl { |
||||
# https://wiki.tcl-lang.org/page/Config+file+using+slave+interp |
||||
|
||||
variable sample_script { |
||||
server -name bsd1 -os FreeBSD |
||||
server -name p1 -os linux |
||||
server -name trillion -os windows |
||||
|
||||
server -name vmhost1 -os FreeBSD { |
||||
guest -name bsd1 -vmmanager iocage |
||||
guest -name p1 -vmmanager bhyve |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
proc prettyparse {script} { |
||||
set i [interp create -safe] |
||||
try { |
||||
# $i eval {unset {*}[info vars]} |
||||
# foreach command [$i eval {info commands}] {$i hide $command} |
||||
# $i invokehidden namespace delete {*}[$i invokehidden namespace children] |
||||
$i alias unknown apply {{i tag args} { |
||||
upvar 1 result result |
||||
set e [concat [list tag $tag]\ |
||||
[lrange $args 0 [expr {([llength $args] & ~1) - 1}]]] |
||||
if {[llength $args] % 2} { |
||||
set saved $result |
||||
set result {} |
||||
$i eval [lindex $args end] |
||||
lappend e body $result |
||||
set result $saved |
||||
} |
||||
lappend result $e |
||||
list |
||||
}} $i |
||||
set result {} |
||||
$i eval $script |
||||
return $result |
||||
} finally { |
||||
interp delete $i |
||||
} |
||||
} |
||||
proc prettyprint {data {level 0}} { |
||||
set ind [string repeat " " $level] |
||||
incr level |
||||
set result {} |
||||
foreach e $data { |
||||
set line $ind[concat [list [dict get $e tag]] [dict remove $e tag body]] |
||||
if {[dict exists $e body] && [llength [dict get $e body]]} { |
||||
append line " {\n[prettyprint [dict get $e body] $level]\n$ind}" |
||||
} |
||||
lappend result $line |
||||
} |
||||
join $result \n |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::tdl [namespace eval punk::tdl { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -1,266 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::winpath 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::winpath { |
||||
namespace export winpath windir cdwin cdwindir illegalname_fix illegalname_test |
||||
|
||||
|
||||
|
||||
|
||||
#\\servername\share etc or \\?\UNC\servername\share etc. |
||||
proc is_unc_path {path} { |
||||
set strcopy_path [punk::objclone $path] |
||||
set strcopy_path [string map [list \\ /] $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) |
||||
if {[string first "//" $strcopy_path] == 0} { |
||||
#check for "Dos device path" syntax |
||||
if {[string range $strcopy_path 0 3] in [list "//?/" "//./"]} { |
||||
#Note that //./ doesn't appear to be supported in Tcl as at 2023-08 - but //?/ works (except for //?/UNC/Server/share) |
||||
if {[string range $strcopy_path 4 6] eq "UNC"} { |
||||
return 1 |
||||
} else { |
||||
#some other Dos device path. Could be a drive which is mapped to a UNC path - but the path itself isn't a unc path |
||||
return 0 |
||||
} |
||||
} else { |
||||
#leading double slash and not dos device path syntax |
||||
return 1 |
||||
} |
||||
} |
||||
return 0 |
||||
} |
||||
|
||||
#ordinary \\Servername or \\servername\share or \\servername\share\path (or forward-slash equivalent) with no dos device syntax //?/ //./ etc. |
||||
proc is_unc_path_plain {path} { |
||||
if {[is_unc_path $path]} { |
||||
if {![is_dos_device_path $path]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
|
||||
#int-rep path preserved - but 'file attributes', and therefor this operation, is expensive (on windows at least) |
||||
proc pwdshortname {{path {}}} { |
||||
if {$path eq ""} { |
||||
set path [pwd] |
||||
} else { |
||||
if {[file pathtype $path] eq "relative"} { |
||||
set path [file normalize $path] |
||||
} |
||||
} |
||||
return [dict get [file attributes $path] -shortname] |
||||
} |
||||
#dos device path syntax allows windows api to acces extended-length paths and filenames with illegal path characters such as trailing dots or whitespace |
||||
#(can exist on server shares and on NTFS - but standard apps can't access without dos device syntax) |
||||
proc is_dos_device_path {path} { |
||||
set strcopy_path [punk::objclone $path] |
||||
set strcopy_path [string map [list \\ /] $strcopy_path] ;#normalize to forward slashes for testing purposes (and forward slashes seem to be auto-translated by windows anyway) |
||||
if {[string range $strcopy_path 0 3] in [list "//?/" "//./"]} { |
||||
return 1 |
||||
} else { |
||||
return 0 |
||||
} |
||||
} |
||||
proc strip_dos_device_prefix {path} { |
||||
#it's unlikely to be valid to strip only //?/ from a //?/UNC path so check for it here and diver to strip that. |
||||
#(review.. or raise error because a //?/UNC path isn't *strictly* a UNC path? ) |
||||
if {[is_unc_path $path]} { |
||||
return [strip_unc_path_prefix $path] |
||||
} |
||||
if {[is_dos_device_path $path]} { |
||||
return [string range $path 4 end] |
||||
} else { |
||||
return $path |
||||
} |
||||
} |
||||
proc strip_unc_path_prefix {path} { |
||||
if {[is_unc_path $path]} { |
||||
#//?/UNC/server/etc |
||||
set strcopy_path [punk::objclone $path] |
||||
set trimmedpath [string range $strcopy_path 7 end] |
||||
file pathtype $trimmedpath ;#shimmer it to path rep |
||||
return $trimmedpath |
||||
} elseif {is_unc_path_plain $path} { |
||||
#plain unc //server |
||||
set strcopy_path [punk::objclone $path] |
||||
set trimmedpath [string range $strcopy_path 2 end] |
||||
file pathtype $trimmedpath |
||||
return $trimmedpath |
||||
} else { |
||||
return $path |
||||
} |
||||
} |
||||
#we don't validate that path is actually illegal because we don't know the full range of such names. |
||||
#The caller can apply this to any path. |
||||
#don't test for platform here - needs to be callable from any platform for potential passing to windows (what usecase? 8.3 name is not always calculable independently) |
||||
#The utility of this is questionable. prepending a dos-device path won't make a filename with illegal characters readable by windows. |
||||
#It will need the 'shortname' at least for the illegal segment - if not the whole path |
||||
#Whilst the 8.3 name algorithm - including undocumented hash function has been reverse engineered |
||||
#- it depends on the content of the directory - as collisions cause a different name (e.g incremented number) |
||||
#- it also depends on the history of the folder |
||||
#- you can't take the current dir contents and a particular *existing* longname and determine the shortname algorithmically... |
||||
#- the shortname may have been generated during a different directory state. |
||||
#- It is then stored on disk (where?) - so access to reading the existing shortname is required. |
||||
#- An implementation of the 8.3 algorithm would only be potentially useful in determining the name that will result from adding a new file |
||||
# and would be subject to potential collisions if there are race-conditions in file creation |
||||
#- Using an 8.3 algorithm externally would be dangerous in that it could appear to work a lot of the time - but return a different file entirely sometimes. |
||||
#- Conclusion is that the 8.3 name must be retrieved rathern than calclated |
||||
proc illegalname_fix {path} { |
||||
#don't add extra dos device path syntax protection-prefix if already done |
||||
if {[is_unc_path $path]} { |
||||
error "illegalname_fix called on UNC path $path - unable to process" |
||||
} |
||||
if {[is_dos_device_path $path]} { |
||||
#we may have appended |
||||
return $path |
||||
} |
||||
|
||||
|
||||
|
||||
#\\servername\share theoretically maps to: \\?\UNC\servername\share in protected form. https://learn.microsoft.com/en-us/dotnet/standard/io/file-path-formats |
||||
#NOTE: 2023-08 on windows 10 at least \\?\UNC\Server\share doesn't work - ie we can't use illegalname_fix on UNC paths such as \\Server\share |
||||
#(but mapped drive to same path will work) |
||||
#Note that test-path cmdlet in powershell is also flaky with regards to \\?\UNC\Server paths. |
||||
#It seems prudent for now to disallow \\?\ protection for UNC paths such as \\server\etc |
||||
if {[is_unc_path $path]} { |
||||
set err "" |
||||
append err "illegalname_fix doesn't currently support UNC paths (non dos device leading double slash or //?/UNC/...)" |
||||
append err \n " - because //?/UNC/Servername/share is not supported in Tcl (and only minimally even in powershell) as at 2023. (on windows use mapped drive instead)" |
||||
error $err |
||||
} |
||||
|
||||
set strcopy_path [punk::objclone $path] |
||||
|
||||
|
||||
#Note: path could still have leading double slash if it is a Dos device path: e.g. //?/c:/etc |
||||
if {[file pathtype $path] eq "absolute"} { |
||||
if {$path eq "~"} { |
||||
# non-normalized ~ is classified as absolute |
||||
# tilde special meaning is a bit of a nuisance.. but as it's the entire path in this case.. presumably it should be kept that way |
||||
# leave for caller to interpret it - but it's not an illegal name whether it's interpreted with special meaning or not |
||||
# unlikely this fix will be called on a plain tilde anyway |
||||
return $path |
||||
} else { |
||||
set fullpath $path |
||||
} |
||||
} else { |
||||
#set fullpath [file normalize $path] ;#very slow on windows |
||||
#set fullpath [pwd]/$path ;#will keep ./ in middle of path - not valid for dos-device paths |
||||
if {[string range $strcopy_path 0 1] eq "./"} { |
||||
set strcopy_path [string range $strcopy_path 2 end] |
||||
} |
||||
set fullpath [file join [pwd] $strcopy_path] |
||||
} |
||||
#For file I/O, the "\\?\" prefix to a path string tells the Windows APIs to disable all string parsing |
||||
# and to send the string that follows it straight to the file system. |
||||
set protect "\\\\?\\" ;# value is: \\?\ prefix |
||||
set protect2 "//?/" ;#file normalize may do this - it still works |
||||
#don't use "//./" - not currently supported in Tcl - seems to work in powershell though. |
||||
|
||||
|
||||
#choose //?/ as normalized version - since likely 'file normalize' will do it anyway, and experimentall, the windows API accepts both REVIEW |
||||
set result ${protect2}$fullpath |
||||
file pathtype $result ;#make it return a path rep |
||||
return $result |
||||
} |
||||
|
||||
#don't test for platform here - needs to be callable from any platform for potential passing to windows |
||||
#we can create files with windows illegal names by using //?/ dos device path syntax - but we need to detect when that is required. |
||||
# |
||||
# path int-rep preserving |
||||
proc illegalname_test {path} { |
||||
#https://learn.microsoft.com/en-us/windows/win32/fileio/naming-a-file |
||||
#according to the above: Use any character in the current code page for a name, including Unicode characters and characters in the extended character set (128–255), except for the following: |
||||
set reserved [list < > : \" / \\ | ? *] |
||||
|
||||
|
||||
#we need to exclude things like path/.. path/. |
||||
foreach seg [file split $path] { |
||||
if {$seg in [list . ..]} { |
||||
#review - what if there is a folder or file that actually has a name such as . or .. ? |
||||
#unlikely in normal use - but could done deliberately for bad reasons? |
||||
#We are unable to check for it here anyway - as this command is intended for checking the path string - not the actual path on a filesystem. |
||||
# |
||||
#/./ /../ segments don't require protection - keep checking. |
||||
continue |
||||
} |
||||
|
||||
#only check for actual space as other whitespace seems to work without being stripped |
||||
#trailing tab and trailing \n or \r seem to be creatable in windows with Tcl - map to some glyph |
||||
if {[string index $seg end] in [list " " "."]} { |
||||
#windows API doesn't handle trailing dots or spaces (silently strips) - even though such files can be created on NTFS systems (or seen via samba etc) |
||||
return 1 |
||||
} |
||||
} |
||||
#glob chars '* ?' are probably illegal.. but although x*y.txt and x?y.txt don't display properly (* ? replaced with some other glyph) |
||||
#- they seem to be readable from cmd and tclsh as is. |
||||
# pipe symbol also has glyph substitution and behaves the same e.g a|b.txt |
||||
#(at least with encoding system utf-8) |
||||
|
||||
#todo - determine what else constitutes an illegal name according to windows APIs and requires protection with dos device syntax |
||||
return 0 |
||||
} |
||||
|
||||
proc test_ntfs_tunneling {f1 f2 args} { |
||||
file mkdir $f1 |
||||
puts stderr "waiting 15secs..." |
||||
after 5000 {puts -nonewline stderr .} |
||||
after 5000 {puts -nonewline stderr .} |
||||
after 5000 {puts -nonewline stderr .} |
||||
after 500 {puts stderr \n} |
||||
file mkdir $f2 |
||||
puts stdout "$f1 [file stat $f1]" |
||||
puts stdout "$f2 [file stat $f2]" |
||||
file delete $f1 |
||||
puts stdout "renaming $f2 to $f1" |
||||
file rename $f2 $f1 |
||||
puts stdout "$f1 [file stat $f1]" |
||||
|
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::winpath [namespace eval punk::winpath { |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
File diff suppressed because it is too large
Load Diff
@ -1,189 +0,0 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. |
||||
# |
||||
# Copyright (c) 2004-2008 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
# @mdgen EXCLUDE: sets_c.tcl |
||||
|
||||
package require Tcl 8.5- |
||||
|
||||
namespace eval ::struct::set {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Management of set implementations. |
||||
|
||||
# ::struct::set::LoadAccelerator -- |
||||
# |
||||
# Loads a named implementation, if possible. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to load. |
||||
# |
||||
# Results: |
||||
# A boolean flag. True if the implementation |
||||
# was successfully loaded; and False otherwise. |
||||
|
||||
proc ::struct::set::LoadAccelerator {key} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $key { |
||||
critcl { |
||||
# Critcl implementation of set requires Tcl 8.4. |
||||
if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} |
||||
if {[catch {package require tcllibc}]} {return 0} |
||||
set r [llength [info commands ::struct::set_critcl]] |
||||
} |
||||
tcl { |
||||
variable selfdir |
||||
source [file join $selfdir sets_tcl.tcl] |
||||
set r 1 |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator/impl. package $key:\ |
||||
must be one of [join [KnownImplementations] {, }]" |
||||
} |
||||
} |
||||
set accel($key) $r |
||||
return $r |
||||
} |
||||
|
||||
# ::struct::set::SwitchTo -- |
||||
# |
||||
# Activates a loaded named implementation. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to activate. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::set::SwitchTo {key} { |
||||
variable accel |
||||
variable loaded |
||||
|
||||
if {[string equal $key $loaded]} { |
||||
# No change, nothing to do. |
||||
return |
||||
} elseif {![string equal $key ""]} { |
||||
# Validate the target implementation of the switch. |
||||
|
||||
if {![info exists accel($key)]} { |
||||
return -code error "Unable to activate unknown implementation \"$key\"" |
||||
} elseif {![info exists accel($key)] || !$accel($key)} { |
||||
return -code error "Unable to activate missing implementation \"$key\"" |
||||
} |
||||
} |
||||
|
||||
# Deactivate the previous implementation, if there was any. |
||||
|
||||
if {![string equal $loaded ""]} { |
||||
rename ::struct::set ::struct::set_$loaded |
||||
} |
||||
|
||||
# Activate the new implementation, if there is any. |
||||
|
||||
if {![string equal $key ""]} { |
||||
rename ::struct::set_$key ::struct::set |
||||
} |
||||
|
||||
# Remember the active implementation, for deactivation by future |
||||
# switches. |
||||
|
||||
set loaded $key |
||||
return |
||||
} |
||||
|
||||
proc ::struct::set::Loaded {} { |
||||
variable loaded |
||||
return $loaded |
||||
} |
||||
|
||||
# ::struct::set::Implementations -- |
||||
# |
||||
# Determines which implementations are |
||||
# present, i.e. loaded. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. |
||||
|
||||
proc ::struct::set::Implementations {} { |
||||
variable accel |
||||
set res {} |
||||
foreach n [array names accel] { |
||||
if {!$accel($n)} continue |
||||
lappend res $n |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::struct::set::KnownImplementations -- |
||||
# |
||||
# Determines which implementations are known |
||||
# as possible implementations. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. In the order |
||||
# of preference, most prefered first. |
||||
|
||||
proc ::struct::set::KnownImplementations {} { |
||||
return {critcl tcl} |
||||
} |
||||
|
||||
proc ::struct::set::Names {} { |
||||
return { |
||||
critcl {tcllibc based} |
||||
tcl {pure Tcl} |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Data structures. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable selfdir [file dirname [info script]] |
||||
variable accel |
||||
array set accel {tcl 0 critcl 0} |
||||
variable loaded {} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Choose an implementation, |
||||
## most prefered first. Loads only one of the |
||||
## possible implementations. And activates it. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable e |
||||
foreach e [KnownImplementations] { |
||||
if {[LoadAccelerator $e]} { |
||||
SwitchTo $e |
||||
break |
||||
} |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Export the constructor command. |
||||
namespace export set |
||||
} |
||||
|
||||
package provide struct::set 2.2.3 |
@ -1,189 +0,0 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. |
||||
# |
||||
# Copyright (c) 2004-2008 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets.tcl,v 1.17 2008/03/09 04:24:37 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
# @mdgen EXCLUDE: sets_c.tcl |
||||
|
||||
package require Tcl 8.5- |
||||
|
||||
namespace eval ::struct::set {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Management of set implementations. |
||||
|
||||
# ::struct::set::LoadAccelerator -- |
||||
# |
||||
# Loads a named implementation, if possible. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to load. |
||||
# |
||||
# Results: |
||||
# A boolean flag. True if the implementation |
||||
# was successfully loaded; and False otherwise. |
||||
|
||||
proc ::struct::set::LoadAccelerator {key} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $key { |
||||
critcl { |
||||
# Critcl implementation of set requires Tcl 8.4. |
||||
if {![package vsatisfies [package provide Tcl] 8.4]} {return 0} |
||||
if {[catch {package require tcllibc}]} {return 0} |
||||
set r [llength [info commands ::struct::set_critcl]] |
||||
} |
||||
tcl { |
||||
variable selfdir |
||||
source [file join $selfdir sets_tcl.tcl] |
||||
set r 1 |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator/impl. package $key:\ |
||||
must be one of [join [KnownImplementations] {, }]" |
||||
} |
||||
} |
||||
set accel($key) $r |
||||
return $r |
||||
} |
||||
|
||||
# ::struct::set::SwitchTo -- |
||||
# |
||||
# Activates a loaded named implementation. |
||||
# |
||||
# Arguments: |
||||
# key Name of the implementation to activate. |
||||
# |
||||
# Results: |
||||
# None. |
||||
|
||||
proc ::struct::set::SwitchTo {key} { |
||||
variable accel |
||||
variable loaded |
||||
|
||||
if {[string equal $key $loaded]} { |
||||
# No change, nothing to do. |
||||
return |
||||
} elseif {![string equal $key ""]} { |
||||
# Validate the target implementation of the switch. |
||||
|
||||
if {![info exists accel($key)]} { |
||||
return -code error "Unable to activate unknown implementation \"$key\"" |
||||
} elseif {![info exists accel($key)] || !$accel($key)} { |
||||
return -code error "Unable to activate missing implementation \"$key\"" |
||||
} |
||||
} |
||||
|
||||
# Deactivate the previous implementation, if there was any. |
||||
|
||||
if {![string equal $loaded ""]} { |
||||
rename ::struct::set ::struct::set_$loaded |
||||
} |
||||
|
||||
# Activate the new implementation, if there is any. |
||||
|
||||
if {![string equal $key ""]} { |
||||
rename ::struct::set_$key ::struct::set |
||||
} |
||||
|
||||
# Remember the active implementation, for deactivation by future |
||||
# switches. |
||||
|
||||
set loaded $key |
||||
return |
||||
} |
||||
|
||||
proc ::struct::set::Loaded {} { |
||||
variable loaded |
||||
return $loaded |
||||
} |
||||
|
||||
# ::struct::set::Implementations -- |
||||
# |
||||
# Determines which implementations are |
||||
# present, i.e. loaded. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. |
||||
|
||||
proc ::struct::set::Implementations {} { |
||||
variable accel |
||||
set res {} |
||||
foreach n [array names accel] { |
||||
if {!$accel($n)} continue |
||||
lappend res $n |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::struct::set::KnownImplementations -- |
||||
# |
||||
# Determines which implementations are known |
||||
# as possible implementations. |
||||
# |
||||
# Arguments: |
||||
# None. |
||||
# |
||||
# Results: |
||||
# A list of implementation keys. In the order |
||||
# of preference, most prefered first. |
||||
|
||||
proc ::struct::set::KnownImplementations {} { |
||||
return {critcl tcl} |
||||
} |
||||
|
||||
proc ::struct::set::Names {} { |
||||
return { |
||||
critcl {tcllibc based} |
||||
tcl {pure Tcl} |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Data structures. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable selfdir [file dirname [info script]] |
||||
variable accel |
||||
array set accel {tcl 0 critcl 0} |
||||
variable loaded {} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Initialization: Choose an implementation, |
||||
## most prefered first. Loads only one of the |
||||
## possible implementations. And activates it. |
||||
|
||||
namespace eval ::struct::set { |
||||
variable e |
||||
foreach e [KnownImplementations] { |
||||
if {[LoadAccelerator $e]} { |
||||
SwitchTo $e |
||||
break |
||||
} |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Export the constructor command. |
||||
namespace export set |
||||
} |
||||
|
||||
package provide struct::set 2.2.3 |
@ -1,93 +0,0 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets_tcl.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. C implementation. |
||||
# |
||||
# Copyright (c) 2007 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets_c.tcl,v 1.3 2008/03/25 07:15:34 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
package require critcl |
||||
# @sak notprovided struct_setc |
||||
package provide struct_setc 2.1.1 |
||||
package require Tcl 8.5- |
||||
|
||||
namespace eval ::struct { |
||||
# Supporting code for the main command. |
||||
|
||||
catch { |
||||
#critcl::cheaders -g |
||||
#critcl::debug memory symbols |
||||
} |
||||
|
||||
critcl::cheaders sets/*.h |
||||
critcl::csources sets/*.c |
||||
|
||||
critcl::ccode { |
||||
/* -*- c -*- */ |
||||
|
||||
#include <m.h> |
||||
} |
||||
|
||||
# Main command, set creation. |
||||
|
||||
critcl::ccommand set_critcl {dummy interp objc objv} { |
||||
/* Syntax - dispatcher to the sub commands. |
||||
*/ |
||||
|
||||
static CONST char* methods [] = { |
||||
"add", "contains", "difference", "empty", |
||||
"equal","exclude", "include", "intersect", |
||||
"intersect3", "size", "subsetof", "subtract", |
||||
"symdiff", "union", |
||||
NULL |
||||
}; |
||||
enum methods { |
||||
S_add, S_contains, S_difference, S_empty, |
||||
S_equal,S_exclude, S_include, S_intersect, |
||||
S_intersect3, S_size, S_subsetof, S_subtract, |
||||
S_symdiff, S_union |
||||
}; |
||||
|
||||
int m; |
||||
|
||||
if (objc < 2) { |
||||
Tcl_WrongNumArgs (interp, objc, objv, "cmd ?arg ...?"); |
||||
return TCL_ERROR; |
||||
} else if (Tcl_GetIndexFromObj (interp, objv [1], methods, "option", |
||||
0, &m) != TCL_OK) { |
||||
return TCL_ERROR; |
||||
} |
||||
|
||||
/* Dispatch to methods. They check the #args in detail before performing |
||||
* the requested functionality |
||||
*/ |
||||
|
||||
switch (m) { |
||||
case S_add: return sm_ADD (NULL, interp, objc, objv); |
||||
case S_contains: return sm_CONTAINS (NULL, interp, objc, objv); |
||||
case S_difference: return sm_DIFFERENCE (NULL, interp, objc, objv); |
||||
case S_empty: return sm_EMPTY (NULL, interp, objc, objv); |
||||
case S_equal: return sm_EQUAL (NULL, interp, objc, objv); |
||||
case S_exclude: return sm_EXCLUDE (NULL, interp, objc, objv); |
||||
case S_include: return sm_INCLUDE (NULL, interp, objc, objv); |
||||
case S_intersect: return sm_INTERSECT (NULL, interp, objc, objv); |
||||
case S_intersect3: return sm_INTERSECT3 (NULL, interp, objc, objv); |
||||
case S_size: return sm_SIZE (NULL, interp, objc, objv); |
||||
case S_subsetof: return sm_SUBSETOF (NULL, interp, objc, objv); |
||||
case S_subtract: return sm_SUBTRACT (NULL, interp, objc, objv); |
||||
case S_symdiff: return sm_SYMDIFF (NULL, interp, objc, objv); |
||||
case S_union: return sm_UNION (NULL, interp, objc, objv); |
||||
} |
||||
/* Not coming to this place */ |
||||
} |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
@ -1,452 +0,0 @@
|
||||
#---------------------------------------------------------------------- |
||||
# |
||||
# sets_tcl.tcl -- |
||||
# |
||||
# Definitions for the processing of sets. |
||||
# |
||||
# Copyright (c) 2004-2008 by Andreas Kupries. |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: sets_tcl.tcl,v 1.4 2008/03/09 04:38:47 andreas_kupries Exp $ |
||||
# |
||||
#---------------------------------------------------------------------- |
||||
|
||||
package require Tcl 8.5- |
||||
|
||||
namespace eval ::struct::set { |
||||
# Only export one command, the one used to instantiate a new tree |
||||
namespace export set_tcl |
||||
} |
||||
|
||||
########################## |
||||
# Public functions |
||||
|
||||
# ::struct::set::set -- |
||||
# |
||||
# Command that access all set commands. |
||||
# |
||||
# Arguments: |
||||
# cmd Name of the subcommand to dispatch to. |
||||
# args Arguments for the subcommand. |
||||
# |
||||
# Results: |
||||
# Whatever the result of the subcommand is. |
||||
|
||||
proc ::struct::set::set_tcl {cmd args} { |
||||
# Do minimal args checks here |
||||
if { [llength [info level 0]] == 1 } { |
||||
return -code error "wrong # args: should be \"$cmd ?arg arg ...?\"" |
||||
} |
||||
::set sub S_$cmd |
||||
if { [llength [info commands ::struct::set::$sub]] == 0 } { |
||||
::set optlist [info commands ::struct::set::S_*] |
||||
::set xlist {} |
||||
foreach p $optlist { |
||||
lappend xlist [string range $p 17 end] |
||||
} |
||||
return -code error \ |
||||
"bad option \"$cmd\": must be [linsert [join [lsort $xlist] ", "] "end-1" "or"]" |
||||
} |
||||
return [uplevel 1 [linsert $args 0 ::struct::set::$sub]] |
||||
} |
||||
|
||||
########################## |
||||
# Implementations of the functionality. |
||||
# |
||||
|
||||
# ::struct::set::S_empty -- |
||||
# |
||||
# Determines emptiness of the set |
||||
# |
||||
# Parameters: |
||||
# set -- The set to check for emptiness. |
||||
# |
||||
# Results: |
||||
# A boolean value. True indicates that the set is empty. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
# |
||||
# Notes: |
||||
|
||||
proc ::struct::set::S_empty {set} { |
||||
return [expr {[llength $set] == 0}] |
||||
} |
||||
|
||||
# ::struct::set::S_size -- |
||||
# |
||||
# Computes the cardinality of the set. |
||||
# |
||||
# Parameters: |
||||
# set -- The set to inspect. |
||||
# |
||||
# Results: |
||||
# An integer greater than or equal to zero. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_size {set} { |
||||
return [llength [Cleanup $set]] |
||||
} |
||||
|
||||
# ::struct::set::S_contains -- |
||||
# |
||||
# Determines if the item is in the set. |
||||
# |
||||
# Parameters: |
||||
# set -- The set to inspect. |
||||
# item -- The element to look for. |
||||
# |
||||
# Results: |
||||
# A boolean value. True indicates that the element is present. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_contains {set item} { |
||||
return [expr {[lsearch -exact $set $item] >= 0}] |
||||
} |
||||
|
||||
# ::struct::set::S_union -- |
||||
# |
||||
# Computes the union of the arguments. |
||||
# |
||||
# Parameters: |
||||
# args -- List of sets to unify. |
||||
# |
||||
# Results: |
||||
# The union of the arguments. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_union {args} { |
||||
switch -exact -- [llength $args] { |
||||
0 {return {}} |
||||
1 {return [lindex $args 0]} |
||||
} |
||||
foreach setX $args { |
||||
foreach x $setX {::set ($x) {}} |
||||
} |
||||
return [array names {}] |
||||
} |
||||
|
||||
|
||||
# ::struct::set::S_intersect -- |
||||
# |
||||
# Computes the intersection of the arguments. |
||||
# |
||||
# Parameters: |
||||
# args -- List of sets to intersect. |
||||
# |
||||
# Results: |
||||
# The intersection of the arguments |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_intersect {args} { |
||||
switch -exact -- [llength $args] { |
||||
0 {return {}} |
||||
1 {return [lindex $args 0]} |
||||
} |
||||
::set res [lindex $args 0] |
||||
foreach set [lrange $args 1 end] { |
||||
if {[llength $res] && [llength $set]} { |
||||
::set res [Intersect $res $set] |
||||
} else { |
||||
# Squash 'res'. Otherwise we get the wrong result if res |
||||
# is not empty, but 'set' is. |
||||
::set res {} |
||||
break |
||||
} |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
proc ::struct::set::Intersect {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return {}} |
||||
|
||||
# This is slower than local vars, but more robust |
||||
if {[llength $B] > [llength $A]} { |
||||
::set res $A |
||||
::set A $B |
||||
::set B $res |
||||
} |
||||
::set res {} |
||||
foreach x $A {::set ($x) {}} |
||||
foreach x $B { |
||||
if {[info exists ($x)]} { |
||||
lappend res $x |
||||
} |
||||
} |
||||
return $res |
||||
} |
||||
|
||||
# ::struct::set::S_difference -- |
||||
# |
||||
# Compute difference of two sets. |
||||
# |
||||
# Parameters: |
||||
# A, B -- Sets to compute the difference for. |
||||
# |
||||
# Results: |
||||
# A - B |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_difference {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return $A} |
||||
|
||||
array set tmp {} |
||||
foreach x $A {::set tmp($x) .} |
||||
foreach x $B {catch {unset tmp($x)}} |
||||
return [array names tmp] |
||||
} |
||||
|
||||
if {0} { |
||||
# Tcllib SF Bug 1002143. We cannot use the implementation below. |
||||
# It will treat set elements containing '(' and ')' as array |
||||
# elements, and this screws up the storage of elements as the name |
||||
# of local vars something fierce. No way around this. Disabling |
||||
# this code and always using the other implementation (s.a.) is |
||||
# the only possible fix. |
||||
|
||||
if {[package vcompare [package provide Tcl] 8.4] < 0} { |
||||
# Tcl 8.[23]. Use explicit array to perform the operation. |
||||
} else { |
||||
# Tcl 8.4+, has 'unset -nocomplain' |
||||
|
||||
proc ::struct::set::S_difference {A B} { |
||||
if {[llength $A] == 0} {return {}} |
||||
if {[llength $B] == 0} {return $A} |
||||
|
||||
# Get the variable B out of the way, avoid collisions |
||||
# prepare for "pure list optimization" |
||||
::set ::struct::set::tmp [lreplace $B -1 -1 unset -nocomplain] |
||||
unset B |
||||
|
||||
# unset A early: no local variables left |
||||
foreach [lindex [list $A [unset A]] 0] {.} {break} |
||||
|
||||
eval $::struct::set::tmp |
||||
return [info locals] |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ::struct::set::S_symdiff -- |
||||
# |
||||
# Compute symmetric difference of two sets. |
||||
# |
||||
# Parameters: |
||||
# A, B -- The sets to compute the s.difference for. |
||||
# |
||||
# Results: |
||||
# The symmetric difference of the two input sets. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_symdiff {A B} { |
||||
# symdiff == (A-B) + (B-A) == (A+B)-(A*B) |
||||
if {[llength $A] == 0} {return $B} |
||||
if {[llength $B] == 0} {return $A} |
||||
return [S_union \ |
||||
[S_difference $A $B] \ |
||||
[S_difference $B $A]] |
||||
} |
||||
|
||||
# ::struct::set::S_intersect3 -- |
||||
# |
||||
# Return intersection and differences for two sets. |
||||
# |
||||
# Parameters: |
||||
# A, B -- The sets to inspect. |
||||
# |
||||
# Results: |
||||
# List containing A*B, A-B, and B-A |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_intersect3 {A B} { |
||||
return [list \ |
||||
[S_intersect $A $B] \ |
||||
[S_difference $A $B] \ |
||||
[S_difference $B $A]] |
||||
} |
||||
|
||||
# ::struct::set::S_equal -- |
||||
# |
||||
# Compares two sets for equality. |
||||
# |
||||
# Parameters: |
||||
# a First set to compare. |
||||
# b Second set to compare. |
||||
# |
||||
# Results: |
||||
# A boolean. True if the lists are equal. |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_equal {A B} { |
||||
::set A [Cleanup $A] |
||||
::set B [Cleanup $B] |
||||
|
||||
# Equal if of same cardinality and difference is empty. |
||||
|
||||
if {[::llength $A] != [::llength $B]} {return 0} |
||||
return [expr {[llength [S_difference $A $B]] == 0}] |
||||
} |
||||
|
||||
|
||||
proc ::struct::set::Cleanup {A} { |
||||
# unset A to avoid collisions |
||||
if {[llength $A] < 2} {return $A} |
||||
# We cannot use variables to avoid an explicit array. The set |
||||
# elements may look like namespace vars (i.e. contain ::), and |
||||
# such elements break that, cannot be proc-local variables. |
||||
array set S {} |
||||
foreach item $A {set S($item) .} |
||||
return [array names S] |
||||
} |
||||
|
||||
# ::struct::set::S_include -- |
||||
# |
||||
# Add an element to a set. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to extend. |
||||
# element -- The item to add to the set. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is extended |
||||
# by the element (if the element was not already present). |
||||
|
||||
proc ::struct::set::S_include {Avar element} { |
||||
# Avar = Avar + {element} |
||||
upvar 1 $Avar A |
||||
if {![info exists A] || ![S_contains $A $element]} { |
||||
lappend A $element |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_exclude -- |
||||
# |
||||
# Remove an element from a set. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to shrink. |
||||
# element -- The item to remove from the set. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is shrunk, |
||||
# the element remove (if the element was actually present). |
||||
|
||||
proc ::struct::set::S_exclude {Avar element} { |
||||
# Avar = Avar - {element} |
||||
upvar 1 $Avar A |
||||
if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} |
||||
while {[::set pos [lsearch -exact $A $element]] >= 0} { |
||||
::set A [lreplace [K $A [::set A {}]] $pos $pos] |
||||
} |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_add -- |
||||
# |
||||
# Add a set to a set. Similar to 'union', but the first argument |
||||
# is a variable. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to extend. |
||||
# B -- The set to add to the set in Avar. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is extended |
||||
# by all the elements in B. |
||||
|
||||
proc ::struct::set::S_add {Avar B} { |
||||
# Avar = Avar + B |
||||
upvar 1 $Avar A |
||||
if {![info exists A]} {set A {}} |
||||
::set A [S_union [K $A [::set A {}]] $B] |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_subtract -- |
||||
# |
||||
# Remove a set from a set. Similar to 'difference', but the first argument |
||||
# is a variable. |
||||
# |
||||
# Parameters: |
||||
# Avar -- Reference to the set variable to shrink. |
||||
# B -- The set to remove from the set in Avar. |
||||
# |
||||
# Results: |
||||
# None. |
||||
# |
||||
# Side effects: |
||||
# The set in the variable referenced by Avar is shrunk, |
||||
# all elements of B are removed. |
||||
|
||||
proc ::struct::set::S_subtract {Avar B} { |
||||
# Avar = Avar - B |
||||
upvar 1 $Avar A |
||||
if {![info exists A]} {return -code error "can't read \"$Avar\": no such variable"} |
||||
::set A [S_difference [K $A [::set A {}]] $B] |
||||
return |
||||
} |
||||
|
||||
# ::struct::set::S_subsetof -- |
||||
# |
||||
# A predicate checking if the first set is a subset |
||||
# or equal to the second set. |
||||
# |
||||
# Parameters: |
||||
# A -- The possible subset. |
||||
# B -- The set to compare to. |
||||
# |
||||
# Results: |
||||
# A boolean value, true if A is subset of or equal to B |
||||
# |
||||
# Side effects: |
||||
# None. |
||||
|
||||
proc ::struct::set::S_subsetof {A B} { |
||||
# A subset|== B <=> (A == A*B) |
||||
return [S_equal $A [S_intersect $A $B]] |
||||
} |
||||
|
||||
# ::struct::set::K -- |
||||
# Performance helper command. |
||||
|
||||
proc ::struct::set::K {x y} {::set x} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
namespace eval ::struct { |
||||
# Put 'set::set' into the general structure namespace |
||||
# for pickup by the main management. |
||||
|
||||
namespace import -force set::set_tcl |
||||
} |
@ -1,80 +0,0 @@
|
||||
# textutil.tcl -- |
||||
# |
||||
# Utilities for manipulating strings, words, single lines, |
||||
# paragraphs, ... |
||||
# |
||||
# Copyright (c) 2000 by Ajuba Solutions. |
||||
# Copyright (c) 2000 by Eric Melski <ericm@ajubasolutions.com> |
||||
# Copyright (c) 2002 by Joe English <jenglish@users.sourceforge.net> |
||||
# Copyright (c) 2001-2006 by Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: textutil.tcl,v 1.17 2006/09/21 06:46:24 andreas_kupries Exp $ |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
package require Tcl 8.2 |
||||
|
||||
namespace eval ::textutil {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API implementation |
||||
## All through sub-packages imported here. |
||||
|
||||
package require textutil::string |
||||
package require textutil::repeat |
||||
package require textutil::adjust |
||||
package require textutil::split |
||||
package require textutil::tabify |
||||
package require textutil::trim |
||||
package require textutil::wcswidth |
||||
|
||||
namespace eval ::textutil { |
||||
# Import the miscellaneous string command for public export |
||||
|
||||
namespace import -force string::chop string::tail |
||||
namespace import -force string::cap string::uncap string::capEachWord |
||||
namespace import -force string::longestCommonPrefix |
||||
namespace import -force string::longestCommonPrefixList |
||||
|
||||
# Import the repeat commands for public export |
||||
|
||||
namespace import -force repeat::strRepeat repeat::blank |
||||
|
||||
# Import the adjust commands for public export |
||||
|
||||
namespace import -force adjust::adjust adjust::indent adjust::undent |
||||
|
||||
# Import the split commands for public export |
||||
|
||||
namespace import -force split::splitx split::splitn |
||||
|
||||
# Import the trim commands for public export |
||||
|
||||
namespace import -force trim::trim trim::trimleft trim::trimright |
||||
namespace import -force trim::trimPrefix trim::trimEmptyHeading |
||||
|
||||
# Import the tabify commands for public export |
||||
|
||||
namespace import -force tabify::tabify tabify::untabify |
||||
namespace import -force tabify::tabify2 tabify::untabify2 |
||||
|
||||
# Re-export all the imported commands |
||||
|
||||
namespace export chop tail cap uncap capEachWord |
||||
namespace export longestCommonPrefix longestCommonPrefixList |
||||
namespace export strRepeat blank |
||||
namespace export adjust indent undent |
||||
namespace export splitx splitn |
||||
namespace export trim trimleft trimright trimPrefix trimEmptyHeading |
||||
namespace export tabify untabify tabify2 untabify2 |
||||
} |
||||
|
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide textutil 0.9 |
@ -1,761 +0,0 @@
|
||||
# trim.tcl -- |
||||
# |
||||
# Various ways of trimming a string. |
||||
# |
||||
# Copyright (c) 2000 by Ajuba Solutions. |
||||
# Copyright (c) 2000 by Eric Melski <ericm@ajubasolutions.com> |
||||
# Copyright (c) 2002-2004 by Johannes-Heinrich Vogeler <vogeler@users.sourceforge.net> |
||||
# Copyright (c) 2001-2006 by Andreas Kupries <andreas_kupries@users.sourceforge.net> |
||||
# |
||||
# See the file "license.terms" for information on usage and redistribution |
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
||||
# |
||||
# RCS: @(#) $Id: adjust.tcl,v 1.16 2011/12/13 18:12:56 andreas_kupries Exp $ |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Requirements |
||||
|
||||
package require Tcl 8.2 |
||||
package require textutil::repeat |
||||
package require textutil::string |
||||
|
||||
namespace eval ::textutil::adjust {} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## API implementation |
||||
|
||||
namespace eval ::textutil::adjust { |
||||
namespace import -force ::textutil::repeat::strRepeat |
||||
} |
||||
|
||||
proc ::textutil::adjust::adjust {text args} { |
||||
if {[string length [string trim $text]] == 0} { |
||||
return "" |
||||
} |
||||
|
||||
Configure $args |
||||
Adjust text newtext |
||||
|
||||
return $newtext |
||||
} |
||||
|
||||
proc ::textutil::adjust::Configure {args} { |
||||
variable Justify left |
||||
variable Length 72 |
||||
variable FullLine 0 |
||||
variable StrictLength 0 |
||||
variable Hyphenate 0 |
||||
variable HyphPatterns ; # hyphenation patterns (TeX) |
||||
|
||||
set args [ lindex $args 0 ] |
||||
foreach { option value } $args { |
||||
switch -exact -- $option { |
||||
-full { |
||||
if { ![ string is boolean -strict $value ] } then { |
||||
error "expected boolean but got \"$value\"" |
||||
} |
||||
set FullLine [ string is true $value ] |
||||
} |
||||
-hyphenate { |
||||
# the word exceeding the length of line is tried to be |
||||
# hyphenated; if a word cannot be hyphenated to fit into |
||||
# the line processing stops! The length of the line should |
||||
# be set to a reasonable value! |
||||
|
||||
if { ![ string is boolean -strict $value ] } then { |
||||
error "expected boolean but got \"$value\"" |
||||
} |
||||
set Hyphenate [string is true $value] |
||||
if { $Hyphenate && ![info exists HyphPatterns(_LOADED_)]} { |
||||
error "hyphenation patterns not loaded!" |
||||
} |
||||
} |
||||
-justify { |
||||
set lovalue [ string tolower $value ] |
||||
switch -exact -- $lovalue { |
||||
left - |
||||
right - |
||||
center - |
||||
plain { |
||||
set Justify $lovalue |
||||
} |
||||
default { |
||||
error "bad value \"$value\": should be center, left, plain or right" |
||||
} |
||||
} |
||||
} |
||||
-length { |
||||
if { ![ string is integer $value ] } then { |
||||
error "expected positive integer but got \"$value\"" |
||||
} |
||||
if { $value < 1 } then { |
||||
error "expected positive integer but got \"$value\"" |
||||
} |
||||
set Length $value |
||||
} |
||||
-strictlength { |
||||
# the word exceeding the length of line is moved to the |
||||
# next line without hyphenation; words longer than given |
||||
# line length are cut into smaller pieces |
||||
|
||||
if { ![ string is boolean -strict $value ] } then { |
||||
error "expected boolean but got \"$value\"" |
||||
} |
||||
set StrictLength [ string is true $value ] |
||||
} |
||||
default { |
||||
error "bad option \"$option\": must be -full, -hyphenate, \ |
||||
-justify, -length, or -strictlength" |
||||
} |
||||
} |
||||
} |
||||
|
||||
return "" |
||||
} |
||||
|
||||
# ::textutil::adjust::Adjust |
||||
# |
||||
# History: |
||||
# rewritten on 2004-04-13 for bugfix tcllib-bugs-882402 (jhv) |
||||
|
||||
proc ::textutil::adjust::Adjust { varOrigName varNewName } { |
||||
variable Length |
||||
variable FullLine |
||||
variable StrictLength |
||||
variable Hyphenate |
||||
|
||||
upvar $varOrigName orig |
||||
upvar $varNewName text |
||||
|
||||
set pos 0; # Cursor after writing |
||||
set line "" |
||||
set text "" |
||||
|
||||
|
||||
if {!$FullLine} { |
||||
regsub -all -- "(\n)|(\t)" $orig " " orig |
||||
regsub -all -- " +" $orig " " orig |
||||
regsub -all -- "(^ *)|( *\$)" $orig "" orig |
||||
} |
||||
|
||||
set words [split $orig] |
||||
set numWords [llength $words] |
||||
set numline 0 |
||||
|
||||
for {set cnt 0} {$cnt < $numWords} {incr cnt} { |
||||
|
||||
set w [lindex $words $cnt] |
||||
set wLen [string length $w] |
||||
|
||||
# the word $w doesn't fit into the present line |
||||
# case #1: we try to hyphenate |
||||
|
||||
if {$Hyphenate && ($pos+$wLen >= $Length)} { |
||||
# Hyphenation instructions |
||||
set w2 [textutil::adjust::Hyphenation $w] |
||||
|
||||
set iMax [llength $w2] |
||||
if {$iMax == 1 && [string length $w] > $Length} { |
||||
# word cannot be hyphenated and exceeds linesize |
||||
|
||||
error "Word \"$w2\" can\'t be hyphenated\ |
||||
and exceeds linesize $Length!" |
||||
} else { |
||||
# hyphenating of $w was successfull, but we have to look |
||||
# that every sylable would fit into the line |
||||
|
||||
foreach x $w2 { |
||||
if {[string length $x] >= $Length} { |
||||
error "Word \"$w\" can\'t be hyphenated\ |
||||
to fit into linesize $Length!" |
||||
} |
||||
} |
||||
} |
||||
|
||||
for {set i 0; set w3 ""} {$i < $iMax} {incr i} { |
||||
set syl [lindex $w2 $i] |
||||
if {($pos+[string length " $w3$syl-"]) > $Length} {break} |
||||
append w3 $syl |
||||
} |
||||
for {set w4 ""} {$i < $iMax} {incr i} { |
||||
set syl [lindex $w2 $i] |
||||
append w4 $syl |
||||
} |
||||
|
||||
if {[string length $w3] && [string length $w4]} { |
||||
# hyphenation was successfull: redefine |
||||
# list of words w => {"$w3-" "$w4"} |
||||
|
||||
set x [lreplace $words $cnt $cnt "$w4"] |
||||
set words [linsert $x $cnt "$w3-"] |
||||
set w [lindex $words $cnt] |
||||
set wLen [string length $w] |
||||
incr numWords |
||||
} |
||||
} |
||||
|
||||
# the word $w doesn't fit into the present line |
||||
# case #2: we try to cut the word into pieces |
||||
|
||||
if {$StrictLength && ([string length $w] > $Length)} { |
||||
# cut word into two pieces |
||||
set w2 $w |
||||
|
||||
set over [expr {$pos+2+$wLen-$Length}] |
||||
|
||||
incr Length -1 |
||||
set w3 [string range $w2 0 $Length] |
||||
incr Length |
||||
set w4 [string range $w2 $Length end] |
||||
|
||||
set x [lreplace $words $cnt $cnt $w4] |
||||
set words [linsert $x $cnt $w3 ] |
||||
set w [lindex $words $cnt] |
||||
set wLen [string length $w] |
||||
incr numWords |
||||
} |
||||
|
||||
# continuing with the normal procedure |
||||
|
||||
if {($pos+$wLen < $Length)} { |
||||
# append word to current line |
||||
|
||||
if {$pos} {append line " "; incr pos} |
||||
append line $w |
||||
incr pos $wLen |
||||
} else { |
||||
# line full => write buffer and begin a new line |
||||
|
||||
if {[string length $text]} {append text "\n"} |
||||
append text [Justification $line [incr numline]] |
||||
set line $w |
||||
set pos $wLen |
||||
} |
||||
} |
||||
|
||||
# write buffer and return! |
||||
|
||||
if {[string length $text]} {append text "\n"} |
||||
append text [Justification $line end] |
||||
return $text |
||||
} |
||||
|
||||
# ::textutil::adjust::Justification |
||||
# |
||||
# justify a given line |
||||
# |
||||
# Parameters: |
||||
# line text for justification |
||||
# index index for line in text |
||||
# |
||||
# Returns: |
||||
# the justified line |
||||
# |
||||
# Remarks: |
||||
# Only lines with size not exceeding the max. linesize provided |
||||
# for text formatting are justified!!! |
||||
|
||||
proc ::textutil::adjust::Justification { line index } { |
||||
variable Justify |
||||
variable Length |
||||
variable FullLine |
||||
|
||||
set len [string length $line]; # length of current line |
||||
|
||||
if { $Length <= $len } then { |
||||
# the length of current line ($len) is equal as or greater than |
||||
# the value provided for text formatting ($Length) => to avoid |
||||
# inifinite loops we leave $line unchanged and return! |
||||
|
||||
return $line |
||||
} |
||||
|
||||
# Special case: |
||||
# for the last line, and if the justification is set to 'plain' |
||||
# the real justification is 'left' if the length of the line |
||||
# is less than 90% (rounded) of the max length allowed. This is |
||||
# to avoid expansion of this line when it is too small: without |
||||
# it, the added spaces will 'unbeautify' the result. |
||||
# |
||||
|
||||
set justify $Justify |
||||
if { ( "$index" == "end" ) && \ |
||||
( "$Justify" == "plain" ) && \ |
||||
( $len < round($Length * 0.90) ) } then { |
||||
set justify left |
||||
} |
||||
|
||||
# For a left justification, nothing to do, but to |
||||
# add some spaces at the end of the line if requested |
||||
|
||||
if { "$justify" == "left" } then { |
||||
set jus "" |
||||
if { $FullLine } then { |
||||
set jus [strRepeat " " [ expr { $Length - $len } ]] |
||||
} |
||||
return "${line}${jus}" |
||||
} |
||||
|
||||
# For a right justification, just add enough spaces |
||||
# at the beginning of the line |
||||
|
||||
if { "$justify" == "right" } then { |
||||
set jus [strRepeat " " [ expr { $Length - $len } ]] |
||||
return "${jus}${line}" |
||||
} |
||||
|
||||
# For a center justification, add half of the needed spaces |
||||
# at the beginning of the line, and the rest at the end |
||||
# only if needed. |
||||
|
||||
if { "$justify" == "center" } then { |
||||
set mr [ expr { ( $Length - $len ) / 2 } ] |
||||
set ml [ expr { $Length - $len - $mr } ] |
||||
set jusl [strRepeat " " $ml] |
||||
set jusr [strRepeat " " $mr] |
||||
if { $FullLine } then { |
||||
return "${jusl}${line}${jusr}" |
||||
} else { |
||||
return "${jusl}${line}" |
||||
} |
||||
} |
||||
|
||||
# For a plain justification, it's a little bit complex: |
||||
# |
||||
# if some spaces are missing, then |
||||
# |
||||
# 1) sort the list of words in the current line by decreasing size |
||||
# 2) foreach word, add one space before it, except if it's the |
||||
# first word, until enough spaces are added |
||||
# 3) rebuild the line |
||||
|
||||
if { "$justify" == "plain" } then { |
||||
set miss [ expr { $Length - [ string length $line ] } ] |
||||
|
||||
# Bugfix tcllib-bugs-860753 (jhv) |
||||
|
||||
set words [split $line] |
||||
set numWords [llength $words] |
||||
|
||||
if {$numWords < 2} { |
||||
# current line consists of less than two words - we can't |
||||
# insert blanks to achieve a plain justification => leave |
||||
# $line unchanged and return! |
||||
|
||||
return $line |
||||
} |
||||
|
||||
for {set i 0; set totalLen 0} {$i < $numWords} {incr i} { |
||||
set w($i) [lindex $words $i] |
||||
if {$i > 0} {set w($i) " $w($i)"} |
||||
set wLen($i) [string length $w($i)] |
||||
set totalLen [expr {$totalLen+$wLen($i)}] |
||||
} |
||||
|
||||
set miss [expr {$Length - $totalLen}] |
||||
|
||||
# len walks through all lengths of words of the line under |
||||
# consideration |
||||
|
||||
for {set len 1} {$miss > 0} {incr len} { |
||||
for {set i 1} {($i < $numWords) && ($miss > 0)} {incr i} { |
||||
if {$wLen($i) == $len} { |
||||
set w($i) " $w($i)" |
||||
incr wLen($i) |
||||
incr miss -1 |
||||
} |
||||
} |
||||
} |
||||
|
||||
set line "" |
||||
for {set i 0} {$i < $numWords} {incr i} { |
||||
set line "$line$w($i)" |
||||
} |
||||
|
||||
# End of bugfix |
||||
|
||||
return "${line}" |
||||
} |
||||
|
||||
error "Illegal justification key \"$justify\"" |
||||
} |
||||
|
||||
proc ::textutil::adjust::SortList { list dir index } { |
||||
|
||||
if { [ catch { lsort -integer -$dir -index $index $list } sl ] != 0 } then { |
||||
error "$sl" |
||||
} |
||||
|
||||
return $sl |
||||
} |
||||
|
||||
# Hyphenation utilities based on Knuth's algorithm |
||||
# |
||||
# Copyright (C) 2001-2003 by Dr.Johannes-Heinrich Vogeler (jhv) |
||||
# These procedures may be used as part of the tcllib |
||||
|
||||
# textutil::adjust::Hyphenation |
||||
# |
||||
# Hyphenate a string using Knuth's algorithm |
||||
# |
||||
# Parameters: |
||||
# str string to be hyphenated |
||||
# |
||||
# Returns: |
||||
# the hyphenated string |
||||
|
||||
proc ::textutil::adjust::Hyphenation { str } { |
||||
|
||||
# if there are manual set hyphenation marks e.g. "Recht\-schrei\-bung" |
||||
# use these for hyphenation and return |
||||
|
||||
if {[regexp {[^\\-]*[\\-][.]*} $str]} { |
||||
regsub -all {(\\)(-)} $str {-} tmp |
||||
return [split $tmp -] |
||||
} |
||||
|
||||
# Don't hyphenate very short words! Minimum length for hyphenation |
||||
# is set to 3 characters! |
||||
|
||||
if { [string length $str] < 4 } then { return $str } |
||||
|
||||
# otherwise follow Knuth's algorithm |
||||
|
||||
variable HyphPatterns; # hyphenation patterns (TeX) |
||||
|
||||
set w ".[string tolower $str]."; # transform to lower case |
||||
set wLen [string length $w]; # and add delimiters |
||||
|
||||
# Initialize hyphenation weights |
||||
|
||||
set s {} |
||||
for {set i 0} {$i < $wLen} {incr i} { |
||||
lappend s 0 |
||||
} |
||||
|
||||
for {set i 0} {$i < $wLen} {incr i} { |
||||
set kmax [expr {$wLen-$i}] |
||||
for {set k 1} {$k < $kmax} {incr k} { |
||||
set sw [string range $w $i [expr {$i+$k}]] |
||||
if {[info exists HyphPatterns($sw)]} { |
||||
set hw $HyphPatterns($sw) |
||||
set hwLen [string length $hw] |
||||
for {set l1 0; set l2 0} {$l1 < $hwLen} {incr l1} { |
||||
set c [string index $hw $l1] |
||||
if {[string is digit $c]} { |
||||
set sPos [expr {$i+$l2}] |
||||
if {$c > [lindex $s $sPos]} { |
||||
set s [lreplace $s $sPos $sPos $c] |
||||
} |
||||
} else { |
||||
incr l2 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Replace all even hyphenation weigths by zero |
||||
|
||||
for {set i 0} {$i < [llength $s]} {incr i} { |
||||
set c [lindex $s $i] |
||||
if {!($c%2)} { set s [lreplace $s $i $i 0] } |
||||
} |
||||
|
||||
# Don't start with a hyphen! Take also care of words enclosed in quotes |
||||
# or that someone has forgotten to put a blank between a punctuation |
||||
# character and the following word etc. |
||||
|
||||
for {set i 1} {$i < ($wLen-1)} {incr i} { |
||||
set c [string range $w $i end] |
||||
if {[regexp {^[:alpha:][.]*} $c]} { |
||||
for {set k 1} {$k < ($i+1)} {incr k} { |
||||
set s [lreplace $s $k $k 0] |
||||
} |
||||
break |
||||
} |
||||
} |
||||
|
||||
# Don't separate the last character of a word with a hyphen |
||||
|
||||
set max [expr {[llength $s]-2}] |
||||
if {$max} {set s [lreplace $s $max end 0]} |
||||
|
||||
# return the syllabels of the hyphenated word as a list! |
||||
|
||||
set ret "" |
||||
set w ".$str." |
||||
for {set i 1} {$i < ($wLen-1)} {incr i} { |
||||
if {[lindex $s $i]} { append ret - } |
||||
append ret [string index $w $i] |
||||
} |
||||
return [split $ret -] |
||||
} |
||||
|
||||
# textutil::adjust::listPredefined |
||||
# |
||||
# Return the names of the hyphenation files coming with the package. |
||||
# |
||||
# Parameters: |
||||
# None. |
||||
# |
||||
# Result: |
||||
# List of filenames (without directory) |
||||
|
||||
proc ::textutil::adjust::listPredefined {} { |
||||
variable here |
||||
return [glob -type f -directory $here -tails *.tex] |
||||
} |
||||
|
||||
# textutil::adjust::getPredefined |
||||
# |
||||
# Retrieve the full path for a predefined hyphenation file |
||||
# coming with the package. |
||||
# |
||||
# Parameters: |
||||
# name Name of the predefined file. |
||||
# |
||||
# Results: |
||||
# Full path to the file, or an error if it doesn't |
||||
# exist or is matching the pattern *.tex. |
||||
|
||||
proc ::textutil::adjust::getPredefined {name} { |
||||
variable here |
||||
|
||||
if {![string match *.tex $name]} { |
||||
return -code error \ |
||||
"Illegal hyphenation file \"$name\"" |
||||
} |
||||
set path [file join $here $name] |
||||
if {![file exists $path]} { |
||||
return -code error \ |
||||
"Unknown hyphenation file \"$path\"" |
||||
} |
||||
return $path |
||||
} |
||||
|
||||
# textutil::adjust::readPatterns |
||||
# |
||||
# Read hyphenation patterns from a file and store them in an array |
||||
# |
||||
# Parameters: |
||||
# filNam name of the file containing the patterns |
||||
|
||||
proc ::textutil::adjust::readPatterns { filNam } { |
||||
|
||||
variable HyphPatterns; # hyphenation patterns (TeX) |
||||
|
||||
# HyphPatterns(_LOADED_) is used as flag for having loaded |
||||
# hyphenation patterns from the respective file (TeX format) |
||||
|
||||
if {[info exists HyphPatterns(_LOADED_)]} { |
||||
unset HyphPatterns(_LOADED_) |
||||
} |
||||
|
||||
# the array xlat provides translation from TeX encoded characters |
||||
# to those of the ISO-8859-1 character set |
||||
|
||||
set xlat(\"s) \337; # 223 := sharp s " |
||||
set xlat(\`a) \340; # 224 := a, grave |
||||
set xlat(\'a) \341; # 225 := a, acute |
||||
set xlat(\^a) \342; # 226 := a, circumflex |
||||
set xlat(\"a) \344; # 228 := a, diaeresis " |
||||
set xlat(\`e) \350; # 232 := e, grave |
||||
set xlat(\'e) \351; # 233 := e, acute |
||||
set xlat(\^e) \352; # 234 := e, circumflex |
||||
set xlat(\`i) \354; # 236 := i, grave |
||||
set xlat(\'i) \355; # 237 := i, acute |
||||
set xlat(\^i) \356; # 238 := i, circumflex |
||||
set xlat(\~n) \361; # 241 := n, tilde |
||||
set xlat(\`o) \362; # 242 := o, grave |
||||
set xlat(\'o) \363; # 243 := o, acute |
||||
set xlat(\^o) \364; # 244 := o, circumflex |
||||
set xlat(\"o) \366; # 246 := o, diaeresis " |
||||
set xlat(\`u) \371; # 249 := u, grave |
||||
set xlat(\'u) \372; # 250 := u, acute |
||||
set xlat(\^u) \373; # 251 := u, circumflex |
||||
set xlat(\"u) \374; # 252 := u, diaeresis " |
||||
|
||||
set fd [open $filNam RDONLY] |
||||
set status 0 |
||||
|
||||
while {[gets $fd line] >= 0} { |
||||
|
||||
switch -exact $status { |
||||
PATTERNS { |
||||
if {[regexp {^\}[.]*} $line]} { |
||||
# End of patterns encountered: set status |
||||
# and ignore that line |
||||
set status 0 |
||||
continue |
||||
} else { |
||||
# This seems to be pattern definition line; to process it |
||||
# we have first to do some editing |
||||
# |
||||
# 1) eat comments in a pattern definition line |
||||
# 2) eat braces and coded linefeeds |
||||
|
||||
set z [string first "%" $line] |
||||
if {$z > 0} { set line [string range $line 0 [expr {$z-1}]] } |
||||
|
||||
regsub -all {(\\n|\{|\})} $line {} tmp |
||||
set line $tmp |
||||
|
||||
# Now $line should consist only of hyphenation patterns |
||||
# separated by white space |
||||
|
||||
# Translate TeX encoded characters to ISO-8859-1 characters |
||||
# using the array xlat defined above |
||||
|
||||
foreach x [array names xlat] { |
||||
regsub -all {$x} $line $xlat($x) tmp |
||||
set line $tmp |
||||
} |
||||
|
||||
# split the line and create a lookup array for |
||||
# the repective hyphenation patterns |
||||
|
||||
foreach item [split $line] { |
||||
if {[string length $item]} { |
||||
if {![string match {\\} $item]} { |
||||
# create index for hyphenation patterns |
||||
|
||||
set var $item |
||||
regsub -all {[0-9]} $var {} idx |
||||
# store hyphenation patterns as elements of an array |
||||
|
||||
set HyphPatterns($idx) $item |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
EXCEPTIONS { |
||||
if {[regexp {^\}[.]*} $line]} { |
||||
# End of patterns encountered: set status |
||||
# and ignore that line |
||||
set status 0 |
||||
continue |
||||
} else { |
||||
# to be done in the future |
||||
} |
||||
} |
||||
default { |
||||
if {[regexp {^\\endinput[.]*} $line]} { |
||||
# end of data encountered, stop processing and |
||||
# ignore all the following text .. |
||||
break |
||||
} elseif {[regexp {^\\patterns[.]*} $line]} { |
||||
# begin of patterns encountered: set status |
||||
# and ignore that line |
||||
set status PATTERNS |
||||
continue |
||||
} elseif {[regexp {^\\hyphenation[.]*} $line]} { |
||||
# some particular cases to be treated separately |
||||
set status EXCEPTIONS |
||||
continue |
||||
} else { |
||||
set status 0 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
close $fd |
||||
set HyphPatterns(_LOADED_) 1 |
||||
|
||||
return |
||||
} |
||||
|
||||
####################################################### |
||||
|
||||
# @c The specified <a text>block is indented |
||||
# @c by <a prefix>ing each line. The first |
||||
# @c <a hang> lines ares skipped. |
||||
# |
||||
# @a text: The paragraph to indent. |
||||
# @a prefix: The string to use as prefix for each line |
||||
# @a prefix: of <a text> with. |
||||
# @a skip: The number of lines at the beginning to leave untouched. |
||||
# |
||||
# @r Basically <a text>, but indented a certain amount. |
||||
# |
||||
# @i indent |
||||
# @n This procedure is not checked by the testsuite. |
||||
|
||||
proc ::textutil::adjust::indent {text prefix {skip 0}} { |
||||
set text [string trimright $text] |
||||
|
||||
set res [list] |
||||
foreach line [split $text \n] { |
||||
if {[string compare "" [string trim $line]] == 0} { |
||||
lappend res {} |
||||
} else { |
||||
set line [string trimright $line] |
||||
if {$skip <= 0} { |
||||
lappend res $prefix$line |
||||
} else { |
||||
lappend res $line |
||||
} |
||||
} |
||||
if {$skip > 0} {incr skip -1} |
||||
} |
||||
return [join $res \n] |
||||
} |
||||
|
||||
# Undent the block of text: Compute LCP (restricted to whitespace!) |
||||
# and remove that from each line. Note that this preverses the |
||||
# shaping of the paragraph (i.e. hanging indent are _not_ flattened) |
||||
# We ignore empty lines !! |
||||
|
||||
proc ::textutil::adjust::undent {text} { |
||||
|
||||
if {$text == {}} {return {}} |
||||
|
||||
set lines [split $text \n] |
||||
set ne [list] |
||||
foreach l $lines { |
||||
if {[string length [string trim $l]] == 0} continue |
||||
lappend ne $l |
||||
} |
||||
set lcp [::textutil::string::longestCommonPrefixList $ne] |
||||
|
||||
if {[string length $lcp] == 0} {return $text} |
||||
|
||||
regexp "^(\[\t \]*)" $lcp -> lcp |
||||
|
||||
if {[string length $lcp] == 0} {return $text} |
||||
|
||||
set len [string length $lcp] |
||||
|
||||
set res [list] |
||||
foreach l $lines { |
||||
if {[string length [string trim $l]] == 0} { |
||||
lappend res {} |
||||
} else { |
||||
lappend res [string range $l $len end] |
||||
} |
||||
} |
||||
return [join $res \n] |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Data structures |
||||
|
||||
namespace eval ::textutil::adjust { |
||||
variable here [file dirname [info script]] |
||||
|
||||
variable Justify left |
||||
variable Length 72 |
||||
variable FullLine 0 |
||||
variable StrictLength 0 |
||||
variable Hyphenate 0 |
||||
variable HyphPatterns |
||||
|
||||
namespace export adjust indent undent |
||||
} |
||||
|
||||
# ### ### ### ######### ######### ######### |
||||
## Ready |
||||
|
||||
package provide textutil::adjust 0.7.3 |
@ -1,902 +0,0 @@
|
||||
% This is `dehypht.tex' as of 03 March 1999. |
||||
% |
||||
% Copyright (C) 1988,1991 Rechenzentrum der Ruhr-Universitaet Bochum |
||||
% [german hyphen patterns] |
||||
% Copyright (C) 1993,1994,1999 Bernd Raichle/DANTE e.V. |
||||
% [macros, adaption for TeX 2] |
||||
% |
||||
% ----------------------------------------------------------------- |
||||
% IMPORTANT NOTICE: |
||||
% |
||||
% This program can be redistributed and/or modified under the terms |
||||
% of the LaTeX Project Public License Distributed from CTAN |
||||
% archives in directory macros/latex/base/lppl.txt; either |
||||
% version 1 of the License, or any later version. |
||||
% ----------------------------------------------------------------- |
||||
% |
||||
% |
||||
% This file contains german hyphen patterns following traditional |
||||
% hyphenation rules and includes umlauts and sharp s, but without |
||||
% `c-k' and triple consonants. It is based on hyphen patterns |
||||
% containing 5719 german hyphen patterns with umlauts in the |
||||
% recommended version of September 27, 1990. |
||||
% |
||||
% For use with TeX generated by |
||||
% |
||||
% Norbert Schwarz |
||||
% Rechenzentrum Ruhr-Universitaet Bochum |
||||
% Universitaetsstrasse 150 |
||||
% D-44721 Bochum, FRG |
||||
% |
||||
% |
||||
% Adaption of these patterns for TeX, Version 2.x and 3.x and |
||||
% all fonts in T1/`Cork'/EC/DC and/or OT1/CM encoding by |
||||
% |
||||
% Bernd Raichle |
||||
% Stettener Str. 73 |
||||
% D-73732 Esslingen, FRG |
||||
% Email: raichle@Informatik.Uni-Stuttgart.DE |
||||
% |
||||
% |
||||
% Error reports in case of UNCHANGED versions to |
||||
% |
||||
% DANTE e.V., Koordinator `german.sty' |
||||
% Postfach 10 18 40 |
||||
% D-69008 Heidelberg, FRG |
||||
% Email: german@Dante.DE |
||||
% |
||||
% or one of the addresses given above. |
||||
% |
||||
% |
||||
% Changes: |
||||
% 1990-09-27 First version of `ghyphen3.tex' (Norbert Schwarz) |
||||
% 1991-02-13 PC umlauts changed to ^^xx (Norbert Schwarz) |
||||
% 1993-08-27 Umlauts/\ss changed to "a/\3 macros, added macro |
||||
% definitions and additional logic to select correct |
||||
% patterns/encoding (Bernd Raichle) |
||||
% 1994-02-13 Release of `ghyph31.tex' V3.1a (Bernd Raichle) |
||||
% 1999-03-03 Renamed file to `dehypht.tex' according to the |
||||
% naming scheme using the ISO country code `de', the |
||||
% common part `hyph' for all hyphenation patterns files, |
||||
% and the additional postfix `t' for traditional, |
||||
% removed wrong catcode change of ^^e (the comment |
||||
% character %) and ^^f (the character &), |
||||
% do _not_ change \catcode, \lccode, \uccode to avoid |
||||
% problems with other hyphenation pattern files, |
||||
% changed code to distinguish TeX 2.x/3.x, |
||||
% changed license conditions to LPPL (Bernd Raichle) |
||||
% |
||||
% |
||||
% For more information see the additional documentation |
||||
% at the end of this file. |
||||
% |
||||
% ----------------------------------------------------------------- |
||||
% |
||||
\message{German Traditional Hyphenation Patterns % |
||||
`dehypht' Version 3.2a <1999/03/03>} |
||||
\message{(Formerly known under the name `ghyph31' and `ghyphen'.)} |
||||
% |
||||
% |
||||
% Next we define some commands which are used inside the patterns. |
||||
% To keep them local, we enclose the rest of the file in a group |
||||
% (The \patterns command globally changes the hyphenation trie!). |
||||
% |
||||
\begingroup |
||||
% |
||||
% |
||||
% Make sure that doublequote is not active: |
||||
\catcode`\"=12 |
||||
% |
||||
% |
||||
% Because ^^e4 is used in the following macros which is read by |
||||
% TeX 2.x as ^^e or %, the comment character of TeX, some trick |
||||
% has to be found to avoid this problem. The same is true for the |
||||
% character ^^f or & in the TeX 2.x code. |
||||
% Therefore in the code the exclamationmark ! is used instead of |
||||
% the circumflex ^ and its \catcode is set appropriately |
||||
% (normally \catcode`\!=12, in the code \catcode`\!=7). |
||||
% |
||||
% The following \catcode, \lccode assignments and macro definitions |
||||
% are defined in such a way that the following \pattern{...} list |
||||
% can be used for both, TeX 2.x and TeX 3.x. |
||||
% |
||||
% We first change the \lccode of ^^Y to make sure that we can |
||||
% include this character in the hyphenation patterns. |
||||
% |
||||
\catcode`\^^Y=11 \lccode`\^^Y=`\^^Y |
||||
% |
||||
% Then we have to define some macros depending on the TeX version. |
||||
% Therefore we have to distinguish TeX version 2.x and 3.x: |
||||
% |
||||
\ifnum`\@=`\^^40 % true => TeX 3.x |
||||
% |
||||
% For TeX 3: |
||||
% ---------- |
||||
% |
||||
% Assign appropriate \catcode and \lccode values for all |
||||
% accented characters used in the patterns (\uccode changes are |
||||
% not used within \patterns{...} and thus not necessary): |
||||
% |
||||
\catcode"E4=11 \catcode"C4=11 % \"a \"A |
||||
\catcode"F6=11 \catcode"D6=11 % \"o \"O |
||||
\catcode"FC=11 \catcode"DC=11 % \"u \"U |
||||
\catcode"FF=11 \catcode"DF=11 % \ss SS |
||||
% |
||||
\lccode"C4="E4 \uccode"C4="C4 \lccode"E4="E4 \uccode"E4="C4 |
||||
\lccode"D6="F6 \uccode"D6="D6 \lccode"F6="F6 \uccode"F6="D6 |
||||
\lccode"DC="FC \uccode"DC="DC \lccode"FC="FC \uccode"FC="DC |
||||
\lccode"DF="FF \uccode"DF="DF \lccode"FF="FF \uccode"FF="DF |
||||
% |
||||
% In the following definitions we use ??xy instead of ^^xy |
||||
% to avoid errors when reading the following macro definitions |
||||
% with TeX 2.x (remember ^^e(4) is the comment character): |
||||
% |
||||
\catcode`\?=7 |
||||
% |
||||
% Define the accent macro " in such a way that it |
||||
% expands to single letters in font encoding T1. |
||||
\catcode`\"=13 |
||||
\def"#1{\ifx#1a??e4\else \ifx#1o??f6\else \ifx#1u??fc\else |
||||
\errmessage{Hyphenation pattern file corrupted!}% |
||||
\fi\fi\fi} |
||||
% |
||||
% - patterns with umlauts are ok |
||||
\def\n#1{#1} |
||||
% |
||||
% For \ss which exists in T1 _and_ OT1 encoded fonts but with |
||||
% different glyph codes, duplicated patterns for both encodings |
||||
% are included. Thus you can use these hyphenation patterns for |
||||
% T1 and OT1 encoded fonts: |
||||
% - define \3 to be code `\^^ff (\ss in font encoding T1) |
||||
% - define \9 to be code `\^^Y (\ss in font encoding OT1) |
||||
\def\3{??ff} |
||||
\def\9{??Y} |
||||
% - duplicated patterns to support font encoding OT1 are ok |
||||
\def\c#1{#1} |
||||
% >>>>>> UNCOMMENT the next line, if you do not want |
||||
% >>>>>> to use fonts in font encoding OT1 |
||||
%\def\c#1{} |
||||
% |
||||
\catcode`\?=12 |
||||
% |
||||
\else |
||||
% |
||||
% For TeX 2: |
||||
% ---------- |
||||
% |
||||
% Define the accent macro " to throw an error message. |
||||
\catcode`\"=13 |
||||
\def"#1{\errmessage{Hyphenation pattern file corrupted!}} |
||||
% |
||||
% - ignore all patterns with umlauts |
||||
\def\n#1{} |
||||
% |
||||
% With TeX 2 fonts in encoding T1 can be used, but all glyphs |
||||
% in positions > 127 can not be used in hyphenation patterns. |
||||
% Thus only patterns with glyphs in OT1 positions are included: |
||||
% - define \3 to be code ^^Y (\ss in CM font encoding) |
||||
% - define \9 to throw an error message |
||||
\def\3{^^Y} |
||||
\def\9{\errmessage{Hyphenation pattern file corrupted!}} |
||||
% - ignore all duplicated patterns with \ss in T1 encoding |
||||
\def\c#1{} |
||||
% |
||||
\fi |
||||
% |
||||
% |
||||
\patterns{% |
||||
.aa6l .ab3a4s .ab3ei .abi2 .ab3it .ab1l .ab1r .ab3u .ad3o4r .alti6 |
||||
.ana3c .an5alg .an1e .ang8s .an1s .ap1p .ar6sc .ar6ta .ar6tei .as2z |
||||
.au2f1 .au2s3 .be5erb .be3na .ber6t5r .bie6r5 .bim6s5t .brot3 .bru6s |
||||
.ch6 .che6f5 .da8c .da2r .dar5in .dar5u .den6ka .de5r6en .des6pe |
||||
.de8spo .de3sz .dia3s4 .dien4 .dy2s1 .ehren5 .eine6 .ei6n5eh .ei8nen |
||||
.ein5sa .en6der .en6d5r .en3k4 .en8ta8 .en8tei .en4t3r .epo1 .er6ban |
||||
.er6b5ei .er6bla .er6d5um .er3ei .er5er .er3in .er3o4b .erwi5s .es1p |
||||
.es8t .ex1a2 .ex3em .fal6sc .fe6st5a .flu4g3 .furch8 .ga6ner .ge3n4a |
||||
\n{.ge5r"o} .ges6 .halb5 .halbe6 .hal6br .haup4 .hau4t .heima6 .he4r3e |
||||
.her6za .he5x .hin3 .hir8sc .ho4c .hu3sa .hy5o .ibe5 .ima6ge .in1 |
||||
.ini6 .is5chi .jagd5 .kal6k5o .ka6ph .ki4e .kop6f3 .kraf6 \n{.k"u5ra} |
||||
.lab6br .liie6 .lo6s5k \n{.l"o4s3t} .ma5d .mi2t1 .no6th .no6top |
||||
.obe8ri .ob1l .obs2 .ob6st5e .or3c .ort6s5e .ost3a .oste8r .pe4re |
||||
.pe3ts .ph6 .po8str .rau4m3 .re5an .ro8q .ru5the \n{.r"u5be} |
||||
\n{.r"u8stet} .sch8 .se6e .se5n6h .se5ra .si2e .spi6ke .st4 .sy2n |
||||
.tages5 .tan6kl .ta8th .te6e .te8str .to6der .to8nin .to6we .um1 |
||||
.umpf4 .un1 .une6 .unge5n .ur1c .ur5en .ve6rin .vora8 .wah6l5 .we8ges |
||||
.wo6r .wor3a .wun4s .zi4e .zuch8 \n{."ande8re} \n{."och8} aa1c aa2gr |
||||
aal5e aa6r5a a5arti aa2s1t aat2s 6aba ab3art 1abdr 6abel aben6dr |
||||
ab5erk ab5err ab5esse 1abf 1abg \n{1abh"a} ab1ir 1abko a1bl ab1la |
||||
5ablag a6bla\3 \c{a6bla\9} ab4ler ab1lu \n{a8bl"a} \n{5a6bl"o} abma5c |
||||
1abn ab1ra ab1re 5a6brec ab1ro ab1s ab8sk abs2z 3abtei ab1ur 1abw |
||||
5abze 5abzu \n{ab1"an} \n{ab"au8} a4ce. a5chal ach5art ach5au a1che |
||||
a8chent ach6er. a6ch5erf a1chi ach1l ach3m ach5n a1cho ach3re a1chu |
||||
ach1w a1chy \n{ach5"af} ack1o acks6t ack5sta a1d 8ad. a6d5ac ad3ant |
||||
ad8ar 5addi a8dein ade5o8 adi5en 1adj 1adle ad1op a2dre 3adres adt1 |
||||
1adv \n{a6d"a} a1e2d ae1r a1er. 1aero 8afa a3fal af1an a5far a5fat |
||||
af1au a6fentl a2f1ex af1fr af5rau af1re 1afri af6tent af6tra aft5re |
||||
a6f5um \n{8af"a} ag5abe 5a4gent ag8er ages5e 1aggr ag5las ag1lo a1gn |
||||
ag2ne 1agog a6g5und a1ha a1he ah5ein a4h3erh a1hi ahl1a ah1le ah4m3ar |
||||
ahn1a a5ho ahra6 ahr5ab ah1re ah8rei ahren8s ahre4s3 ahr8ti ah1ru a1hu |
||||
\n{ah8"o} ai3d2s ai1e aif6 a3inse ai4re. a5isch. ais8e a3ismu ais6n |
||||
aiso6 a1j 1akad a4kade a1ke a1ki 1akko 5akro1 a5lal al5ans 3al8arm |
||||
al8beb al8berw alb5la 3album al1c a1le a6l5e6be a4l3ein a8lel a8lerb |
||||
a8lerh a6lert 5a6l5eth 1algi al4gli al3int al4lab al8lan al4l3ar |
||||
alle3g a1lo a4l5ob al6schm al4the altist5 al4t3re 8a1lu alu5i a6lur |
||||
alu3ta \n{a1l"a} a6mate 8ame. 5a6meise am6m5ei am6mum am2n ampf3a |
||||
am6schw am2ta a1mu \n{a1m"a} a3nac a1nad anadi5e an3ako an3alp 3analy |
||||
an3ame an3ara a1nas an5asti a1nat anat5s an8dent ande4s3 an1ec an5eis |
||||
an1e2k 4aner. a6n5erd a8nerf a6n5erke 1anfa 5anfert \n{1anf"a} 3angab |
||||
5angebo an3gli ang6lis an2gn 3angri ang5t6 \n{5anh"a} ani5g ani4ka |
||||
an5i8on an1kl an6kno an4kro 1anl anma5c anmar4 3annah anne4s3 a1no |
||||
5a6n1o2d 5a6n3oma 5a6nord 1anr an1sa 5anschl an4soz an1st 5anstal |
||||
an1s2z 5antenn an1th \n{5anw"a} a5ny an4z3ed 5anzeig 5anzieh 3anzug |
||||
\n{an1"a} \n{5an"as} \n{a1n"o} \n{an"o8d} a1os a1pa 3apfel a2ph1t |
||||
\n{aph5"a6} a1pi 8apl apo1c apo1s a6poste a6poth 1appa ap1pr a1pr |
||||
\n{a5p"a} \n{a3p"u} a1ra a4r3af ar3all 3arbei 2arbt ar1c 2a1re ar3ein |
||||
ar2gl 2a1ri ari5es ar8kers ar6les ar4nan ar5o6ch ar1o2d a1rol ar3ony |
||||
a8ror a3ros ar5ox ar6schl 8artei ar6t5ri a1ru a1ry 1arzt arz1w |
||||
\n{ar8z"a} \n{ar"a8m} \n{ar"o6} \n{ar5"om} \n{ar1"u2} a1sa a6schec |
||||
asch5l asch3m a6schn a3s4hi as1pa asp5l a8steb as5tev 1asth a6stoc |
||||
a1str ast3re 8a1ta ata5c ata3la a6tapf ata5pl a1te a6teli aten5a |
||||
ate5ran 6atf 6atg a1th at3hal 1athl 2a1ti 5atlant 3atlas 8atmus 6atn |
||||
a1to a6t5ops ato6ra a6t5ort. 4a1tr a6t5ru at2t1h \n{at5t6h"a} 6a1tu |
||||
atz1w \n{a1t"a} \n{a1t"u} au1a au6bre auch3a au1e aue4l 5aufent |
||||
\n{3auff"u} 3aufga 1aufn auf1t 3auftr 1aufw 3auge. au4kle aule8s 6aum |
||||
au8mar aum5p 1ausb 3ausd 1ausf 1ausg au8sin 3auss au4sta 1ausw 1ausz |
||||
aut5eng au1th 1auto au\3e8 \c{au\9e8} a1v ave5r6a aver6i a1w a6wes a1x |
||||
a2xia a6xio a1ya a1z azi5er. 8a\3 \c{8a\9} 1ba 8ba8del ba1la ba1na |
||||
ban6k5r ba5ot bardi6n ba1ro basten6 bau3sp 2b1b bb6le b2bli 2b1c 2b1d |
||||
1be be1a be8at. be1ch 8becht 8becke. be5el be1en bee8rei be5eta bef2 |
||||
8beff be1g2 \n{beh"o8} bei1s 6b5eisen bei3tr b8el bel8o belu3t be3nac |
||||
bend6o be6ners be6nerw be4nor ben4se6 bens5el \n{be1n"a} \n{be1n"u} |
||||
be1o2 b8er. be1ra be8rac ber8gab. ber1r \n{be1r"u} bes8c bes5erh |
||||
bes2p be5tha bet5sc be1un be1ur 8bex be6zwec 2b1f8 bfe6st5e 2b1g2 |
||||
bga2s5 bge1 2b1h bhole6 1bi bi1bl b6ie bi1el bi1la \n{bil"a5} bi1na |
||||
bi4nok bi5str bi6stu bi5tr bit4t5r b1j 2b1k2 \n{bk"u6} bl8 b6la. |
||||
6b1lad 6blag 8blam 1blat b8latt 3blau. b6lav 3ble. b1leb b1led |
||||
8b1leg 8b1leh 8bleid 8bleih 6b3lein blei3s ble4m3o 4blich b4lind |
||||
8bling b2lio 5blit b4litz b1loh 8b1los 1blu 5blum 2blun blut3a blut5sc |
||||
\n{3bl"a} \n{bl"as5c} \n{5bl"o} \n{3bl"u} \n{bl"u8sc} 2b1m 2b1n 1bo |
||||
bo1ch bo5d6s boe5 8boff 8bonk bo1ra b1ort 2b1p2 b1q 1br brail6 brast8 |
||||
bre4a b5red 8bref 8b5riem b6riga bro1s b1rup b2ruz \n{8br"oh} |
||||
\n{br"os5c} 8bs b1sa b8sang b2s1ar b1sc bs3erl bs3erz b8sof b1s2p |
||||
bst1h b3stru \n{b5st"a} b6sun 2b1t b2t1h 1bu bu1ie bul6k b8ure bu6sin |
||||
6b1v 2b1w 1by1 by6te. 8b1z bzi1s \n{1b"a} \n{b5"a6s5} \n{1b"u} |
||||
\n{b6"u5bere} \n{b"uge6} \n{b"ugel5e} \n{b"ur6sc} 1ca cag6 ca5la ca6re |
||||
ca5y c1c 1ce celi4c celich5 ce1ro c8h 2ch. 1chae ch1ah ch3akt cha6mer |
||||
8chanz 5chara 3chari 5chato 6chb 1chef 6chei ch3eil ch3eis 6cherkl |
||||
6chf 4chh 5chiad 5chias 6chins 8chj chl6 5chlor 6ch2m 2chn6 ch8nie |
||||
5cho. 8chob choi8d 6chp ch3ren ch6res \n{ch3r"u} 2chs 2cht cht5ha |
||||
cht3hi 5chthon ch6tin 6chuh chu4la 6ch3unt chut6t 8chw 1ci ci5tr c2k |
||||
2ck. ck1ei 4ckh ck3l ck3n ck5o8f ck1r 2cks ck5stra ck6s5u c2l 1c8o |
||||
con6ne 8corb cos6t c3q 1c6r 8c1t 1cu 1cy \n{5c"a1} \n{c"o5} 1da. |
||||
8daas 2dabg 8dabr 6dabt 6dabw 1dac da2gr 6d5alk 8d5amt dan6ce. |
||||
dani5er dan8ker 2danl danla6 6dans 8danzi 6danzu d1ap da2r1a8 2d1arb |
||||
d3arc dar6men 4d3art 8darz 1dat 8datm 2d1auf 2d1aus 2d1b 2d1c 2d1d |
||||
d5de d3d2h \n{dd"amme8} 1de 2deal de5an de3cha de1e defe6 6deff 2d1ehr |
||||
5d4eic de5isc de8lar del6s5e del6spr de4mag de8mun de8nep dene6r |
||||
8denge. 8dengen de5o6d 2deol de5ram 8derdb der5ein de1ro der1r d8ers |
||||
der5um de4s3am de4s3an de4sau de6sil de4sin de8sor de4spr de2su 8deul |
||||
de5us. 2d1f df2l 2d1g 2d1h 1di dia5c di5ara dice5 di3chr di5ena di1gn |
||||
di1la dil8s di1na 8dind 6dinf 4d3inh 2d1ins di5o6d di3p4t di8sen dis1p |
||||
di5s8per di6s5to dis5tra di8tan di8tin d1j 6dje 2dju 2d1k 2d1l 2d1m |
||||
2d1n6 dni6 dnje6 1do 6d5obe do6berf 6d5ony do3ran 6dord 2d1org dor4t3h |
||||
do6ste 6doth dott8e 2d1p d5q dr4 1drah 8drak d5rand 6dre. 4drech |
||||
d6reck 4d3reg 8d3reic d5reife 8drem 8d1ren 2drer 8dres. 6d5rh 1dria |
||||
d1ric 8drind droi6 dro5x 1dru 8drut \n{dr"os5c} \n{1dr"u} \n{dr"u5b} |
||||
\n{dr"u8sc} 2ds d1sa d6san dsat6 d1sc 5d6scha. 5dschik dse8e d8serg |
||||
8dsl d1sp d4spak ds2po \n{d8sp"a} d1st \n{d1s"u} 2dt d1ta d1te d1ti |
||||
d1to dt1s6 d1tu \n{d5t"a} 1du du5als du1b6 du1e duf4t3r 4d3uh du5ie |
||||
8duml 8dumw 2d1und du8ni 6d5unt dur2c durch3 6durl 6dursa 8durt du1s |
||||
du8schr 2d1v 2d1w dwa8l 2d1z \n{1d"a} \n{6d"ah} \n{8d"and} \n{d"a6r} |
||||
\n{d"o8bl} \n{d5"ol} \n{d"or6fl} \n{d"o8sc} \n{d5"o4st} \n{d"os3te} |
||||
\n{1d"u} ea4ben e1ac e1ah e1akt e1al. e5alf e1alg e5a8lin e1alk e1all |
||||
e5alp e1alt e5alw e1am e1and ea6nim e1ar. e5arf e1ark e5arm e3art |
||||
e5at. e6ate e6a5t6l e8ats e5att e6au. e1aus e1b e6b5am ebens5e |
||||
eb4lie eb4ser eb4s3in e1che e8cherz e1chi ech3m 8ech3n ech1r ech8send |
||||
ech4su e1chu eck5an e5cl e1d ee5a ee3e ee5g e1ei ee5isc eei4s3t |
||||
ee6lend e1ell \n{ee5l"o} e1erd ee3r4e ee8reng eere6s5 \n{ee5r"a} |
||||
ee6tat e1ex e1f e6fau e8fe8b 3effek ef3rom ege6ra eglo6si 1egy e1ha |
||||
e6h5ach eh5ans e6hap eh5auf e1he e1hi ehl3a eh1le ehl5ein eh1mu ehn5ec |
||||
e1ho ehr1a eh1re ehre6n eh1ri eh1ru ehr5um e1hu eh1w e1hy \n{e1h"a} |
||||
\n{e1h"o} \n{e3h"ut} ei1a eia6s ei6bar eich3a eich5r ei4dar ei6d5ei |
||||
ei8derf ei3d4sc ei1e 8eifen 3eifri 1eign eil1d ei6mab ei8mag ein1a4 |
||||
ei8nat ei8nerh ei8ness ei6nete ein1g e8ini ein1k ei6n5od ei8nok ei4nor |
||||
\n{e3ins"a} ei1o e1irr ei5ru ei8sab ei5schn ei6s5ent ei8sol ei4t3al |
||||
eit3ar eit1h ei6thi ei8tho eit8samt ei6t5um e1j 1ekd e1ke e1ki e1k2l |
||||
e1kn ekni4 e1la e2l1al 6elan e6lanf e8lanl e6l5ans el3arb el3arm |
||||
e6l3art 5e6lasti e6lauge elbst5a e1le 6elef ele6h e6l5ehe e8leif |
||||
e6l5einh 1elek e8lel 3eleme e6lemen e6lente el5epi e4l3err e6l5ersc |
||||
elf2l elg2 e6l5ins ell8er 4e1lo e4l3ofe el8soh el8tent 5eltern e1lu |
||||
elut2 \n{e1l"a} \n{e1l"u} em8dei em8meis 4emo emo5s 1emp1f 1empt 1emto |
||||
e1mu emurk4 emurks5 \n{e1m"a} en5a6ben en5achs en5ack e1nad en5af |
||||
en5all en3alt en1am en3an. en3ant en3anz en1a6p en1ar en1a6s 6e1nat |
||||
en3auf en3aus en2ce enda6l end5erf end5erg en8dess 4ene. en5eck |
||||
e8neff e6n5ehr e6n5eim en3eis 6enem. 6enen e4nent 4ener. e8nerd |
||||
e6n3erf e4nerg 5energi e6n5erla en5ers e6nerst en5erw 6enes e6n5ess |
||||
e2nex en3glo 2eni enni6s5 ennos4 enns8 e1no e6nober eno8f en5opf |
||||
e4n3ord en8sers ens8kl en1sp ens6por en5t6ag enta5go en8terbu en6tid |
||||
3entla ent5ric 5entwic 5entwu 1entz enu5i e3ny en8zan \n{en1"of} |
||||
\n{e1n"os} \n{e1n"ug} eo1c e5o6fe e5okk e1on. e3onf e5onk e5onl e5onr |
||||
e5opf e5ops e5or. e1ord e1org eo5r6h eo1t e1pa e8pee e6p5e6g ep5ent |
||||
e1p2f e1pi 5epid e6pidem e1pl 5epos e6pos. ep4p3a e1pr \n{e1p"a} e1q |
||||
e1ra. er5aal 8eraba e5rabel er5a6ben e5rabi er3abs er3ach era5e |
||||
era5k6l er3all er3amt e3rand e3rane er3ans e5ranz. e1rap er3arc |
||||
e3rari er3a6si e1rat erat3s er3auf e3raum 3erbse er1c e1re 4e5re. |
||||
er3eck er5egg er5e2h 2erei e3rei. e8reine er5einr 6eren. e4r3enm |
||||
4erer. e6r5erm er5ero er5erst e4r3erz er3ess \n{5erf"ul} er8gan. |
||||
5ergebn er2g5h \n{5erg"anz} \n{5erh"ohu} 2e1ri eri5ak e6r5iat e4r3ind |
||||
e6r5i6n5i6 er5ins e6r5int er5itio er1kl \n{3erkl"a} \n{5erl"os.} |
||||
ermen6s er6nab 3ernst 6e1ro. e1rod er1o2f e1rog 6e3roi ero8ide e3rol |
||||
e1rom e1ron e3rop8 e2r1or e1ros e1rot er5ox ersch4 5erstat er6t5ein |
||||
er2t1h er5t6her 2e1ru eruf4s3 e4r3uhr er3ums e5rus 5erwerb e1ry er5zwa |
||||
er3zwu \n{er"a8m} \n{er5"as} \n{er"o8} \n{e3r"os.} \n{e6r1"u2b} e1sa |
||||
esa8b e8sap e6s5a6v e1sc esch4l ese1a es5ebe eserve5 e8sh es5ill |
||||
es3int es4kop e2sl eso8b e1sp espei6s5 es2po es2pu 5essenz e6stabs |
||||
e6staf e6st5ak est3ar e8stob e1str est5res es3ur e2sz \n{e1s"u} e1ta |
||||
et8ag etari5e eta8ta e1te eten6te et5hal e5thel e1ti 1etn e1to e1tr |
||||
et3rec e8tscha et8se et6tei et2th et2t1r e1tu etu1s et8zent et8zw |
||||
\n{e1t"a} \n{e1t"o} \n{e1t"u} eu1a2 eu1e eue8rei eu5fe euin5 euk2 |
||||
e1um. eu6nio e5unter eu1o6 eu5p 3europ eu1sp eu5str eu8zo e1v eval6s |
||||
eve5r6en ever4i e1w e2wig ex1or 1exp 1extr ey3er. e1z \n{e1"a2} |
||||
\n{e5"o8} \n{e1"u} e8\3es \c{e8\9es} fa6ch5i fade8 fa6del fa5el. |
||||
fal6lo falt8e fa1na fan4gr 6fanl 6fap far6ba far4bl far6r5a 2f1art |
||||
fa1sc fau8str fa3y 2f1b2 6f1c 2f1d 1fe 2f1eck fe6dr feh6lei f6eim |
||||
8feins f5eis fel5en 8feltern 8femp fe5rant 4ferd. ferri8 fe8stof |
||||
fe6str fe6stum fe8tag fet6ta fex1 2ff f1fa f6f5arm f5fe ffe5in ffe6la |
||||
ffe8ler ff1f f1fla ff3lei ff4lie ff8sa ff6s5ta 2f1g2 fgewen6 4f1h 1fi |
||||
fid4 fi3ds fieb4 fi1la fi8lei fil4m5a f8in. fi1na 8finf fi8scho fi6u |
||||
6f1j 2f1k2 f8lanz fl8e 4f3lein 8flib 4fling f2lix 6f3lon 5flop 1flor |
||||
\n{5f8l"ac} \n{3fl"ot} 2f1m 2f1n 1fo foh1 f2on fo6na 2f1op fo5ra |
||||
for8mei for8str for8th for6t5r fo5ru 6f5otte 2f1p8 f1q fr6 f5ram |
||||
1f8ran f8ra\3 \c{f8ra\9} f8re. frei1 5frei. f3reic f3rest f1rib |
||||
8f1ric 6frig 1fris fro8na \n{fr"as5t} 2fs f1sc f2s1er f5str |
||||
\n{fs3t"at} 2ft f1tak f1te ft5e6h ftere6 ft1h f1ti f5to f1tr ft5rad |
||||
ft1sc ft2so f1tu ftwi3d4 ft1z 1fu 6f5ums 6funf fun4ka fu8\3end |
||||
\c{fu8\9end} 6f1v 2f1w 2f1z \n{1f"a} \n{f"a1c} \n{8f"arm} \n{6f"aug} |
||||
\n{f"a8\3} \n{\c{f"a8\9}} \n{f"ode3} \n{8f"of} \n{3f"or} \n{1f"u} |
||||
\n{f"un4f3u} 1ga ga6bl 6gabw 8gabz g3a4der ga8ho ga5isc 4gak ga1la |
||||
6g5amt ga1na gan5erb gan6g5a ga5nj 6ganl 8gansc 6garb 2g1arc 2g1arm |
||||
ga5ro 6g3arti ga8sa ga8sc ga6stre 2g1atm 6g5auf gau5fr g5aus 2g1b g5c |
||||
6gd g1da 1ge ge1a2 ge6an ge8at. ge1e2 ge6es gef2 8geff ge1g2l ge1im |
||||
4g3eise geist5r gel8bra gelt8s \n{ge5l"o} ge8nin gen3k 6g5entf |
||||
\n{ge3n"a} ge1or ge1ra ge6rab ger8au \n{8gerh"o} ger8ins ge1ro 6g5erz. |
||||
\n{ge1r"a} \n{ge1r"u} ge1s ges2p ge5unt 4g3ex3 2g1f8 2g1g g1ha 6g1hei |
||||
5ghel. g5henn 6g1hi g1ho 1ghr \n{g1h"o} 1gi gi5la gi8me. gi1na |
||||
4g3ins gi3str g1j 2g1k 8gl. 1glad g5lag glan4z3 1glas 6glass 5glaub |
||||
g3lauf 1gle. g5leb 3gleic g3lein 5gleis 1glem 2gler 8g3leu gli8a |
||||
g2lie 3glied 1g2lik 1g2lim g6lio 1gloa 5glom 1glon 1glop g1los g4loss |
||||
g5luf 1g2ly \n{1gl"u} 2g1m gn8 6gn. 1gna 8gnach 2gnah g1nas g8neu |
||||
g2nie g3nis 1gno 8gnot 1go goe1 8gof 2gog 5gogr 6g5oh goni5e 6gonist |
||||
go1ra 8gord 2g1p2 g1q 1gr4 g5rahm gra8m gra4s3t 6g1rec gre6ge 4g3reic |
||||
g5reit 8grenn gri4e g5riem 5grif 2grig g5ring 6groh 2grot gro6\3 |
||||
\c{gro6\9} 4grut 2gs gs1ab g5sah gs1ak gs1an gs8and gs1ar gs1au g1sc |
||||
gs1ef g5seil gs5ein g2s1er gs1in g2s1o gso2r gs1pr g2s1u 2g1t g3te |
||||
g2t1h 1gu gu5as gu2e 2gue. 6gued 4g3uh 8gums 6g5unt gu1s gut3h gu2tu |
||||
4g1v 2g1w gy1n g1z \n{1g"a} \n{8g"a8m} \n{6g"arm} \n{1g"o} \n{1g"u} |
||||
\n{6g"ub} 1haa hab8r ha8del hade4n 8hae ha5el. haf6tr 2hal. ha1la |
||||
hal4b5a 6hale 8han. ha1na han6dr han6ge. 2hani h5anth 6hanz 6harb |
||||
h3arbe h3arme ha5ro ha2t1h h1atm hau6san ha8\3 \c{ha8\9} h1b2 h1c h1d |
||||
he2bl he3cho h3echt he5d6s 5heft h5e6he. hei8ds h1eif 2hein he3ism |
||||
he5ist. heit8s3 hek6ta hel8lau 8helt he6mer 1hemm 6h1emp hen5end |
||||
hen5klo hen6tri he2nu 8heo he8q her3ab he5rak her3an 4herap her3au |
||||
h3erbi he1ro he8ro8b he4r3um her6z5er he4spe he1st heta6 het5am he5th |
||||
heu3sc he1xa hey5e h1f2 h1g hgol8 h1h h1iat hie6r5i hi5kt hil1a2 |
||||
hil4fr hi5nak hin4ta hi2nu hi5ob hirn5e hir6ner hi1sp hi1th hi5tr |
||||
5hitz h1j h6jo h1k2 hlabb4 hla4ga hla6gr h5lai hl8am h1las h1la\3 |
||||
\c{h1la\9} hl1c h1led h3lein h5ler. h2lif h2lim h8linf hl5int h2lip |
||||
h2lit h4lor h3lose \n{h1l"as} hme5e h2nee h2nei hn3eig h2nel hne8n |
||||
hne4p3f hn8erz h6netz h2nip h2nit h1nol hn5sp h2nuc h2nud h2nul hoch1 |
||||
1hoh hoh8lei 2hoi ho4l3ar 1holz h2on ho1ra 6horg 5horn. ho3sl hos1p |
||||
ho4spi h1p hpi6 h1q 6hr h1rai h8rank h5raum hr1c hrcre8 h1red h3reg |
||||
h8rei. h4r3erb h8rert hrg2 h1ric hr5ins h2rom hr6t5erl hr2t1h hr6t5ra |
||||
hr8tri h6rum hr1z hs3ach h6s5amt h1sc h6s5ec h6s5erl hs8erle h4sob |
||||
h1sp h8spa\3 \c{h8spa\9} h8spel hs6po h4spun h1str h4s3tum hs3und |
||||
\n{h1s"u} h5ta. h5tab ht3ac ht1ak ht3ang h5tanz ht1ar ht1at h5taub |
||||
h1te h2t1ec ht3eff ht3ehe h4t3eif h8teim h4t3ein ht3eis h6temp h8tentf |
||||
hte8ren \n{h6terf"u} h8tergr h4t3erh h6t5ersc h8terst h8tese h8tess |
||||
h2t1eu h4t3ex ht1he ht5hu h1ti ht5rak hts3ah ht1sc ht6sex ht8sk ht8so |
||||
h1tu htz8 \n{h5t"um} hub5l hu6b5r huh1l h5uhr. huld5a6 hu8lent |
||||
\n{hu8l"a} h5up. h1v h5weib h3weis h1z \n{h"a8kl} \n{h"al8s} |
||||
\n{h"ama8tu8} \n{h"a8sche.} \n{h"at1s} \n{h"au4s3c} \n{2h"o.} |
||||
\n{2h"oe} \n{8h"oi} \n{h"o6s} \n{h"os5c} \n{h"uhne6} \n{h"ul4s3t} |
||||
\n{h"utte8re} i5adn i1af i5ak. i1al. i1al1a i1alb i1ald i5alei i1alf |
||||
i1alg i3alh i1alk i1all i1alp i1alr i1als i1alt i1alv i5alw i3alz |
||||
i1an. ia5na i3and ian8e ia8ne8b i1ang i3ank i5ann i1ant i1anz i6apo |
||||
i1ar. ia6rab i5arr i1as. i1asm i1ass i5ast. i1at. i5ats i1au i5azz |
||||
i6b5eig i6b5eis ib2le i4blis i6brig i6b5unt \n{i6b"ub} i1che ich5ei |
||||
i6cherb i1chi ich5ins ich1l ich3m ich1n i1cho icht5an icht3r i1chu |
||||
ich1w ick6s5te ic5l i1d id3arm 3ideal ide8na 3ideol \n{ide5r"o} i6diot |
||||
id5rec id1t ie1a ie6b5ar iebe4s3 ie2bl ieb1r ie8bra ie4bre \n{ie8b"a} |
||||
ie2dr ie1e8 ie6f5ad ief5f ie2f1l ie4fro ief1t i1ei ie4l3ec ie8lei |
||||
ie4lek i3ell i1en. i1end ien6e i3enf i5enn ien6ne. i1enp i1enr |
||||
i5ensa ien8stal i5env i1enz ie5o ier3a4b ie4rap i2ere ie4rec ie6r5ein |
||||
ie6r5eis ier8er i3ern. ie8rum ie8rund ie6s5che ie6tau ie8tert ie5the |
||||
ie6t5ri i1ett ie5un iex5 2if i1fa if5ang i6fau if1fr if5lac i5f6lie |
||||
i1fre ift5a if6t5r ig3art 2ige i8gess ig5he i5gla ig2ni i5go ig3rot |
||||
ig3s2p i1ha i8ham i8hans i1he i1hi ih1n ih1r i1hu i8hum ih1w 8i1i ii2s |
||||
ii2t i1j i1k i6kak i8kerz i6kes ik4ler i6k5unt 2il i5lac i1lag il3ans |
||||
i5las i1lau il6auf i1le ile8h i8lel il2fl il3ipp il6l5enn i1lo ilt8e |
||||
i1lu \n{i1l"a} i8mart imb2 i8mele i8mid imme6l5a i1mu \n{i1m"a} |
||||
\n{i5m"o} ina5he i1nat in1au inau8s 8ind. in4d3an 5index ind2r 3indus |
||||
i5nec i2n1ei i8nerw 3infek 1info 5ingeni ing5s6o 5inhab ini5er. 5inj |
||||
\n{in8k"at} in8nan i1no inoi8d in3o4ku in5sau in1sp 5inspe 5instit |
||||
5instru ins4ze 5intere 5interv in3the in5t2r i5ny \n{in"a2} \n{i1n"ar} |
||||
\n{in1"as} \n{in"o8} \n{in5"od} \n{i1n"os} 2io io1a8 io1c iode4 io2di |
||||
ioi8 i1ol. i1om. i1on. i5onb ion2s1 i1ont i5ops i5o8pt i1or. |
||||
i3oral io3rat i5orc i1os. i1ot. i1o8x 2ip i1pa i1pi i1p2l i1pr i1q |
||||
i1ra ir6bl i1re i1ri ir8me8d ir2m1o2 ir8nak i1ro ir5rho ir6schl |
||||
ir6sch5r i5rus i5ry \n{i5r"a} i1sa i8samt i6sar i2s1au i8scheh i8schei |
||||
isch5m isch3r \n{isch"a8} is8ele ise3ra i4s3erh is3err isi6de i8sind |
||||
is4kop ison5e is6por i8s5tum i5sty \n{i5s"o} i1ta it5ab. i2t1a2m |
||||
i8tax i1te i8tersc i1thi i1tho i5thr \n{it8h"a} i1ti i8ti8d iti6kl |
||||
itmen4 i1to i8tof it3ran it3rau i1tri itri5o it1sc it2se it5spa it8tru |
||||
i1tu it6z5erg it6z1w \n{i1t"a} \n{it"a6r5e} \n{it"at2} \n{it"ats5} |
||||
\n{i1t"u} i1u iu6r 2i1v i6vad iva8tin i8vei i6v5ene i8verh i2vob i8vur |
||||
i1w iwi2 i5xa i1xe i1z ize8n i8zir i6z5w \n{i"a8m} \n{i1"a6r} |
||||
\n{i5"at.} \n{i5"av} \n{i1"o8} \n{i"u8} i6\35ers \c{i6\95ers} ja5la |
||||
je2t3r 6jm 5jo jo5as jo1ra jou6l ju5cha jugen4 jugend5 jung5s6 ju1s |
||||
\n{3j"a} 1ka 8kachs 8kakz ka1la kal5d kam5t ka1na 2kanl 8kapf ka6pl |
||||
ka5r6a 6k3arbe ka1ro kar6p5f 4k3arti 8karz \n{ka1r"a} kasi5e ka6teb |
||||
kat8ta kauf6s kau3t2 2k1b 2k1c 4k1d kehr6s kehrs5a 8keic 2k1eig 6k5ein |
||||
6k5eis ke6lar ke8leis ke8lo 8kemp k5ente. k3entf 8k5ents 6kentz ke1ra |
||||
k5erlau 2k1f8 2k1g 2k1h ki5fl 8kik king6s5 6kinh ki5os ki5sp ki5th |
||||
\n{8ki8"o} 2k1k2 kl8 1kla 8klac k5lager kle4br k3leib 3kleid kle5isc |
||||
4k3leit k3lek 6k5ler. 5klet 2klic 8klig k2lim k2lin 5klip 5klop k3lor |
||||
\n{1kl"a} 2k1m kmani5e kn8 6kner k2ni \n{kn"a8} 1k2o ko1a2 ko6de. |
||||
ko1i koi8t ko6min ko1op ko1or ko6pht ko3ra kor6d5er ko5ru ko5t6sc k3ou |
||||
3kow 6k5ox 2k1p2 k1q 1kr8 4k3rad 2k1rec 4k3reic kre5ie 2krib 6krig |
||||
2krip 6kroba 2ks k1sa k6sab ksal8s k8samt k6san k1sc k2s1ex k5spat |
||||
k5spe k8spil ks6por k1spr kst8 k2s1uf 2k1t kta8l kt5a6re k8tein kte8re |
||||
k2t1h k8tinf kt3rec kt1s 1ku ku1ch kuck8 k3uhr ku5ie kum2s1 kunfts5 |
||||
kun2s kunst3 ku8rau ku4ro kurz1 ku1st 4kusti ku1ta ku8\3 \c{ku8\9} |
||||
6k1v 2k1w ky5n 2k1z \n{1k"a} \n{k"a4m} \n{4k3"ami} \n{k"ase5} \n{1k"o} |
||||
\n{k"o1c} \n{k"o1s} \n{1k"u} \n{k"u1c} \n{k"ur6sc} \n{k"u1s} 1la. |
||||
8labf 8labh lab2r 2l1abs lach3r la8dr 5ladu 8ladv 6laff laf5t la2gn |
||||
5laken 8lamb la6mer 5lampe. 2l1amt la1na 1land lan4d3a lan4d3r lan4gr |
||||
8lanme 6lann 8lanw \n{6lan"a} 8lappa lap8pl lap6pr l8ar. la5ra lar4af |
||||
la8rag la8ran la6r5a6s l3arbe la8rei 6larm. la8sa la1sc la8sta lat8i |
||||
6l5atm 4lauss 4lauto 1law 2lb l8bab l8bauf l8bede l4b3ins l5blo |
||||
lbst5an lbst3e 8lc l1che l8chert l1chi lch3m l5cho lch5w 6ld l4d3ei |
||||
ld1re \n{l6d"ub} le2bl le8bre lecht6s5 led2r 6leff le4gas 1lehr lei6br |
||||
le8inf 8leinn 5leistu 4lektr le6l5ers lemo2 8lemp l8en. 8lends |
||||
6lendun le8nend len8erw 6l5ents 4l3entw 4lentz 8lenzy 8leoz 6lepi |
||||
le6pip 8lepo 1ler l6er. 8lerbs 6l5erde le8reis le8rend le4r3er 4l3erg |
||||
l8ergr 6lerkl 6l5erzie \n{8ler"o} 8lesel lesi5e le3sko le3tha let1s |
||||
5leuc 4leuro leu4s3t le5xe 6lexp l1f 2l1g lgend8 l8gh lglie3 lglied6 |
||||
6l1h 1li li1ar li1as 2lick li8dr li1en lien6n li8ers li8ert 2lie\3 |
||||
\c{2lie\9} 3lig li8ga8b li1g6n li1l8a 8limb li1na 4l3indu lings5 |
||||
4l3inh 6linj link4s3 4linkt 2lint 8linv lion5s6t 4lipp 5lipt 4lisam |
||||
livi5e 6l1j 6l1k l8keim l8kj lk2l lko8f lkor8 lk2sa lk2se 6ll l1la |
||||
ll3a4be l8labt ll8anl ll1b ll1c ll1d6 l1le l4l3eim l6l5eise ller3a |
||||
l4leti l5lip l1lo ll3ort ll5ov ll6spr llte8 l1lu ll3urg \n{l1l"a} |
||||
\n{l5l"u} \n{l6l"ub} 2l1m l6m5o6d 6ln l1na l1no 8lobl lo6br 3loch. |
||||
l5o4fen 5loge. 5lohn 4l3ohr 1lok l2on 4l3o4per lo1ra 2l1ord 6lorg |
||||
4lort lo1ru 1los. lo8sei 3losig lo6ve lowi5 6l1p lp2f l8pho l8pn |
||||
lp4s3te l2pt l1q 8l1r 2ls l1sa l6sarm l1sc l8sec l6s5erg l4s3ers l8sh |
||||
l5s6la l1sp ls4por ls2pu l1str l8suni \n{l1s"u} 2l1t lt5amp l4t3ein |
||||
l5ten l6t5eng l6t5erp l4t3hei lt3her l2t1ho l6t5i6b lti1l \n{l8tr"o} |
||||
lt1sc lt6ser lt4s3o lt5ums lu8br lu2dr lu1en8 8lu8fe luft3a luf8tr |
||||
lu6g5r 2luh l1uhr lu5it 5luk 2l1umf 2l1umw 1lun 6l5u6nio 4l3unte lu5ol |
||||
4lurg 6lurs l3urt lu4sto lu3str lu6st5re lu8su lu6tal lu6t5e6g lu8terg |
||||
lu3the lu6t5or lu2t1r lu6\35 \c{lu6\95} l1v lve5r6u 2l1w 1ly lya6 |
||||
6lymp ly1no l8zess l8zo8f l3zwei lz5wu \n{3l"and} \n{l"a5on} |
||||
\n{l"a6sc} \n{l"at1s} \n{5l"auf} \n{2l"aug} \n{l"au6s5c} \n{l"a5v} |
||||
\n{l1"ol} \n{1l"os} \n{l"o1\36t} \n{\c{l"o1\96t}} \n{6l1"ube} 1ma |
||||
8mabg ma5chan mad2 ma5el 4magg mag8n ma1la ma8lau mal5d 8malde mali5e |
||||
malu8 ma8lut 2m1amp 3man mand2 man3ds 8mangr mani5o 8m5anst 6mappa |
||||
4m3arbe mar8kr ma1r4o mar8schm 3mas ma1sc \n{ma1t"o} 4m5auf ma5yo 2m1b |
||||
mb6r 2m1c 2m1d \n{md6s"a} 1me me1ch me5isc 5meld mel8sa 8memp me5nal |
||||
men4dr men8schl men8schw 8mentsp me1ra mer4gl me1ro 3mes me6s5ei me1th |
||||
me8\3 \c{me8\9} 2m1f6 2m1g 2m1h 1mi mi1a mi6ale mi1la 2m1imm mi1na |
||||
\n{mi5n"u} mi4s3an mit1h mi5t6ra 3mitt mitta8 mi6\35 \c{mi6\95} 6mj |
||||
2m1k8 2m1l 2m1m m6mad m6m5ak m8menth m8mentw mme6ra m2mn mm5sp mm5ums |
||||
mmut5s \n{m8m"an} m1n8 m5ni 1mo mo5ar mo4dr 8mof mo8gal mo4kla mol5d |
||||
m2on mon8do mo4n3od mont8a 6m5ony mopa6 mo1ra mor8d5a mo1sc mo1sp 5mot |
||||
moy5 2mp m1pa mpfa6 mpf3l mphe6 m1pi mpin6 m1pl mp2li m2plu mpo8ste |
||||
m1pr \n{mpr"a5} mp8th mput6 mpu5ts \n{m1p"o} 8m1q 2m1r 2ms ms5au m1sc |
||||
msch4l ms6po m3spri m1str 2m1t mt1ar m8tein m2t1h mt6se \n{mt8s"a} |
||||
mu5e 6m5uh mumi1 1mun mun6dr muse5e mu1ta 2m1v mvol2 mvoll3 2m1w 1my |
||||
2m1z \n{m"a6kl} \n{1m"an} \n{m"a1s} \n{m"a5tr} \n{m"au4s3c} \n{3m"a\3} |
||||
\n{\c{3m"a\9}} \n{m"ob2} \n{6m"ol} \n{1m"u} \n{5m"un} \n{3m"ut} 1na. |
||||
n5ab. 8nabn n1abs n1abz \n{na6b"a} na2c nach3e 3nacht 1nae na5el |
||||
n1afr 1nag 1n2ah na8ha na8ho 1nai 6nair na4kol n1akt nal1a 8naly 1nama |
||||
na4mer na1mn n1amp 8n1amt 5nanc nan6ce n1and n6and. 2n1ang 1nani |
||||
1nann n1ans 8nanw 5napf. 1n2ar. na2ra 2n1arc n8ard 1nari n8ark |
||||
6n1arm 5n6ars 2n1art n8arv 6natm nat6s5e 1naue 4nauf n3aug 5naui n5auk |
||||
na5um 6nausb 6nauto 1nav 2nax 3naz 1na\3 \c{1na\9} n1b2 nbau5s n1c |
||||
nche5e nch5m 2n1d nda8d n2d1ak nd5ans n2d1ei nde8lac ndel6sa n8derhi |
||||
nde4se nde8stal n2dj ndnis5 n6d5or6t nd3rec nd3rot nd8samt nd6sau |
||||
ndt1h n8dumd 1ne ne5as ne2bl 6n5ebn 2nec 5neei ne5en ne1g4l 2negy |
||||
4n1ein 8neis 4n3e4lem 8nemb 2n1emp nen1a 6n5energ nen3k 8nentb |
||||
4n3en3th 8nentl 8n5entn 8n5ents ne1ra ne5r8al ne8ras 8nerbi 6n5erde. |
||||
nere5i6d nerfor6 \n{6n5erh"o} \n{8nerl"o} 2n1err n8ers. 6n5ertra |
||||
2n1erz nesi3e net1h neu4ra neu5sc 8neu\3 \c{8neu\9} n1f nf5f nf2l |
||||
nflei8 nf5lin nft8st n8g5ac ng5d ng8en nge8ram ngg2 ng1h n6glic ng3rip |
||||
ng8ru ng2se4 ng2si n2g1um n1gy \n{n8g"al} n1h nhe6r5e 1ni ni1bl |
||||
\n{ni5ch"a} ni8dee n6ie ni1en nie6s5te niet5h ni8etn 4n3i6gel n6ik |
||||
ni1la 2n1imp ni5na 2n1ind 8ninf 6n5inh ni8nit 6n5inn 2n1ins 4n1int |
||||
n6is ni3str ni1th ni1tr n1j n6ji n8kad nk5ans n1ke n8kerla n1ki nk5inh |
||||
\n{n5kl"o} n1k2n n8k5not nk3rot \n{n8kr"u} nk5spo nk6t5r n8kuh |
||||
\n{n6k"ub} n5l6 nli4mi n1m nmen4s n1na n8nerg nni5o n1no nn4t3ak nnt1h |
||||
nnu1e n1ny \n{n1n"a} \n{n1n"o} \n{n1n"u} no5a no4b3la 4n3obs 2nobt |
||||
noche8 no6die no4dis no8ia no5isc 6n5o6leu no4mal noni6er 2n1onk n1ony |
||||
4n3o4per 6nopf 6nopti no3ra no4ram nor6da 4n1org 2n1ort n6os no1st |
||||
8nost. no8tan no8ter noty6pe 6n5ox n1p2 n1q n1r \n{nr"os3} 6ns n1sac |
||||
ns3ang n1sc n8self n8s5erf n8serg n6serk ns5erw n8sint n1s2pe n1spr |
||||
n6s5tat. n5s6te. n6stob n1str n1ta n4t3a4go nt5anh nt3ark nt3art |
||||
n1te nt3eis nte5n6ar nte8nei nter3a nte6rei nt1ha nt6har n3ther nt5hie |
||||
n3thus n1ti nti1c n8tinh nti1t ntlo6b ntmen8 n1to nt3o4ti n1tr ntra5f |
||||
ntra5ut nt8rea nt3rec nt8rep n4t3rin nt8rop n4t3rot \n{n4tr"u} nt1s |
||||
nts6an nt2sk n1tu nt1z \n{n1t"a} \n{n1t"o} \n{n8t"ol} \n{n1t"u} 1nu |
||||
nu1a nu5el nu5en 4n1uhr nu5ie 8numl 6n5ums 6n5umw 2n1und 6nuni 6n5unr |
||||
2n1unt 2nup 2nu6r n5uri nu3skr nu5ta n1v 8n1w 1nys n1za n6zab n2z1ar |
||||
n6zaus nzi4ga n8zof n6z5unt n1zw n6zwir \n{1n"ac} \n{5n"ae} \n{5n"ai} |
||||
\n{n8"al} \n{n"a6m} \n{n"a6re} \n{n5"arz} \n{5n"aus} \n{n1"ol} |
||||
\n{1n"ot} \n{n5"oz} \n{5n"u.} \n{6n1"u2b} \n{5n"u\3} \n{\c{5n"u\9}} |
||||
o5ab. oa2l o8ala o1a2m o1an ob1ac obe4ra o6berh 5o4bers o4beru |
||||
obe6ser 1obj o1bl o2bli ob5sk 3obst. ob8sta obst5re ob5sz o1che |
||||
oche8b o8chec o3chi och1l och3m ocho8f o3chro och3to o3chu och1w o1d |
||||
o2d1ag od2dr ode5i ode6n5e od1tr o5e6b o5e6der. oe8du o1ef o1e2l |
||||
o1e2p o1er. o5e8x o1fa of8fan 1offi of8fin of6f5la o5fla o1fr 8o1g |
||||
og2n o1ha o1he o6h5eis o1hi ohl1a oh1le oh4l3er 5ohm. oh2ni o1ho |
||||
oh1re oh1ru o1hu oh1w o1hy \n{o1h"a} o5ia o1id. o8idi oi8dr o5ids |
||||
o5isch. oiset6 o1ism o3ist. o5i6tu o1j o1k ok2l ok3lau \n{o8kl"a} |
||||
1okta o1la old5am old5r o1le ole5in ole1r ole3u ol6gl ol2kl olk4s1 |
||||
ol8lak ol8lauf. ol6lel ol8less o1lo ol1s ol6sk o1lu oly1e2 5olym |
||||
o2mab om6an o8mau ombe4 o8merz om5sp o1mu o8munt \n{o1m"a} \n{o1m"o} |
||||
o1na ona8m on1ax on8ent o6n5erb 8oni oni5er. on1k on6n5a6b o1no ono1c |
||||
o4nokt 1ons onts8 \n{o1n"a} oo8f 1oog oo2pe oo2sa o1pa 3o4pera o3pfli |
||||
opf3lo opf3r o1pi o1pl o2pli o5p6n op8pa op6pl o1pr o3p4ter 1opti |
||||
\n{o1p"a} \n{o5p"o} o1q o1ra. o3rad o8radd 1oram o6rang o5ras o8rauf |
||||
or5cha or4d3a4m or8dei or8deu 1ordn or4dos o1re o5re. ore2h o8r5ein |
||||
ore5isc or6enn or8fla or8fli 1orga 5orgel. or2gl o1ri 5o6rient or8nan |
||||
\n{or8n"a} o1ro or1r2h or6t5an or8tau or8tere o1rus o1ry \n{o1r"a} |
||||
\n{or1"u2} o1sa osa3i 6ose o8serk o1sk o6ske o6ski os2kl os2ko os2kr |
||||
osni5e o2s1o2d o3s4per o4stam o6stau o3stra ost3re osu6 o6s5ur o5s6ze |
||||
o1ta ot3auf o6taus o1te o6terw o1th othe5u o2th1r o1ti o1to oto1a |
||||
ot1re o1tri o1tro ot1sc o3tsu ot6t5erg ot2t3h ot2t5r \n{ot8t"o} o1tu |
||||
ou3e ouf1 ou5f6l o5u6gr ou5ie ou6rar ou1t6a o1v o1wa o1we o6wer. o1wi |
||||
owid6 o1wo o5wu o1xe oy5al. oy1e oy1i o5yo o1z oza2r 1o2zea ozo3is |
||||
\n{o"o8} o\35elt \c{o\95elt} o\31t \c{o\91t} 3paa pa6ce 5pad pag2 1pak |
||||
pa1la pa8na8t pani5el pa4nor pan1s2 1pap pap8s pa8rei par8kr paro8n |
||||
par5o6ti part8e 5partei 3partn pas6sep pa4tha 1pau 6paug pau3sc p1b |
||||
8p5c 4p1d 1pe 4peic pe5isc 2pek pen3k pen8to8 p8er pe1ra pere6 per5ea |
||||
per5eb pe4rem 2perr per8ran 3pers 4persi \n{pe3r"u} pe4sta pet2s |
||||
p2f1ec p4fei pf1f pf2l 5pflanz pf8leg pf3lei 2pft pf3ta p1g 1ph 2ph. |
||||
2p1haf 6phb 8phd 6p5heit ph5eme 6phg phi6e 8phk 6phn p5holl pht2 |
||||
ph3tha 4ph3the phu6 6phz pi1en pi5err pi1la pi1na 5pinse pioni8e 1pis |
||||
pi1s2k pi1th p1k pl8 5pla p2lau 4plei p3lein 2pler 6p5les 2plig p6lik |
||||
6p5ling p2liz plo8min 6p1m p1n 1p2o 8poh 5pol po8lan poly1 po3ny po1ra |
||||
2porn por4t3h \n{po5r"o} 5poti p1pa p6p5ei ppe6la pp5f p2p1h p1pi pp1l |
||||
ppp6 pp5ren pp1s \n{p5p"o} pr6 3preis 1pres 2p3rig 5prinz 1prob 1prod |
||||
5prog pro8pt pro6t5a prote5i 8pro\3 \c{8pro\9} \n{pr"a3l} \n{1pr"as} |
||||
\n{pr"ate4} \n{1pr"uf} p5schl 2pst 1p2sy p1t p8to8d pt1s 5p6ty 1pu |
||||
pu1b2 2puc pu2dr puf8fr 6p5uh pun8s pu8rei pu5s6h pu1ta p1v p3w 5py |
||||
py5l p1z \n{p"a6der} \n{p5"a6m} \n{p"a8nu} \n{8p"ar} \n{p"at5h} |
||||
\n{p"at1s} qu6 1qui 8rabk ra6bla 3rable ra2br r1abt 6rabz ra4dan ra2dr |
||||
5rafal ra4f3er ra5gla ra2g3n 6raha ral5am 5rald 4ralg ra8lins 2rall |
||||
ral5t 8ramei r3anal r6and ran8der ran4dr 8ranf 6ranga 5rangi ran8gli |
||||
r3angr rans5pa 8ranw r8anz. ra5or 6rapf ra5pl rap6s5er 2r1arb 1rarh |
||||
r1arm ra5ro 2r1art 6r1arz ra8tei ra6t5he 6ratl ra4t3ro r5atta raue4n |
||||
6raus. r5austa rau8tel raut5s ray1 r1b rb5lass r6bler rb4lie rbon6n |
||||
r8brecht \n{rb6s5t"a} r8ces r1che rch1l rch3m rch3re rch3tr rch1w 8rd |
||||
r1da r8dachs r8dap rda5ro rde5ins rdio5 r8dir rd3ost r1dr r8drau 1re. |
||||
re1ak 3reakt re3als re6am. re1as 4reben re6bl rech5a r8edi re3er |
||||
8reff 3refl 2reh 5reha r4ei. reich6s5 8reier 6reign re5imp 4r3eina |
||||
6r3einb 6reing 6r5einn 6reinr 4r3eins r3eint reli3e 8r5elt 6rempf |
||||
2remt ren5a6b ren8gl r3enni 1reno 5rente 4r3enth 8rentl 4r3entw 8rentz |
||||
ren4zw re1on requi5 1rer rer4bl 6rerbs 4r3erd \n{8rerh"o} 8rerkl |
||||
4r3erla \n{8rerl"o} 4r3erns \n{6r5ern"a} rer5o 6r5erreg r5ertr r5erwec |
||||
\n{r5er"o} re2sa re8schm 2ress re5u8ni 6rewo 2r1ex r1f r8ferd rf4lie |
||||
8r1g r8gah rge4bl rge5na rgest4 rg6ne r2gni2 r8gob r4g3ret rg8sel r1h8 |
||||
r2hy 5rhyt ri1ar ri5cha rid2g r2ie rieg4s5 ri8ei ri1el ri6ele ri1en |
||||
ri3er. ri5ers. ri6fan ri8fer ri8fr 1r2ig ri8kn ri5la \n{rim"a8} |
||||
ri1na r8inde rin4ga rin6gr 1rinn 6rinner rino1 r8insp 4rinst |
||||
\n{ri1n"a} ri5o6ch ri1o2d ri3o6st 2r1ir r2is ri3sko ri8spr \n{ri8st"u} |
||||
ri5sv r2it 6r5i6tal ri5tr ri6ve. 8r1j 6rk r1ke rkehrs5 r1ki r3klin |
||||
r1k2n rk3str rk4t3an rk6to r6kuh \n{rk"a4s3t} r1l r5li rline5a 6r1m |
||||
r6manl rma4p r4m3aph r8minf r8mob rm5sa 2rn r1na rna8be r5ne rn2ei |
||||
r6neif r6nex r6nh rn1k r1no r6n5oc rn1sp \n{r1n"a} \n{r1n"u} ro6bern |
||||
6robs ro1ch 3rock. ro5de ro1e 4rofe ro8hert 1rohr ro5id ro1in ro5isc |
||||
6rolym r2on 6roog ro6phan r3ort ro1s2p ro5s6w ro4tau ro1tr ro6ts 5rout |
||||
r1p rpe8re rp2f r2ps r2pt r1q 2rr r1ra r1re rrer6 rr6hos \n{r5rh"o} |
||||
r1ri r1ro rro8f rr8or rror5a r1ru r3ry \n{r1r"a} \n{r1r"o} \n{r1r"u} |
||||
2r1s r6sab r4sanf rse6e rse5na r2sh r6ska r6ski rs2kl r8sko r2sl rs2p |
||||
r6stauf r8sterw r8stran rswi3d4 r2sz 2r1t rt3art r8taut r5tei rt5eige |
||||
r8tepe r4t3erh r8terla r4t3hei r5t6hu r4t3int rt5reif rt1sc rt6ser |
||||
rt6s5o rt6s5u rt5und r8turt rube6 ru1en 1r4uf ruf4st ru1ie 2r1umg |
||||
2r1uml 2rums run8der run4d5r 6rundz 6runf 8runs 2r1unt 2r1ur r6us |
||||
ru6sta ru3str ru6tr 1ruts r1v rven1 rvi2c r1w r1x r1za rz5ac r6z5al |
||||
r8z1ar r8zerd r6z5erf rz8erh rz4t3h r8zum \n{r"a4ste} \n{r"au8sc} |
||||
\n{r1"of} \n{5r"ohr} \n{r"o5le} \n{3r"oll} \n{5r"omis} \n{r1"or} |
||||
\n{r"o2sc} \n{3r"ump} 1sa. 1saa s3a4ben sa2bl 2s1abs 6s1abt 6sabw |
||||
3sack. 6s3a4der 1saf sa1fa 4s1aff sa5fr 1sag 1sai sa1i2k1 4s1akt 1sal |
||||
sa1la 4s3alpi 6salter salz3a 1sam s5anb san2c 1sand s5angeh 6sanl |
||||
2s1ans 6s3antr 8s1anw s1ap s6aph 8sapo sap5p6 s8ar. 2s1arb 3sarg |
||||
s1arm sa5ro 2s1art 6s1arz 1sas 1sat sat8a 2s1atl sa8tom 3s8aue s5auff |
||||
sau5i s6aur 2s1aus 5s6ause 2s1b2 2sca s4ce 8sch. 3scha. 5schade |
||||
3schaf 3schal sch5ame 8schanc 8schb 1sche 6schef 8schex 2schf 2schg |
||||
2schh 1schi 2schk 5schlag 5schlu \n{6schm"a\3} \n{\c{6schm"a\9}} |
||||
6schna\3 \c{6schna\9} 1scho 6schord 6schp 3schri 8schric 8schrig |
||||
8schrou 6schs 2scht sch3ta sch3tr 1schu 8schunt 6schv 2schz \n{5sch"o} |
||||
\n{5sch"u} 2sco scre6 6scu 2s1d 1se se5an se1ap se6ben se5ec see5i6g |
||||
se3erl 8seff se6han se8hi \n{se8h"o} 6s5eid. 2s1eig s8eil 5sein. |
||||
sei5n6e 6s5einh 3s8eit 3sel. se4lar selb4 6s3e4lem se8lerl 2s1emp |
||||
sen3ac se5nec 6s5ents 4sentz s8er. se8reim ser5inn \n{8serm"a} |
||||
8s5erzi \n{6ser"of} se1um 8sexa 6sexp 2s1f2 sfal8ler 2s3g2 sge5b2 s1h |
||||
s8hew 5s6hip 5s4hop 1si 2siat si1b sicht6s 6s5i6dee siege6s5 si1en |
||||
si5err si1f2 si1g2n si6g5r si8kau sik1i si4kin si2kl \n{si8k"u} si1la |
||||
sil6br si1na 2s1inf sin5gh 2s1inh sinne6s5 2s1ins si5ru si5str 4s1j |
||||
s1k2 6sk. 2skau skel6c skelch5 s6kele 1s2ki. 3s4kin. s6kiz s8kj |
||||
6skn 2skow 3skrib 3skrip 2sku \n{8sk"u} s1l s8lal slei3t s4low 2s1m |
||||
s1n 6sna 6snot 1so so1ch 2s1odo so4dor 6s5o4fen solo3 s2on so5of 4sope |
||||
so1ra 2s1ord 4sorga sou5c so3un 4s3ox sp2 8spaa 5spal 1span 2spap |
||||
s2pec s4peis 1spek s6perg 4spers s6pes 2s1pf 8sphi \n{1s2ph"a} 1spi |
||||
spi4e 6s5pig 6spinse 2spis 2spla 2spol 5s6pom 6s5pos 6spoti 1spra |
||||
3s8prec 6spreis 5spring 6sprob 1spru s2pul 1s2pur 6spy \n{5sp"an} |
||||
\n{1sp"u} s1q 2s1r 2s1s2 sse8nu ssini6s ssoi6r 2st. 1sta 4stafe 2stag |
||||
sta3la 6stale 4stalg 8stalk 8stamt 6st5anf 4stans 6stanw 6starb sta4te |
||||
6staus 2stb 6stc 6std 1ste 4steil 3s2tel st3elb 8stemb 6steppi 8stese |
||||
8stesse 6stf 2stg 2sth st1ha st3hei s8t1hi st1ho st5hu 1sti sti4el |
||||
4stigm sti3na 6stind 4stinf sti8r 2stk 2stl 2stm 1sto 6stoll. 4st3ope |
||||
6stopf. 6stord 6stp 5stra. 4strai 3s4tral 6s5traum 3stra\3 |
||||
\c{3stra\9} 3strec 6s3tref 8streib 5streif 6streno 6stres 6strev |
||||
5s6tria 6strig 5strik 8strisi 3s4troa s8troma st5rose 4struf 3strum |
||||
\n{6str"ag} 2st1s6 2stt 1stu stu5a 4stuc 2stue 8stun. 2stv 2stw s2tyl |
||||
6stz \n{1st"a} \n{8st"ag} \n{1st"o} \n{1st"u} \n{8st"uch} \n{4st"ur.} |
||||
1su su2b1 3suc su1e su2fe su8mar 6sumfa 8sumk 2s1unt sup1p2 6s5u6ran |
||||
6surte 2s1v 2s1w 1sy 8syl. sy5la syn1 sy2na syne4 s1z s4zend 5s6zene. |
||||
8szu \n{1s"a} \n{6s5"and} \n{6s"augi} \n{6s"au\3} \n{\c{6s"au\9}} |
||||
\n{5s"om} \n{2s1"u2b} \n{1s"uc} \n{s"u8di} \n{1s"un} \n{5s"u\3} |
||||
\n{\c{5s"u\9}} taats3 4tab. taba6k ta8ban tab2l ta6bre 4tabs t3absc |
||||
8tabz 6t3acht ta6der 6tadr tad6s tad2t 1tafe4 1tag ta6ga6 ta8gei |
||||
tage4s tag6s5t tah8 tahl3 tai6ne. ta5ir. tak8ta tal3au 1tale ta8leng |
||||
tal5ert 6t5a6mer 6tamp tampe6 2t1amt tan5d6a tan8dr tands5a tani5e |
||||
6tanl 2tanr t3ans 8t5antr tanu6 t5anw 8tanwa tan8zw ta8rau 6tarbe |
||||
1tari 2tark 2t1arm ta1ro 2tart t3arti 6tarz ta1sc ta6sien ta8stem |
||||
ta8sto t5aufb 4taufn 8taus. 5tause 8tausf 6tausg t5ausl 2t1b2 2t1c |
||||
t6chu 2t1d te2am tea4s te8ben 5techn 4teff te4g3re te6hau 2tehe te4hel |
||||
2t1ehr te5id. teig5l 6teign tei8gr 1teil 4teinh t5einhe 4teis t5eisen |
||||
8teiw te8lam te4lar 4telek 8telem te6man te6n5ag ten8erw ten5k tens4p |
||||
ten8tro 4t3entw 8tentz te6pli 5teppi ter5a6b te3ral ter5au 8terbar |
||||
t5erbe. 6terben 8terbs 4t3erbt t5erde. ter5ebe ter5ein te8rers terf4 |
||||
\n{8terh"o} \n{6terkl"a} ter8nor ter6re. t8erscha t5e6sel te8stau |
||||
t3euro te1xa tex3e 8texp tex6ta 2t1f2 2t1g2 2th. th6a 5tha. 2thaa |
||||
6t1hab 6t5haf t5hah 8thak 3thal. 6thals 6t3hand 2t1hau 1the. 3t4hea |
||||
t1heb t5heil t3heit t3helf 1theo 5therap 5therf 6t5herz 1thes 1thet |
||||
5thi. 2t1hil t3him 8thir 3this t5hj 2th1l 2th1m th1n t5hob t5hof |
||||
4tholz 6thopti 1thr6 4ths t1hum 1thy \n{4t1h"a} \n{2t1h"o} \n{t1h"u} |
||||
ti1a2m ti1b tie6fer ti1en ti8gerz tig3l ti8kin ti5lat 1tilg t1ind |
||||
tin4k3l ti3spa ti5str 5tite ti5tr ti8vel ti8vr 2t1j 2t1k2 2t1l tl8a |
||||
2t1m8 2t1n 3tobe 8tobj to3cha 5tocht 8tock tode4 to8del to8du to1e |
||||
6t5o6fen to1in toi6r 5toll. to8mene t2ons 2t1ony to4per 5topf. 6topt |
||||
to1ra to1s to6ska tos2l 2toti to1tr t8ou 2t1p2 6t1q tr6 tra5cha |
||||
tra8far traf5t 1trag tra6gl tra6gr t3rahm 1trai t6rans tra3sc tra6st |
||||
3traue t4re. 2trec t3rech t8reck 6t1red t8ree 4t1reg 3treib 4treif |
||||
8t3reis 8trepo tre6t5r t3rev 4t3rez 1trib t6rick tri6er 2trig t8rink |
||||
tri6o5d trizi5 tro1a 3troc trocke6 troi8d tro8man. tro3ny 5tropf |
||||
6t5rosa t5ro\3 \c{t5ro\9} 5trub 5trup trut5 \n{1tr"ag} \n{6t1r"oh} |
||||
\n{5tr"ub} \n{tr"u3bu} \n{t1r"uc} \n{t1r"us} 2ts ts1ab t1sac tsa8d |
||||
ts1ak t6s5alt ts1an ts1ar ts3auf t3schr \n{t5sch"a} tse6e tsee5i |
||||
tsein6s ts3ent ts1er t8serf t4serk t8sh 5t6sik t4s3int ts5ort. |
||||
t5s6por t6sprei t1st t6s5tanz ts1th t6stit t4s3tor 1t2sua t2s1uf |
||||
t8sum. t2s1u8n t2s1ur 2t1t tt5eif tte6sa tt1ha tt8ret tt1sc tt8ser |
||||
tt5s6z 1tuc tuch5a 1tu1e 6tuh t5uhr tu1i tu6it 1tumh 6t5umr 1tums |
||||
8tumt 6tund 6tunf 2t1unt tu5ra tu6rau tu6re. tu4r3er 2t1v 2t1w 1ty1 |
||||
ty6a ty8la 8tym 6ty6o 2tz tz5al tz1an tz1ar t8zec tzeh6 tzehn5 t6z5ei. |
||||
t6zor t4z3um \n{t6z"au} \n{5t"ag} \n{6t"ah} \n{t5"alt} \n{t8"an} |
||||
\n{t"are8} \n{8t"a8st} \n{6t"au\3} \n{\c{6t"au\9}} \n{t5"offen} |
||||
\n{8t"o8k} \n{1t"on} \n{4t"ub} \n{t6"u5ber.} \n{5t"uch} \n{1t"ur.} |
||||
u3al. u5alb u5alf u3alh u5alk u3alp u3an. ua5na u3and u5ans u5ar. |
||||
ua6th u1au ua1y u2bab ubi5er. u6b5rit ubs2k \n{u5b"o} \n{u8b"ub} 2uc |
||||
u1che u6ch5ec u1chi uch1l uch3m uch5n uch1r uch5to ucht5re u1chu uch1w |
||||
uck1a uck5in u1d ud4a u1ei u6ela uene8 u6ep u1er uer1a ue8rerl uer5o |
||||
u8esc u2est u8ev u1fa u2f1ei u4f3ent u8ferh uf1fr uf1l uf1ra uf1re |
||||
\n{uf1r"a} \n{uf1r"u} uf1s2p uf1st uft1s u8gabt u8gad u6gap ugeb8 u8gn |
||||
ugo3s4 u1ha u1he u1hi uh1le u1ho uh1re u1hu uh1w \n{u1h"a} \n{u1h"o} |
||||
6ui ui5en u1ig u3ins uin8tes u5isch. u1j 6uk u1ke u1ki u1kl u8klu |
||||
u1k6n u5ky u1la uld8se u1le ul8lac ul6lau ul6le6l ul6lo ulni8 u1lo |
||||
ulo6i ult6a ult8e u1lu ul2vr \n{u1l"a} \n{u1l"o} 3umfan 5umlau umo8f |
||||
um8pho u1mu umu8s \n{u5m"o} u1n1a un2al un6at unau2 6und. 5undein |
||||
un4d3um 3undzw \n{und"u8} \n{un8d"ub} une2b un1ec une2h un3eis 3unfal |
||||
\n{1unf"a} 5ungea \n{3ungl"u} ung2s1 \n{un8g"a} 1u2nif un4it un8kro |
||||
unk5s u1no unpa2 uns2p unvol4 unvoll5 u5os. u1pa u1pi u1p2l u1pr |
||||
up4s3t up2t1a u1q u1ra ur5abs ura8d ur5ah u6rak ur3alt u6rana u6r5ans |
||||
u8rap ur5a6ri u8ratt u1re ur3eig ur8gri u1ri ur5ins 3urlau urmen6 |
||||
ur8nan u1ro 3ursac ur8sau ur8sei ur4sk 3urtei u1ru uru5i6 uru6r u1ry |
||||
ur2za \n{ur6z"a} \n{ur5"a6m} \n{u5r"o} \n{u1r"u} \n{ur"uck3} u1sa |
||||
usa4gi u2s1ar u2s1au u8schec usch5wi u2s1ei use8kel u8sl u4st3a4b |
||||
us3tau u3s4ter u2s1uf u8surn ut1ac u1tal uta8m u1tan ut1ar u1tas ut1au |
||||
u1te u8teic u4tent u8terf u6terin u4t3hei ut5ho ut1hu u1ti utine5 |
||||
uti6q u1to uto5c u1tr ut1sa ut1s6p ut6stro u1tu utz5w u1u u1v uve5n |
||||
\n{uve3r4"a} u1w u1xe u5ya uy5e6 u1yi u2z1eh u8zerh \n{u5"o} u\3e6n |
||||
\c{u\9e6n} u\3en5e \c{u\9en5e} 8vanb 6vang 6varb var8d va6t5a va8tei |
||||
va2t1r 2v1b 6v5c 6vd 1ve 6ve5g6 ver1 ver5b verb8l ve2re2 verg8 ve2ru8 |
||||
ve1s ve2s3p ve3xe 2v1f 2v1g 6v5h vi6el vie6w5 vi1g4 vi8leh vil6le. |
||||
8vint vi1ru vi1tr 2v1k 2v1l 2v1m 4v5n 8vo8f voi6le vol8lend vol8li |
||||
v2or1 vo2re vo8rin vo2ro 2v1p 8vra v6re 2v1s 2v1t 2v1v 4v3w 2v1z |
||||
waffe8 wa6g5n 1wah wah8n wa5la wal8din wal6ta wan4dr 5ware wa8ru |
||||
war4za 1was w5c w1d 5wech we6fl 1weg we8geng weg5h weg3l we2g1r |
||||
weh6r5er 5weise weit3r wel2t welt3r we6rat 8werc 5werdu wer4fl 5werk. |
||||
wer4ka wer8ku wer4ta wer8term we2sp we8stend we6steu we8str |
||||
\n{we8st"o} wet8ta wich6s5t 1wid wi2dr wiede4 wieder5 wik6 wim6ma |
||||
win4d3r 5wirt wisch5l 1wj 6wk 2w1l 8w1n wo1c woche6 wol6f wor6t5r 6ws2 |
||||
w1sk 6w5t 5wunde. wun6gr wu1sc wu2t1 6w5w wy5a \n{w"arme5} \n{w"a1sc} |
||||
1xag x1ak x3a4men 8xamt x1an 8x1b x1c 1xe. x3e4g 1xen xe1ro x1erz |
||||
1xes 8xf x1g 8x1h 1xi 8xid xi8so 4xiste x1k 6x1l x1m 8xn 1xo 8x5o6d |
||||
8x3p2 x1r x1s6 8x1t x6tak x8terf x2t1h 1xu xu1e x5ul 6x3w x1z 5ya. |
||||
y5an. y5ank y1b y1c y6cha y4chia y1d yen6n y5ern y1g y5h y5in y1j |
||||
y1k2 y1lak yl1al yla8m y5lax y1le y1lo y5lu y8mn ym1p2 y3mu y1na yno2d |
||||
yn1t y1on. y1o4p y5ou ypo1 y1pr y8ps y1r yri3e yr1r2 y1s ys5iat ys8ty |
||||
y1t y3w y1z \n{y"a8m} z5a6b zab5l 8za6d 1zah za5is 4z3ak 6z1am 5zange. |
||||
8zanl 2z1ara 6z5as z5auf 3zaun 2z1b 6z1c 6z1d 1ze ze4dik 4z3eff 8zein |
||||
zei4ta zei8ters ze6la ze8lec zel8th 4zemp 6z5engel zen8zin \n{8zerg"a} |
||||
zer8i ze1ro zers8 zerta8 zer8tab zer8tag 8zerz ze8ste zeu6gr 2z1ex |
||||
2z1f8 z1g 4z1h 1zi zi1en zi5es. 4z3imp zi1na 6z5inf 6z5inni zin6s5er |
||||
8zinsuf zist5r zi5th zi1tr 6z1j 2z1k 2z1l 2z1m 6z1n 1zo zo6gl 4z3oh |
||||
zo1on zor6na8 4z1p z5q 6z1r 2z1s8 2z1t z4t3end z4t3hei z8thi 1zu zu3al |
||||
zu1b4 zu1f2 6z5uhr zun2a 8zunem zunf8 8zungl zu1o zup8fi zu1s8 zu1z |
||||
2z1v zw8 z1wal 5zweck zwei3s z1wel z1wer z6werg 8z5wes 1zwi zwi1s |
||||
6z1wo 1zy 2z1z zz8a zzi1s \n{1z"a} \n{1z"o} \n{6z"ol.} \n{z"o1le} |
||||
\n{1z"u} \n{2z1"u2b} \n{"a1a6} \n{"ab1l} \n{"a1che} \n{"a3chi} |
||||
\n{"ach8sc} \n{"ach8sp} \n{"a5chu} \n{"ack5a} \n{"ad1a} \n{"ad5era} |
||||
\n{"a6d5ia} \n{"a1e} \n{"a5fa} \n{"af1l} \n{"aft6s} \n{"ag1h} |
||||
\n{"ag3le} \n{"a6g5nan} \n{"ag5str} \n{"a1he} \n{"a1hi} \n{"ah1le} |
||||
\n{"ah5ne} \n{1"ahnl} \n{"ah1re} \n{"ah5ri} \n{"ah1ru} \n{"a1hu} |
||||
\n{"ah1w} \n{6"ai} \n{"a1isc} \n{"a6ische} \n{"a5ism} \n{"a5j} |
||||
\n{"a1k} \n{"al1c} \n{"a1le} \n{"a8lei} \n{"al6schl} \n{"ami1e} |
||||
\n{"am8n} \n{"am8s} \n{"a5na} \n{5"anderu} \n{"ane5i8} \n{"ang3l} |
||||
\n{"ank5l} \n{"a1no} \n{"an6s5c} \n{"a1pa} \n{"ap6s5c} \n{3"aq} |
||||
\n{"ar1c} \n{"a1re} \n{"are8m} \n{5"argern} \n{"ar6gl} \n{"a1ri} |
||||
\n{3"armel} \n{"a1ro} \n{"art6s5} \n{"a1ru} \n{3"arztl} \n{"a5r"o} |
||||
\n{"a6s5chen} \n{"asen8s} \n{"as1th} \n{"ata8b} \n{"a1te} \n{"ateri4} |
||||
\n{"ater5it} \n{"a6thy} \n{"a1ti} \n{3"atk} \n{"a1to} \n{"at8schl} |
||||
\n{"ats1p} \n{"a5tu} \n{"aub1l} \n{"au1e} \n{1"aug} \n{"au8ga} |
||||
\n{"au5i} \n{"a1um.} \n{"a1us.} \n{1"au\3} \n{\c{1"au\9}} \n{"a1z} |
||||
\n{"o1b} \n{"o1che} \n{"o5chi} \n{"och8stei} \n{"och8str} \n{"ocht6} |
||||
\n{5"o6dem} \n{5"offn} \n{"o1he} \n{"oh1l8} \n{"oh1re} \n{"o1hu} |
||||
\n{"o1is} \n{"o1ke} \n{1"o2ko} \n{1"ol.} \n{"ol6k5l} \n{"ol8pl} |
||||
\n{"o1mu} \n{"o5na} \n{"onig6s3} \n{"o1no} \n{"o5o6t} \n{"opf3l} |
||||
\n{"op6s5c} \n{"o1re} \n{"or8gli} \n{"o1ri} \n{"or8tr} \n{"o1ru} |
||||
\n{5"osterr} \n{"o1te} \n{"o5th} \n{"o1ti} \n{"o1tu} \n{"o1v} \n{"o1w} |
||||
\n{"owe8} \n{"o2z} \n{"ub6e2} \n{3"u4ber1} \n{"ub1l} \n{"ub1r} |
||||
\n{5"u2bu} \n{"u1che} \n{"u1chi} \n{"u8ch3l} \n{"uch6s5c} \n{"u8ck} |
||||
\n{"uck1a} \n{"uck5ers} \n{"ud1a2} \n{"u6deu} \n{"udi8t} \n{"u2d1o4} |
||||
\n{"ud5s6} \n{"uge4l5a} \n{"ug1l} \n{"uh5a} \n{"u1he} \n{"u8heh} |
||||
\n{"u6h5erk} \n{"uh1le} \n{"uh1re} \n{"uh1ru} \n{"u1hu} \n{"uh1w} |
||||
\n{"u3k} \n{"u1le} \n{"ul4l5a} \n{"ul8lo} \n{"ul4ps} \n{"ul6s5c} |
||||
\n{"u1lu} \n{"un8da} \n{"un8fei} \n{"unk5l} \n{"un8za} \n{"un6zw} |
||||
\n{"u5pi} \n{"u1re} \n{"u8rei} \n{"ur8fl} \n{"ur8fr} \n{"ur8geng} |
||||
\n{"u1ri} \n{"u1ro} \n{"ur8sta} \n{"ur8ster} \n{"u1ru} \n{"use8n} |
||||
\n{"u8sta} \n{"u8stes} \n{"u6s5tete} \n{"u3ta} \n{"u1te} \n{"u1ti} |
||||
\n{"ut8tr} \n{"u1tu} \n{"ut8zei} \n{"u1v} \31a8 \c{\91a8} 5\3a. |
||||
\c{5\9a.} \38as \c{\98as} \31b8 \c{\91b8} \31c \c{\91c} \31d \c{\91d} |
||||
1\3e \c{1\9e} \35ec \c{\95ec} 8\3e8g \c{8\9e8g} 8\3e8h \c{8\9e8h} |
||||
2\31ei \c{2\91ei} 8\3em \c{8\9em} \31f8 \c{\91f8} \31g \c{\91g} \31h |
||||
\c{\91h} 1\3i \c{1\9i} \31k \c{\91k} \31l \c{\91l} \31m \c{\91m} |
||||
\3mana8 \c{\9mana8} \31n \c{\91n} \31o \c{\91o} \31p8 \c{\91p8} \35q |
||||
\c{\95q} \31r \c{\91r} \31s2 \c{\91s2} \3st8 \c{\9st8} \31ta \c{\91ta} |
||||
\31te \c{\91te} \3t3hei \c{\9t3hei} \31ti \c{\91ti} \35to \c{\95to} |
||||
\31tr \c{\91tr} 1\3u8 \c{1\9u8} 6\35um \c{6\95um} \31v \c{\91v} \31w |
||||
\c{\91w} \31z \c{\91z} |
||||
}% |
||||
\endgroup |
||||
\relax\endinput |
||||
% |
||||
% ----------------------------------------------------------------- |
||||
% |
||||
% =============== Additional Documentation =============== |
||||
% |
||||
% |
||||
% Older Versions of German Hyphenation Patterns: |
||||
% ---------------------------------------------- |
||||
% |
||||
% All older versions of `ghyphen.tex' distributed as |
||||
% |
||||
% ghyphen.tex/germhyph.tex as of 1986/11/01 |
||||
% ghyphen.min/ghyphen.max as of 1988/10/10 |
||||
% ghyphen3.tex as of 1990/09/27 & 1991/02/13 |
||||
% ghyph31.tex as of 1994/02/13 |
||||
% |
||||
% are out of date and it is recommended to replace them |
||||
% with the new version `dehypht.tex' as of 1999/03/03. |
||||
% |
||||
% If you are using `ghyphen.min' (a minor version of `ghyphen') |
||||
% because of limited trie memory space, try this version and if |
||||
% the space is exceeded get a newer TeX implementation with |
||||
% larger or configurable trie memory sizes. |
||||
% |
||||
% |
||||
% |
||||
% Trie Memory Requirements/Space for Hyphenation Patterns: |
||||
% -------------------------------------------------------- |
||||
% |
||||
% To load this set of german hyphenation patterns the parameters |
||||
% of TeX has to have at least these values: |
||||
% |
||||
% TeX 3.x: |
||||
% IniTeX: trie_size >= 9733 trie_op_size >= 207 |
||||
% VirTeX: trie_size >= 8375 trie_op_size >= 207 |
||||
% |
||||
% TeX 2.x: |
||||
% IniTeX: trie_size >= 8675 trie_op_size >= 198 |
||||
% VirTeX: trie_size >= 7560 trie_op_size >= 198 |
||||
% |
||||
% If you want to load more than one set of hyphenation patterns |
||||
% (in TeX 3.x), the parameters have to be set to a value larger |
||||
% than or equal to the sum of all required values for each set. |
||||
% |
||||
% |
||||
% Setting Trie Memory Parameters: |
||||
% ------------------------------- |
||||
% |
||||
% Some implementations allow the user to change the default value |
||||
% of a set of the internal TeX parameters including the trie memory |
||||
% size parameter specifying the used memory for the hyphenation |
||||
% patterns. |
||||
% |
||||
% Web2c 7.x (Source), teTeX 0.9 (Unix, Amiga), fpTeX (Win32) |
||||
% and newer: |
||||
% The used memory size of the true is usually set high enough. |
||||
% If needed set the size of the trie using the keyword `trie_size' |
||||
% in the configuration file `texmf/web2c/texmf.cnf'. For details |
||||
% see the included documentation. |
||||
% |
||||
% emTeX (OS/2, MS-DOS, Windows 3.x/9x/NT): |
||||
% You can set the used memory size of the trie using the |
||||
% `-mt<number>' option on the command line or in the |
||||
% TEXOPTIONS environment variable. |
||||
% |
||||
% PasTeX (Amiga): |
||||
% The values for the parameters can be set using the keywords |
||||
% `triesize', `itriesize' and `trieopsize' in the configuration |
||||
% file. |
||||
% |
||||
% others (binaries only): |
||||
% See the documentation of the implementation if it is possible |
||||
% and how to change these values without recompilation. |
||||
% |
||||
% others (with sources) |
||||
% If the trie memory is too small, you have to recompile TeX |
||||
% using larger values for `trie_size' and `trie_op_size'. |
||||
% Modify the change file `tex.ch' and recompile TeX. |
||||
% For details see the documentation included in the sources. |
||||
% |
||||
% |
||||
% |
||||
% Necessary Settings in TeX macro files: |
||||
% -------------------------------------- |
||||
% |
||||
% \lefthyphenmin, \righthyphenmin: |
||||
% You can set both parameters to 2. |
||||
% |
||||
% \lccode <char>: |
||||
% To get correct hyphenation points within words containing |
||||
% umlauts or \ss, it's necessary to assign values > 0 to the |
||||
% appropriate \lccode <char> positions. |
||||
% |
||||
% These changes are _not_ done when reading this file and have to |
||||
% be included in the language switching mechanism as is done in, |
||||
% for example, `german.sty' (\lccode change for ^^Y = \ss in OT1, |
||||
% \left-/\righthyphenmin settings). |
||||
% |
||||
% |
||||
%% \CharacterTable |
||||
%% {Upper-case \A\B\C\D\E\F\G\H\I\J\K\L\M\N\O\P\Q\R\S\T\U\V\W\X\Y\Z |
||||
%% Lower-case \a\b\c\d\e\f\g\h\i\j\k\l\m\n\o\p\q\r\s\t\u\v\w\x\y\z |
||||
%% Digits \0\1\2\3\4\5\6\7\8\9 |
||||
%% Exclamation \! Double quote \" Hash (number) \# |
||||
%% Dollar \$ Percent \% Ampersand \& |
||||
%% Acute accent \' Left paren \( Right paren \) |
||||
%% Asterisk \* Plus \+ Comma \, |
||||
%% Minus \- Point \. Solidus \/ |
||||
%% Colon \: Semicolon \; Less than \< |
||||
%% Equals \= Greater than \> Question mark \? |
||||
%% Commercial at \@ Left bracket \[ Backslash \\ |
||||
%% Right bracket \] Circumflex \^ Underscore \_ |
||||
%% Grave accent \` Left brace \{ Vertical bar \| |
||||
%% Right brace \} Tilde \~} |
||||
%% |
||||
\endinput |
||||
%% |
||||
%% End of file `dehypht.tex'. |
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,223 +0,0 @@
|
||||
|
||||
%%%%%%%%%%%%%%%%%%%% file ithyph.tex |
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%% file ithyph.tex %%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
||||
% |
||||
% Prepared by Claudio Beccari e-mail beccari@polito.it |
||||
% |
||||
% Dipartimento di Elettronica |
||||
% Politecnico di Torino |
||||
% Corso Duca degli Abruzzi, 24 |
||||
% 10129 TORINO |
||||
% |
||||
% Copyright 1998, 2001 Claudio Beccari |
||||
% |
||||
% This program can be redistributed and/or modified under the terms |
||||
% of the LaTeX Project Public License Distributed from CTAN |
||||
% archives in directory macros/latex/base/lppl.txt; either |
||||
% version 1 of the License, or any later version. |
||||
% |
||||
% \versionnumber{4.8d} \versiondate{2001/11/21} |
||||
% |
||||
% These hyphenation patterns for the Italian language are supposed to comply |
||||
% with the Reccomendation UNI 6461 on hyphenation issued by the Italian |
||||
% Standards Institution (Ente Nazionale di Unificazione UNI). No guarantee |
||||
% or declaration of fitness to any particular purpose is given and any |
||||
% liability is disclaimed. |
||||
% |
||||
% See comments and loading instructions at the end of the file after the |
||||
% \endinput line |
||||
% |
||||
{\lccode`\'=`\' % Apostrophe has its own lccode so that it is treated |
||||
% as a letter |
||||
%>> 1998/04/14 inserted grouping |
||||
% |
||||
%\lccode23=23 % Compound word mark is a letter in encoding T1 |
||||
%\def\W{^^W} % ^^W =\char23 = \char"17 =\char'27 |
||||
% |
||||
\patterns{ |
||||
.a3p2n % After the Garzanti dictionary: a-pnea, a-pnoi-co,... |
||||
.anti1 .anti3m2n |
||||
.bio1 |
||||
.ca4p3s |
||||
.circu2m1 |
||||
.di2s3cine |
||||
%.e2x |
||||
.fran2k3 |
||||
.free3 |
||||
.narco1 |
||||
.opto1 |
||||
.orto3p2 |
||||
.para1 |
||||
.poli3p2 |
||||
.pre1 |
||||
.p2s |
||||
%.ri1a2 .ri1e2 .re1i2 .ri1o2 .ri1u2 |
||||
.sha2re3 |
||||
.tran2s3c .tran2s3d .tran2s3f .tran2s3l .tran2s3n .tran2s3p .tran2s3r .tran2s3t |
||||
.su2b3lu .su2b3r |
||||
.wa2g3n |
||||
.wel2t1 |
||||
a1ia a1ie a1io a1iu a1uo a1ya 2at. |
||||
e1iu e2w |
||||
o1ia o1ie o1io o1iu |
||||
%u1u |
||||
% |
||||
%1\W0a2 1\W0e2 1\W0i2 1\W0o2 1\W0u2 |
||||
'2 |
||||
1b 2bb 2bc 2bd 2bf 2bm 2bn 2bp 2bs 2bt 2bv |
||||
b2l b2r 2b. 2b'. 2b'' |
||||
1c 2cb 2cc 2cd 2cf 2ck 2cm 2cn 2cq 2cs 2ct 2cz |
||||
2chh c2h 2chb ch2r 2chn c2l c2r 2c. 2c'. 2c'' .c2 |
||||
1d 2db 2dd 2dg 2dl 2dm 2dn 2dp d2r 2ds 2dt 2dv 2dw |
||||
2d. 2d'. 2d'' .d2 |
||||
1f 2fb 2fg 2ff 2fn f2l f2r 2fs 2ft 2f. 2f'. 2f'' |
||||
1g 2gb 2gd 2gf 2gg g2h g2l 2gm g2n 2gp g2r 2gs 2gt |
||||
2gv 2gw 2gz 2gh2t 2g. 2g'. 2g'' |
||||
1h 2hb 2hd 2hh hi3p2n h2l 2hm 2hn 2hr 2hv 2h. 2h'. 2h'' |
||||
1j 2j. 2j'. 2j'' |
||||
1k 2kg 2kf k2h 2kk k2l 2km k2r 2ks 2kt 2k. 2k'. 2k'' |
||||
1l 2lb 2lc 2ld 2l3f2 2lg l2h 2lk 2ll 2lm 2ln 2lp |
||||
2lq 2lr 2ls 2lt 2lv 2lw 2lz 2l. 2l'. 2l'' |
||||
1m 2mb 2mc 2mf 2ml 2mm 2mn 2mp 2mq 2mr 2ms 2mt 2mv 2mw |
||||
2m. 2m'. 2m'' |
||||
1n 2nb 2nc 2nd 2nf 2ng 2nk 2nl 2nm 2nn 2np 2nq 2nr |
||||
2ns 2nt 2nv 2nz n2g3n 2nheit. 2n. 2n' 2n'' |
||||
1p 2pd p2h p2l 2pn 3p2ne 2pp p2r 2ps 3p2sic 2pt 2pz 2p. 2p'. 2p'' |
||||
1q 2qq 2q. 2q'. 2q'' |
||||
1r 2rb 2rc 2rd 2rf r2h 2rg 2rk 2rl 2rm 2rn 2rp |
||||
2rq 2rr 2rs 2rt rt2s3 2rv 2rx 2rw 2rz 2r. 2r'. 2r'' |
||||
1s2 2shm 2s3s s4s3m 2s3p2n 2stb 2stc 2std 2stf 2stg 2stm 2stn |
||||
2stp 2sts 2stt 2stv 2sz 4s. 4s'. 4s'' |
||||
1t 2tb 2tc 2td 2tf 2tg t2h t2l 2tm 2tn 2tp t2r 2ts |
||||
3t2sch 2tt 2tv 2tw t2z 2tzk 2tzs 2t. 2t'. 2t'' |
||||
1v 2vc v2l v2r 2vv 2v. 2v'. 2v'' |
||||
1w w2h wa2r 2w1y 2w. 2w'. 2w'' |
||||
1x 2xt 2xw 2x. 2x'. 2x'' |
||||
y1ou y1i |
||||
1z 2zb 2zd 2zl 2zn 2zp 2zt 2zs 2zv 2zz 2z. 2z'. 2z'' .z2 |
||||
}} % Pattern end |
||||
|
||||
\endinput |
||||
|
||||
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Information %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
||||
|
||||
|
||||
LOADING THESE PATTERNS |
||||
|
||||
These patterns, as well as those for any other language, do not become |
||||
effective until they are loaded in a special form into a format file; this |
||||
task is performed by the TeX initializer; any TeX system has its own |
||||
initializer with its special way of being activated. Before loading these |
||||
patterns, then, it is necessary to read very carefully the instructions that |
||||
come with your TeX system. |
||||
|
||||
Here I describe how to load the patterns with the freeware TeX system named |
||||
MiKTeX version 2.x for Windows 9x, NT, 2000, XP; with minor changes the |
||||
whole procedure is applicable with other TeX systems, but the details must |
||||
be deduced from your TeX system documentation at the section/chapter "How to |
||||
build or to rebuild a format file". |
||||
|
||||
With MikTeX: |
||||
|
||||
a) copy this file and replace the existing file ithyph.tex in the directory |
||||
\texmf\tex\generic\hyphen if the existing one has an older version date |
||||
and number. |
||||
b) select Start|Programs|MiKTeX|MiKTeX options. |
||||
c) in the Language tab add a check mark to the line concerning the Italian |
||||
language. |
||||
d) in the Geneal tab click "Update format files". |
||||
e) That's all! |
||||
|
||||
For the activation of these patterns with the specific Italian typesetting |
||||
features, use the babel package as this: |
||||
|
||||
\documentclass{article} % Or whatever other class |
||||
\usepackage[italian]{babel} |
||||
... |
||||
\begin{document} |
||||
... |
||||
\end{document} |
||||
|
||||
|
||||
ON ITALIAN HYPHENATION |
||||
|
||||
I have been working on patterns for the Italian language since 1987; in 1992 |
||||
I published |
||||
|
||||
C. Beccari, "Computer aided hyphenation for Italian and Modern |
||||
Latin", TUG vol. 13, n. 1, pp. 23-33 (1992) |
||||
|
||||
which contained a set of patterns that allowed hyphenation for both Italian |
||||
and Latin; a slightly modified version of the patterns published in the |
||||
above paper is contained in LAHYPH.TEX available on the CTAN archives. |
||||
|
||||
From the above patterns I extracted the minimum set necessary for |
||||
hyphenating Italian that was made available on the CTAN archives with the |
||||
name ITHYPH.tex the version number 3.5 on the 16th of August 1994. |
||||
|
||||
The original pattern set required 37 ops; being interested in a local |
||||
version of TeX/LaTeX capable of dealing with half a dozen languages, I |
||||
wanted to reduce memory occupation and therefore the number of ops. |
||||
|
||||
Th new version (4.0 released in 1996) of ITHYPH.TEX is much simpler than |
||||
version 3.5 and requires just 29 ops while it retains all the power of |
||||
version 3.5; it contains many more new patterns that allow to hyphenate |
||||
unusual words that generally have a root borrowed from a foreign language. |
||||
Updated versions 4.x contain minor additions and the number of ops is |
||||
increased to 30 (version 4.7 of 1998/06/01). |
||||
|
||||
This new pattern set has been tested with the same set of difficult Italian |
||||
words that was used to test version 3.5 and it yields the same results (a |
||||
part a minor change that was deliberately introduced so as to reduce the |
||||
typographical hyphenation with hyathi, since hyphenated hyathi are not |
||||
appreciated by Italian readers). A new enlarged word set for testing |
||||
purposes gets correct hyphen points that were missed or wrongly placed with |
||||
version 3.5, although no error had been reported, because such words are of |
||||
very specialized nature and are seldom used. |
||||
|
||||
As the previous version, this new set of patterns does not contain any |
||||
accented character so that the hyphenation algorithm behaves properly in |
||||
both cases, that is with cm and with dc/ec fonts. With LaTeXe terminology |
||||
the difference is between OT1 and T1 encodings; with the former encoding |
||||
fonts do not contain accented characters, while with the latter accented |
||||
characters are present and sequences such as \`a map directly to slot "E0 |
||||
that contains "agrave". |
||||
|
||||
Of course if you use dc/ec fonts (or any other real or virtual font with T1 |
||||
encoding) you get the full power of the hyphenation algorithm, while if you |
||||
use cm fonts (or any other real or virtual font with OT1 encoding) you miss |
||||
some possible break points; this is not a big inconvenience in Italian |
||||
because: |
||||
|
||||
1) The Regulation UNI 6015 on accents specifies that compulsory accents |
||||
appear only on the ending vowel of oxitone words; this means that it is |
||||
almost indifferent to have or to miss the dc/ec fonts because the only |
||||
difference consists in how TeX evaluates the end of the word; in practice |
||||
if you have these special facilities you get "qua-li-t\`a", while if you |
||||
miss them, you get "qua-lit\`a" (assuming that \righthyphenmin > 1). |
||||
|
||||
2) Optional accents are so rare in Italian, that if you absolutely want to |
||||
use them in those rare instances, and you miss the T1 encoding |
||||
facilities, you should also provide explicit discretionary hyphens as in |
||||
"s\'e\-gui\-to". |
||||
|
||||
There is no explicit hyphenation exception list because these patterns |
||||
proved to hyphenate correctly a very large set of words suitably chosen in |
||||
order to test them in the most heavy circumstances; these patterns were used |
||||
in the preparation of a number of books and no errors were discovered. |
||||
|
||||
Nevertheless if you frequently use technical terms that you want hyphenated |
||||
differently from what is normally done (for example if you prefer |
||||
etymological hyphenation of prefixed and/or suffixed words) you should |
||||
insert a specific hyphenation list in the preamble of your document, for |
||||
example: |
||||
|
||||
\hyphenation{su-per-in-dut-to-re su-per-in-dut-to-ri} |
||||
|
||||
Should you find any word that gets hyphenated in a wrong way, please, AFTER |
||||
CHECKING ON A RELIABLE MODERN DICTIONARY, report to the author, preferably |
||||
by e-mail. |
||||
|
||||
|
||||
Happy multilingual typesetting ! |
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue