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.
 
 
 
 
 
 

542 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::module 0.1.0
# Meta platform tcl
# Meta license BSD
# @@ Meta End
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements
##e.g package require frobz
package require punk::repo
# depends on punk,punk::mix::base,punk::mix::cli
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
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_low_to_high [templates_dict {*}$args]
#convert to screen order - with higher priority at the top
set tdict [dict create]
foreach k [lreverse [dict keys $tdict_low_to_high]] {
dict set tdict $k [dict get $tdict_low_to_high $k]
}
package require overtype
package require textblock
#set pathinfolist [dict values $tdict]
#set paths [lsearch -all -inline -index 1 -subindices $pathinfolist *] ;#relies on first key of templates_dict being path
set names [dict keys $tdict]
set paths [list]
set pathtypes [list]
dict for {nm tinfo} $tdict {
lappend paths [dict get $tinfo path]
lappend pathtypes [dict get $tinfo sourceinfo pathtype]
}
set title(path) "Path"
set widest(path) [tcl::mathfunc::max {*}[lmap v [concat [list $title(path)] $paths] {punk::strlen $v}]]
set col(path) [string repeat " " $widest(path)]
set title(pathtype) "[a+ green]Path Type[a]"
set widest(pathtype) [tcl::mathfunc::max {*}[lmap v [concat [list $title(pathtype)] $pathtypes] {string length $v}]]
set col(pathtype) [string repeat " " $widest(pathtype)]
set title(name) "Template Name"
set widest(name) [tcl::mathfunc::max {*}[lmap v [concat [list $title(name)] $names] {string length $v}]]
set col(name) [string repeat " " $widest(name)]
set tablewidth [expr {$widest(name) + 1 + $widest(pathtype) + 1 + $widest(name)}]
set table ""
append table [string repeat - $tablewidth] \n
append table "[textblock::join -- [overtype::left $col(name) $title(name)] " " [overtype::left $col(pathtype) $title(pathtype)] " " [overtype::left $col(path) $title(path)]]" \n
append table [string repeat - $tablewidth] \n
foreach n $names pt $pathtypes p $paths {
append table "[overtype::left $col(name) $n] [overtype::left $col(pathtype) $pt] [overtype::left $col(path) $p]" \n
}
return $table
}
#return all module templates with repeated ones suffixed with .2 .3 etc
proc templates_dict {args} {
set argspec {
*proc -name templates_dict -help "Templates from module and project paths"
-startdir -default "" -help "Project folder used in addition to module paths"
-not -default "" -multiple 1
*values
globsearches -default * -multiple 1
}
set argd [punk::args::get_dict $argspec $args]
package require punk::cap
if {[punk::cap::capability_has_handler punk.templates]} {
set template_folder_dict [punk::cap::call_handler punk.templates get_itemdict_moduletemplates {*}$args]
} else {
put stderr "get_template_basefolders WARNING - no handler available for the 'punk.templates' capability - template providers will be unable to provide template locations"
}
}
proc new {args} {
set year [clock format [clock seconds] -format %Y]
set moduletypes [punk::mix::cli::lib::module_types]
# use \uFFFD because unicode replacement char should consistently render as 1 wide
set argspecs [subst {
-project -default \uFFFD
-version -default \uFFFD
-license -default <unspecified>
-template -default punk.module
-type -default \uFFFD -choices {$moduletypes}
-force -default 0 -type boolean
-quiet -default 0 -type boolean
*values -min 1 -max 1
module -type string
}]
set argd [punk::args::get_dict $argspecs $args]
lassign [dict values $argd] leaders opts values
set module [dict get $values module]
#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 or zip (modpod) 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 "\uFFFD"} {
set opt_version "0.1.0"
} else {
set opt_version $opt_version_supplied
if {![util::is_valid_tm_version $opt_version]} {
error "deck 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 "deck 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 "\uFFFD"} {
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 -errorprefix "punk::mix::commandset::module::new"
if {[regexp {[A-Z]} $module]} {
set msg "module names containing uppercase are not recommended (see tip 590).\n"
append msg "Please retype the module name '$module' to proceed.\n"
append msg "If you type it exactly as it was you will be allowed to proceed with uppercase anyway\n"
append msg "Retype it all in lowercase to use recommended naming"
set answer [util::askuser $msg]
if {[regexp {[A-Z]} $answer]} {
if {$answer eq $module} {
#ok - user insists
} else {
}
} else {
#user has resupplied modulename all as lowercase
if {$answer eq [string tolower $module]} {
set module $answer
} else {
#.. but it doesn't match original - require rerun
}
}
}
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
#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 [punk::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]
if {[regexp {.*[?*].*} $opt_template]} {
error "module.new -template does not support glob chars. Use an exact full name including version (and optionally .tm) - or use just the name without version or .tm, and the latest version will be selected"
}
set templates_dict [templates_dict] ;#keys are possibly prefixed with <vendor>. and/or suffixed with #2 #3 etc if there are collisions - the remaining unsuffixed being the one with highest preference
#todo - allow versionless name - pick latest which isn't suffixed with #2 etc
#if the user wants to exactly match an unversioned template, in the presence of versioned ones - they may need to include the trailing .tm
if {[dict exists $templates_dict $opt_template]} {
#exact long name (possibly including version)
#Note - an unversioned .tm template will be matched here - even though versioned templates of the same name may exist.
set templatefile [dict get $templates_dict $opt_template path]
set templatefile_info [dict get $templates_dict $opt_template sourceinfo]
} else {
#if it wasn't an exact match for opt_template - then opt_template now shouldn't contain a version (we have also ruled out glob chars * & ? above)
#(if it does - then we just won't find anything - which is fine)
#module file name could contain dots - but only one dash - if it is versioned
set matches [lsearch -all -inline [dict keys $templates_dict] $opt_template-*] ;#the key is of form vendor.modulename-version(#suffix) (version optional, suffix if lower precedence with same name was found)
#only .tm (or .TM .Tm .tM) files make it into the templates_dict - they are allowed to be unversioned though.
set key_version_list [list]
foreach m $matches {
#vendorname could contain dashes or dots - so easiest way to split out is to examine the stored vendor value in sourceinfo
set vendor [dict get $templates_dict $m sourceinfo vendor]
if {$vendor ne "_project"} {
#_project special case - not included in module names
set module $m
} else {
set module [string range [string length $vendor.] end]
}
lassign [punk::mix::cli::lib::split_modulename_version $m] _tailmname mversion
lappend key_version_list [list $m $mversion]
}
if {[llength $matches]} {
set highest_m ""
set highest_v ""
foreach kv $key_version_list {
if {$highest_v eq ""} {
set highest_m [lindex $kv 0]
set highest_v [lindex $kv 1]
} else {
if {[package vcompare $highest_v [lindex $kv 1]] == -1} {
set highest_m [lindex $kv 0]
set highest_v [lindex $kv 1]
}
}
}
set templatefile [dict get $templates_dict $highest_m path]
set templatefile_info [dict get $templates_dict $highest_m sourceinfo]
} else {
error "module.new unable to find template '$opt_template'. [dict size $templates_dict] Known templates. Use deck module.templates to display"
}
}
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 "\uFFFD"} {
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 opt_quiet [dict get $opts -quiet]
set opt_force [dict get $opts -force]
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---
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 moduletemplate [file join $projectname [punk::path::relative $projectdir $templatefile]] ;#if templatfile is on another volume - just $templatefile will be returned.
#moduletemplate should usually be a relative path - but could be absolute, or contain info about the relative locations of projectdir vs templatefile if template comes from another project or a module outside the project
#This path info may be undesired in the template output (%moduletemplate%)
#it is nevertheless useful information - and not the only way developer-machine/build-machine paths can leak
#for now the user has the option to override any templates and remove %moduletemplate% if it is a security/privacy concern
#Don't put literal %x% in the code for the commandset::module itself - to stop them being seen by layout scanner as replacable tokens
set tagnames [list moduletemplate $moduletemplate project $projectname pkg $modulename year $year license $opt_license version $infile_version]
set strmap [list]
foreach {tag val} $tagnames {
lappend strmap %$tag% $val
}
set template_filedata [string map $strmap $template_filedata]
set tmfile $modulefolder/${moduletail}-$infile_version.tm
set podfile $modulefolder/#modpod-$moduletail-$infile_version/$moduletail-$infile_version.tm
set has_tm [file exists $tmfile]
set has_pod [file exists $podfile]
if {$has_tm && $has_pos} {
#invalid configuration - bomb out
error "module.new error: Invalid target configuration found. module folder has both a .tm file $tmfile and a modpod file $podfile. Please delete one of them before trying again."
}
if {$opt_type eq "plain"} {
set modulefile $tmfile
} else {
set modulefile $podfile
}
if {$has_tm || $has_pod} {
if {!$opt_force} {
if {$has_tm} {
set errmsg "module.new error: module file $tmfile already exists - aborting"
} else {
set errmsg "module.new error: module file $podfile already exists - aborting"
}
if {[string match "*$magicversion*" $tmfile]} {
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
} else {
#review - prompt here vs caller?
#we are committed to overwriting/replacing if there was a pre-existing module of same version
if {$has_pod} {
file delete -force [file dirname $podfile]
} elseif {$has_tm} {
file delete -force $tmfile
}
}
}
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_tm_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
set existing_pod_versions [glob -nocomplain -dir $modulefolder -tails #modpod-$moduletail-*]
set existing_versions [concat $existing_tm_versions $existing_pod_versions]
if {[llength $existing_versions]} {
set name_version_pairs [list]
lappend name_version_pairs [list $moduletail $infile_version]
foreach existing $existing_versions {
lassign [punk::mix::cli::lib::split_modulename_version $existing] namepart version ;# .tm is stripped and ignored
if {[string match #modpod-* $namepart]} {
set namepart [string range $namepart 8 end]
}
lappend name_version_pairs [list $namepart $version]
}
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] *]"
}
}
if {!$opt_quiet} {
puts stdout "Creating $modulefile from template $moduletemplate"
}
file mkdir [file dirname $modulefile]
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 {
}
}
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Ready
package provide punk::mix::commandset::module [namespace eval punk::mix::commandset::module {
variable version
set version 0.1.0
}]
return