You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
470 lines
24 KiB
470 lines
24 KiB
# -*- tcl -*- |
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
|
# module template: punkshell/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
|
# |
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# (C) 2024 |
|
# |
|
# @@ Meta Begin |
|
# Application punk::packagepreference 0.1.0 |
|
# Meta platform tcl |
|
# Meta license <unspecified> |
|
# @@ Meta End |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# doctools header |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[manpage_begin punkshell_module_punk::packagepreference 0 0.1.0] |
|
#[copyright "2024"] |
|
#[titledesc {punkshell package/module loading}] [comment {-- Name section and table of contents description --}] |
|
#[moddesc {package/module load}] [comment {-- Description at end of page heading --}] |
|
#[require punk::packagepreference] |
|
#[keywords module package] |
|
#[description] |
|
#[para] - |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section Overview] |
|
#[para] overview of punk::packagepreference |
|
#[subsection Concepts] |
|
#[para] - |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Requirements |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[subsection dependencies] |
|
#[para] packages used by punk::packagepreference |
|
#[list_begin itemized] |
|
|
|
package require Tcl 8.6- |
|
package require commandstack |
|
#*** !doctools |
|
#[item] [package {Tcl 8.6}] |
|
#[item] [package {commandstack}] |
|
|
|
# #package require frobz |
|
# #*** !doctools |
|
# #[item] [package {frobz}] |
|
|
|
#*** !doctools |
|
#[list_end] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
#*** !doctools |
|
#[section API] |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# Base namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
tcl::namespace::eval punk::packagepreference { |
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
|
|
|
variable PUNKARGS |
|
|
|
#*** !doctools |
|
#[subsection {Namespace punk::packagepreference}] |
|
#[para] Core API functions for punk::packagepreference |
|
#[list_begin definitions] |
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::packagepreference::uninstall |
|
@cmd -name ::punk::packagepreference::uninstall -help\ |
|
"Uninstall override for ::package builtin - for 'require' subcommand only." |
|
@values -min 0 -max 0 |
|
}] |
|
proc uninstall {} { |
|
#*** !doctools |
|
#[call [fun uninstall]] |
|
#[para]Return to the previous ::package implementation (This will be the builtin if no other override was present when install was called) |
|
|
|
commandstack::remove_rename {::package punk::packagepreference} |
|
} |
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::packagepreference::install |
|
@cmd -name ::punk::packagepreference::install -help\ |
|
"Install override for ::package builtin - for 'require' subcommand only." |
|
@values -min 0 -max 0 |
|
}] |
|
proc install {} { |
|
#*** !doctools |
|
#[call [fun install]] |
|
#[para]Override ::package builtin (or the current implementation if it has already been renamed/overridden) to check for and prefer lowercase packages/modules |
|
#[para](todo - check info loaded and restrict to existing version as determined from dll/so?) |
|
#[para]The overriding package command will call whatever implementation was in place before install to do the actual work - once it has modified 'package require' names to lowercase. |
|
#[para]This is intended to be in alignment with tip 590 "Recommend lowercase Package Names" |
|
#[para] https://core.tcl-lang.org/tips/doc/trunk/tip/590.md |
|
#[para]It prevents some loading errors when multiple package versions are available to an interpreter and the latest version is only provided by a lowercased module (.tm file) |
|
#[para]A package provided by the standard pkgIndex.tcl mechanism might override a later-versioned package because it may support both upper and lowercased names. |
|
#[para]The overriding of ::package only looks at 'package require' calls and preferentially tries the lowercase version (if the package isn't already loaded with either upper or lowercase name) |
|
#[para]This comes at some slight cost for packages that are only available with uppercase letters in the name - but at minimal cost for recommended lowercase package names |
|
#[para]Return to the standard ::package builtin by calling punk::packagepreference::uninstall |
|
|
|
#todo - review/update commandstack package |
|
#modern module/lib names should preferably be lower case |
|
#see tip 590 - "Recommend lowercase Package names". Where non-lowercase are deprecated (but not removed even in Tcl9) |
|
#Mixed case causes problems esp on windows where we can't have Package.tm and package.tm as they aren't distinguishable. |
|
#We enforce package to try lowercase first - at some potentially significant speed penalty if the lib actually does use uppercase |
|
#(also just overloading the package builtin comes at a cost!) |
|
#Without the lowercase-first mechanism - a lower versioned package such as Tablelist provided by a pkgIndex.tcl may be loaded in precedence to a higher versioned tablelist provided by a .tm |
|
#As punk kits launched with dev first arg may use tcl::tm::paths coming from both the system and zipkits for example - this is a problem. |
|
#(or in any environment where multiple versions of Tcl libraries may be available) |
|
#We can't provide a modernised .tm package for an old package that is commonly used with uppercase letters, in both the old form and lowercased form from a single .tm file. |
|
#It could be done by providing a redirecting .tm in a separate module path, or by providing a packageIndex.tcl to redirect it but both these solutions are error prone from a sysops perspective. |
|
set stackrecord [commandstack::rename_command -renamer punk::packagepreference package {args} { |
|
#::package override installed by punk::packagepreference::install |
|
#return to previous 'package' implementation with: punk::packagepreference::uninstall |
|
|
|
#uglier but faster than tcl::prefix::match in this instance |
|
#maintenance - check no prefixes of require are added to builtin package command |
|
switch -exact -- [lindex $args 0] { |
|
r - re - req - requi - requir - require { |
|
#puts "==>package $args" |
|
#puts "==>[info level 1]" |
|
#despite preference for lowercase - we need to handle packages that insist on providing as uppercase |
|
#(e.g we will still need to handle things like: package provide Tcl 8.6) |
|
#Where the package is already provided uppercase we shouldn't waste time deferring to lowercase |
|
set is_exact 0 |
|
if {[lindex $args 1] eq "-exact"} { |
|
set pkg [lindex $args 2] |
|
set vwant [lindex $args 3]-[lindex $args 3] |
|
set is_exact 1 |
|
} else { |
|
set pkg [lindex $args 1] |
|
set vwant [lrange $args 2 end] ;#rare - but version can be a list of requirements |
|
if {[llength $vwant] == 1 && [string first - [lindex $vwant 0]] > 0} { |
|
#only one version - and it has a dash |
|
lassign [split [lindex $vwant 0] -] a b |
|
if {$a eq $b} { |
|
#string compare version nums (can contain dots and a|b) |
|
set is_exact 1 |
|
} |
|
} |
|
} |
|
if {[set ver [$COMMANDSTACKNEXT_ORIGINAL provide $pkg]] ne ""} { |
|
#although we could shortcircuit using vsatisfies to return the ver |
|
#we should instead pass through to COMMANDSTACKNEXT so as not to interfere with whatever it does. |
|
#e.g a package require logger further down the commandstack |
|
return [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]] |
|
} |
|
|
|
if {!$is_exact && [llength $vwant] <= 1 } { |
|
#required version unspecified - or specified singularly |
|
set available_versions [$COMMANDSTACKNEXT_ORIGINAL versions $pkg] |
|
if {[llength $available_versions] >= 1} { |
|
# --------------------------------------------------------------- |
|
#An attempt to detect dll/so loaded and try to load same version |
|
#dll/so files are often named with version numbers that don't contain dots or a version number at all |
|
#e.g sqlite3400.dll Thread288.dll |
|
set pkgloadedinfo [lsearch -nocase -inline -index 1 [info loaded] $pkg] |
|
|
|
if {[llength $pkgloadedinfo]} { |
|
if {[llength $available_versions] > 1} { |
|
puts stderr "--> pkg $pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and [llength $available_versions] versions available" |
|
} |
|
lassign $pkgloadedinfo loaded_path name |
|
set lc_loadedpath [string tolower $loaded_path] |
|
#first attempt to find a match for our loaded sharedlib path in a *simple* package ifneeded statement. |
|
set lcpath_to_version [dict create] |
|
foreach av $available_versions { |
|
set scr [package ifneeded $pkg $av] |
|
#ifneeded script not always a valid tcl list |
|
if {![catch {llength $scr} scrlen]} { |
|
if {$scrlen == 3 && [lindex $scr 0] eq "load" && [string match -nocase [lindex $scr 2] $pkg]} { |
|
#a basic 'load <path> <pkg>' statement |
|
dict set lcpath_to_version [string tolower [lindex $scr 1]] $av |
|
} |
|
} |
|
} |
|
|
|
if {[dict exists $lcpath_to_version $lc_loadedpath]} { |
|
set lversion [dict get $lcpath_to_version $lc_loadedpath] |
|
} else { |
|
#fallback to a best effort guess based on the path |
|
set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $loaded_path $pkg] |
|
} |
|
#puts "====lcpath_to_version: $lcpath_to_version" |
|
if {$lversion ne ""} { |
|
#name matches pkg |
|
#hack for known dll version mismatch |
|
if {[string tolower $pkg] eq "thread" && $lversion eq "30b3"} { |
|
set lversion 3.0b3 |
|
} |
|
if {[llength $vwant] == 1} { |
|
#todo - still check vsatisfies - report a conflict? review |
|
} |
|
#return [$COMMANDSTACKNEXT require $pkg $lversion-$lversion] |
|
try { |
|
set result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg $lversion-$lversion]] |
|
} trap {} {emsg eopts} { |
|
#REVIEW - this occurred in punkmagic (rebuild of tclmagic) - probably due to multiple versions of registry |
|
#under different auto_path folders - and mal-ordering in punk::libunknown's tclPkgUnknown |
|
#May be obsolete.. issue still not clear |
|
|
|
#A hack for 'couldn't open "<path.dll>": permission denied' |
|
#This happens for example with the tcl9registry13.dll when loading from zipfs - but not in all systems, and not for all dlls. |
|
#exact cause unknown. |
|
#e.g |
|
#%package ifneeded registry 1.3.7 |
|
#- load //zipfs:/app/lib_tcl9/registry1.3/tcl9registry13.dll Registry |
|
#%load //zipfs:/app/lib_tcl9/registry1.3/tcl9registry13.dll Registry |
|
#couldn't open "C:/Users/sleek/AppData/Local/Temp/TCL00003cf8/tcl9registry13.dll": permission denied |
|
|
|
#a subsequent load of the path used in the error message works. |
|
|
|
#if {[string match "couldn't open \"*\": permission denied" $emsg]} {} |
|
if {[regexp {couldn't open "(.*)":.*permission denied.*} $emsg _ newpath]} { |
|
#Since this is a hack that shouldn't be required - be noisy about it. |
|
puts stderr ">>> $emsg" |
|
puts stderr "punk::packagepreference::require hack: Re-trying load of $pkg with path: $newpath" |
|
return [load $newpath $pkg] |
|
} else { |
|
#puts stderr "??? $emsg" |
|
#dunno - re-raise |
|
return -options $eopts $emsg |
|
} |
|
} |
|
return $result |
|
} |
|
#else puts stderr "> no version determined for pkg: $pkg loaded_path: $loaded_path" |
|
} |
|
} |
|
} |
|
# --------------------------------------------------------------- |
|
#?? |
|
#set pkgloadedinfo [lsearch -inline -index 1 [info loaded] $pkg] |
|
|
|
|
|
|
|
if {[regexp {[A-Z]} $pkg]} { |
|
#legacy package names |
|
#only apply catch & retry if there was a cap - otherwise we'll double try for errors unrelated to capitalisation |
|
if {[catch {uplevel 1 [list $COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant]} v]} { |
|
try { |
|
set require_result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg {*}$vwant]] |
|
} trap {} {emsg eopts} { |
|
return -options $eopts $emsg |
|
} |
|
} else { |
|
set require_result $v |
|
} |
|
} else { |
|
#return [$COMMANDSTACKNEXT require $pkg {*}$vwant] |
|
try { |
|
set require_result [uplevel 1 [list $COMMANDSTACKNEXT require $pkg {*}$vwant]] |
|
} trap {} {emsg eopts} { |
|
return -options $eopts $emsg |
|
} |
|
} |
|
#--------------------------------------------------------------- |
|
#load relevant punk::args::<docname> package(s) |
|
#todo - review whether 'packagepreference' is the right place for this. |
|
#It is conceptually different from the main functions of packagepreference, |
|
#but we don't really want to have a chain of 'package' overrides slowing performance. |
|
#there may be a more generic way to add soft side-dependencies that the original package doesn't/can't specify. |
|
#--------------------------------------------------------------- |
|
|
|
set lc_pkg [string tolower $pkg] |
|
#todo - lookup list of docpkgs for a package? from where? |
|
#we should have the option to not load punk::args::<docpkg> at all for many(most?) cases where they're unneeded. |
|
#e.g skip if not ::tcl_interactive? |
|
switch -exact -- $lc_pkg { |
|
tcl { |
|
set docpkgs [list tclcore] |
|
} |
|
tk { |
|
set docpkgs [list tkcore] |
|
} |
|
default { |
|
set docpkgs [list $lc_pkg] |
|
} |
|
} |
|
foreach dp $docpkgs { |
|
#review - versions? |
|
#we should be able to load more specific punk::args pkg based on result of [package present $pkg] |
|
catch { |
|
#$COMMANDSTACKNEXT require $pkg {*}$vwant |
|
#j2 |
|
uplevel 1 [list $COMMANDSTACKNEXT require punk::args::moduledoc::$dp] |
|
} |
|
} |
|
#--------------------------------------------------------------- |
|
return $require_result |
|
} |
|
default { |
|
return [uplevel 1 [list $COMMANDSTACKNEXT {*}$args]] |
|
} |
|
} |
|
|
|
}] |
|
if {[dict get $stackrecord implementation] ne ""} { |
|
set impl [dict get $stackrecord implementation] ;#use hardcoded name rather than slower (but more flexible) commandstack::get_next_command |
|
#puts stdout "punk::packagepreference renamed ::package to $impl" |
|
return 1 |
|
} else { |
|
puts stderr "punk::packagepreference failed to rename ::package" |
|
return 0 |
|
} |
|
#puts stdout [info body ::package] |
|
} |
|
|
|
#proc sample1 {p1 n args} { |
|
# #*** !doctools |
|
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
|
# #[para]Description of sample1 |
|
# #[para] Arguments: |
|
# # [list_begin arguments] |
|
# # [arg_def tring p1] A description of string argument p1. |
|
# # [arg_def integer n] A description of integer argument n. |
|
# # [list_end] |
|
# return "ok" |
|
#} |
|
|
|
|
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace punk::packagepreference ---}] |
|
} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# Secondary API namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
tcl::namespace::eval punk::packagepreference::lib { |
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
|
tcl::namespace::path [tcl::namespace::parent] |
|
#*** !doctools |
|
#[subsection {Namespace punk::packagepreference::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::packagepreference::lib ---}] |
|
} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
#*** !doctools |
|
#[section Internal] |
|
tcl::namespace::eval punk::packagepreference::system { |
|
#*** !doctools |
|
#[subsection {Namespace punk::packagepreference::system}] |
|
#[para] Internal functions that are not part of the API |
|
variable PUNKARGS |
|
|
|
lappend PUNKARGS [list { |
|
@id -id ::punk::packagepreference::system::slibpath_guess_pkgversion |
|
@cmd -name punk::packagepreference::system::slibpath_guess_pkgversion -help\ |
|
"Assistance function to determine pkg version from the information |
|
obtained from [info loaded]. This is used to try to avoid loading a different |
|
version of a binary package in another thread/interp when the package isn't |
|
present in the interp, but [info loaded] indicates the binary is already loaded. |
|
The more general/robust way to avoid this is to ensure ::auto_path and |
|
tcl::tm::list are the same in each interp/thread. |
|
|
|
This call should only be used as a fallback in case a binary package has a more |
|
complex ifneeded script. If the ifneeded script for a binary package is a |
|
straightforward 'load <path_to_binary> <pkgname>' - then that information |
|
should be used to determine the version by matching <path_to_binary> |
|
rather than this one. |
|
|
|
Takes a path to a shared lib (.so/.dll), and the name of its providing |
|
package, and return the version of the package if possible to determine |
|
from the path. |
|
The filename portion of the lib is often missing a version number or has |
|
a version number that has been shortened (e.g dots removed). |
|
The filename itself is first checked for a version number - but the number |
|
is ignored if it doesn't contain any dots. |
|
(prefix is checked to match with $pkgname, with a possible additional prefix |
|
of lib or tcl<int>) |
|
Often (even usually) the parent or grandparent folder will be named as |
|
per the package name with a proper version. If so we can return it, |
|
otherwise return empty string. |
|
The parent/grandparent matching will be done by looking for a case |
|
insensitive match of the prefix to $pkgname. |
|
" |
|
@values -min 1 |
|
libpath -help "Full path to shared library (.so,.dll etc)" |
|
pkgname -help "" |
|
}] |
|
proc slibpath_guess_pkgversion {libpath pkgname} { |
|
set root [file rootname [file tail $libpath]] |
|
set namelen [string length $pkgname] |
|
regexp {^(tcl(?:[0-9])+){0,1}(.*)} $root _match tclxx root ;#regexp will match anything - but only truncate leading tclXX.. |
|
set testv "" |
|
if {[string match -nocase $pkgname* $root]} { |
|
set testv [string range $root $namelen end] |
|
} elseif {[string match -nocase lib$pkgname* $root]} { |
|
set testv [string range $root $namelen+3 end] |
|
} |
|
if {[string first . $testv] > 0} { |
|
if {![catch [list package vcompare $testv $testv]]} { |
|
#testv has an inner dot and is understood by tcl as a valid version number |
|
return $testv |
|
} |
|
} |
|
#no valid dotted version found directly on dll or so filename |
|
set parent [file dirname $libpath] ;#parent folder is often some differentiator for platform or featureset (e.g win-x64) |
|
set grandparent [file dirname $parent] |
|
foreach path [list $parent $grandparent] { |
|
set segment [file tail $path] |
|
if {$segment eq "bin"} { |
|
continue |
|
} |
|
set testv "" |
|
if {[string match -nocase $pkgname* $segment]} { |
|
set testv [string range $segment $namelen end] |
|
} elseif {[string match -nocase critcl_$pkgname* $segment]} { |
|
set testv [string range $segment $namelen+7 end] |
|
} |
|
#we don't look for dot in parent/grandparent version - a bare integer here after the <pkgname> will be taken to be the version |
|
if {![catch [list package vcompare $testv $testv]]} { |
|
return $testv |
|
} |
|
} |
|
#review - sometimes path and lib are named only for major.minor but package provides major.minor.subversion |
|
#using returned val to attempt to package require -exact major.minor will fail to load major.minor.subversion |
|
return "" |
|
} |
|
|
|
} |
|
|
|
namespace eval ::punk::args::register { |
|
#use fully qualified so 8.6 doesn't find existing var in global namespace |
|
lappend ::punk::args::register::NAMESPACES ::punk::packagepreference ::punk::packagepreference::system |
|
} |
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
## Ready |
|
package provide punk::packagepreference [tcl::namespace::eval punk::packagepreference { |
|
variable pkg punk::packagepreference |
|
variable version |
|
set version 0.1.0 |
|
}] |
|
return |
|
|
|
#*** !doctools |
|
#[manpage_end] |
|
|
|
|