# -*- tcl -*- # Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from -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 999999.0a1.0 # Meta platform tcl # Meta license # @@ Meta End # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[manpage_begin punkshell_module_punk::packagepreference 0 999999.0a1.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] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # oo::class namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #tcl::namespace::eval punk::packagepreference::class { #*** !doctools #[subsection {Namespace punk::packagepreference::class}] #[para] class definitions #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { #*** !doctools #[list_begin enumerated] # oo::class create interface_sample1 { # #*** !doctools # #[enum] CLASS [class interface_sample1] # #[list_begin definitions] # method test {arg1} { # #*** !doctools # #[call class::interface_sample1 [method test] [arg arg1]] # #[para] test method # puts "test: $arg1" # } # #*** !doctools # #[list_end] [comment {-- end definitions interface_sample1}] # } #*** !doctools #[list_end] [comment {--- end class enumeration ---}] #} #} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::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 [$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]} { puts stderr "--> pkg not already 'provided' but shared object seems to be loaded: $pkgloadedinfo - and multiple versions available" lassign $pkgloadedinfo path name set lcpath [string tolower $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]} { dict set lcpath_to_version [string tolower [lindex $scr 1]] $av } } } if {[dict exists $lcpath_to_version $lcpath]} { set lversion [dict get $lcpath_to_version $lcpath] } else { #fallback to a best effort guess based on the path set lversion [::punk::packagepreference::system::slibpath_guess_pkgversion $path $pkg] } 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] } } } } # --------------------------------------------------------------- #?? #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 {$COMMANDSTACKNEXT require [string tolower $pkg] {*}$vwant} v]} { try { set require_result [$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 [$COMMANDSTACKNEXT require $pkg {*}$vwant] } trap {} {emsg eopts} { return -options $eopts $emsg } } #--------------------------------------------------------------- #load relevant punk::args:: 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:: 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 $COMMANDSTACKNEXT require punk::args::$dp } } #--------------------------------------------------------------- return $require_result } default { return [$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 ' - then that information should be used to determine the version by matching 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) 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 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 999999.0a1.0 }] return #*** !doctools #[manpage_end]