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.
 
 
 
 
 
 

603 lines
26 KiB

# -*- tcl -*-
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck 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
package require punk::lib
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
namespace eval punk::mix::commandset::loadedlib {
namespace export *
#search automatically wrapped in * * - can contain inner * ? globs
punk::args::define {
@id -id ::punk::mix::commandset::loadedlib::search
@cmd -name "punk::mix::commandset::loadedlib search" -help "search all Tcl libraries available to your local interpreter"
-return -type string -default table -choices {table tableobject list lines}
-present -type integer -default 2 -choices {0 1 2} -choicelabels {absent present both} -help\
"(unimplemented) Display only those that are 0:absent 1:present 2:either"
-highlight -type boolean -default 1 -help\
"Highlight which version is present with ansi underline and colour"
-refresh -default 0 -type boolean -help "Re-scan the tm and library folders"
searchstrings -default * -multiple 1 -help\
"Names to search for, may contain glob chars (* ?) e.g *lib*
If no glob chars are explicitly specified, the searchstring will be wrapped with star globs.
eg name -> *name*
To search for an exact name prefix it with =
e.g =name -> name
"
}
proc search {args} {
set argd [punk::args::get_by_id ::punk::mix::commandset::loadedlib::search $args]
set searchstrings [dict get $argd values searchstrings]
set opts [dict get $argd opts]
set opt_return [dict get $opts -return]
set opt_highlight [dict get $opts -highlight]
#REVIEW - this doesn't result in full scans
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
}
set packages [package names]
set matches [list]
foreach search $searchstrings {
if {[regexp {[?*\[]} $search]} {
#caller has specified specific glob pattern - use it
#todo - respect supplied case only if uppers present? require another flag?
lappend matches {*}[lsearch -all -inline -nocase $packages $search]
} elseif {[string match =* $search]} {
lappend matches {*}[lsearch -all -inline -exact $packages [string range $search 1 end]]
} else {
#make it easy to search for anything
lappend matches {*}[lsearch -all -inline -nocase $packages "*$search*"]
}
}
set matches [lsort -unique $matches][unset matches]
set matchinfo [list]
set highlight_ansi [a+ web-limegreen underline]
set RST [a]
foreach m $matches {
set versions [package versions $m]
if {![llength $versions]} {
#e.g builtins such as zlib - shows no versions - but will show version when package present/provide used
set versions [package provide $m]
#if {![catch {package present $m} v]} {
# set versions $v
#}
}
if {$has_natsort} {
set versions [natsort::sort $versions]
} else {
set versions [lsort $versions]
}
if {$opt_highlight} {
set v [package provide $m]
if {$v ne ""} {
set posn [lsearch $versions $v]
if {$posn >= 0} {
#FIXME! (probably in textblock::pad ?)
#TODO - determine why underline is extended to padding even with double reset. (space or other char required to prevent)
set highlighted "$highlight_ansi$v$RST $RST"
set versions [lreplace $versions $posn $posn $highlighted]
} else {
#shouldn't be possible?
puts stderr "failed to find version '$v' in versions:$versions for package $m"
}
}
}
lappend matchinfo [list $m $versions]
}
switch -- $opt_return {
list {
return $matchinfo
}
lines {
return [join $matchinfo \n]
}
table - tableobject {
set t [textblock::class::table new]
$t add_column -headers "Package"
$t add_column -headers "Version"
$t configure -show_hseps 0
foreach m $matchinfo {
$t add_row [list [lindex $m 0] [join [lindex $m 1] " "]]
}
if {$opt_return eq "tableobject"} {
return $t
}
set result [$t print]
$t destroy
return $result
}
}
}
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 $libname 1-0} ;#ensure pkg system has loaded/searched - using unsatisfiable version range
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 $library 1-0} ;#ensure pkg system has loaded/searched for everything for the path of the specified library (using unsatisfiable version range)
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]
set majorv [lindex [split [info tclversion] .] 0]
foreach k [list modules modules_tcl$majorv vendormodules vendormodules_tcl$majorv] {
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 bootsupport/modules_tcl$majorv"} {
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]]
set versions [lsort -command {package vcompare} $versions]
#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 {\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 {\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 "---"
set question "Proceed to create ${pkgtail}-${ver}.tm module? Y|N"
set answer [punk::lib::askuser $question] ;#takes account of previous stdin state and terminal raw vs line state
if {[string tolower $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} {
set question "Copy anyway? Y|N"
set answer [punk::lib::askuser $question]
if {[string tolower $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