17 changed files with 7349 additions and 798 deletions
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
@ -0,0 +1,6 @@
|
||||
#!/bin/sh |
||||
# -*- tcl -*- \ |
||||
# 'build.tcl' name as required by kettle |
||||
# Can be run directly - but also using `deck Kettle ...` or `deck KettleShell ...`\ |
||||
exec ./kettle -f "$0" "${1+$@}" |
||||
kettle doc |
||||
@ -0,0 +1,995 @@
|
||||
# tcl |
||||
# |
||||
#make any tclkits and modules in src and place them and associated data files/scripts in the parent folder of src. |
||||
#e.g in 'bin' and 'modules' folders at same level as 'src' folder. |
||||
|
||||
set hashline "# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ###" |
||||
puts $hashline |
||||
puts " punkshell make script " |
||||
puts $hashline\n |
||||
namespace eval ::punkmake { |
||||
variable scriptfolder [file normalize [file dirname [info script]]] |
||||
variable foldername [file tail $scriptfolder] |
||||
variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list] |
||||
variable non_help_flags [list -k] |
||||
variable help_flags [list -help --help /?] |
||||
variable known_commands [list project get-project-info shell bootsupport] |
||||
} |
||||
if {"::try" ni [info commands ::try]} { |
||||
puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting" |
||||
exit 1 |
||||
} |
||||
|
||||
#------------------------------------------------------------------------------ |
||||
#Module loading from /src/bootsupport or src/*.vfs if script is within a .vfs folder |
||||
#------------------------------------------------------------------------------ |
||||
#If the there is a folder under the current directory /src/bootsupport/modules which contains .tm files |
||||
# - then it will attempt to preference these modules |
||||
# This allows a source update via 'fossil update' 'git pull' etc to pull in a minimal set of support modules for the make script |
||||
# and load these in preference to ones that may have been in the interp's tcl::tm::list or auto_path due to environment variables |
||||
set startdir [pwd] |
||||
if {[file exists [file join $startdir src bootsupport]]} { |
||||
set bootsupport_mod [file join $startdir src bootsupport modules] |
||||
set bootsupport_lib [file join $startdir src bootsupport lib] |
||||
} else { |
||||
set bootsupport_mod [file join $startdir bootsupport modules] |
||||
set bootsupport_lib [file join $startdir bootsupport lib] |
||||
} |
||||
if {[file exists $bootsupport_mod] || [file exists $bootsupport_lib]} { |
||||
|
||||
set original_tm_list [tcl::tm::list] |
||||
tcl::tm::remove {*}$original_tm_list |
||||
set original_auto_path $::auto_path |
||||
set ::auto_path [list $bootsupport_lib] |
||||
|
||||
set support_modules [glob -nocomplain -dir $bootsupport_mod -type f -tail *.tm] |
||||
set tcl_core_packages [list tcl::zlib zlib tcl::oo TclOO tcl::tommath tcl::zipfs Tcl Tk] ;#packages we |
||||
if {[llength $support_modules] || [llength [glob -nocomplain -dir $bootsupport_lib -tail *]]} { |
||||
#only forget all *unloaded* package names |
||||
foreach pkg [package names] { |
||||
if {$pkg in $tcl_core_packages} { |
||||
continue |
||||
} |
||||
if {![llength [package versions $pkg]]} { |
||||
#puts stderr "Got no versions for pkg $pkg" |
||||
continue |
||||
} |
||||
if {![string length [package provide $pkg]]} { |
||||
#no returned version indicates it wasn't loaded - so we can forget its index |
||||
package forget $pkg |
||||
} |
||||
} |
||||
tcl::tm::add $bootsupport_mod |
||||
} |
||||
|
||||
|
||||
if {[file exists [pwd]/modules]} { |
||||
tcl::tm::add [pwd]/modules |
||||
} |
||||
|
||||
#package require Thread |
||||
# - the full repl requires Threading and punk,shellfilter,shellrun to call and display properly. |
||||
|
||||
|
||||
# tm list already indexed - need 'package forget' to find modules based on current tcl::tm::list |
||||
#These are strong dependencies |
||||
package forget punk::mix |
||||
package require punk::mix |
||||
package forget punk::repo |
||||
package require punk::repo |
||||
package forget punkcheck |
||||
package require punkcheck |
||||
|
||||
|
||||
|
||||
#restore module paths and auto_path in addition to the bootsupport ones |
||||
set tm_list_now [tcl::tm::list] |
||||
foreach p $original_tm_list { |
||||
if {$p ni $tm_list_now} { |
||||
tcl::tm::add $p |
||||
} |
||||
} |
||||
set ::auto_path [list $bootsupport_lib {*}$original_auto_path] |
||||
#------------------------------------------------------------------------------ |
||||
} |
||||
|
||||
# ** *** *** *** *** *** *** *** *** *** *** *** |
||||
#*temporarily* hijack package command |
||||
# ** *** *** *** *** *** *** *** *** *** *** *** |
||||
try { |
||||
rename ::package ::punkmake::package_temp_aside |
||||
proc ::package {args} { |
||||
if {[lindex $args 0] eq "require"} { |
||||
lappend ::punkmake::pkg_requirements [lindex $args 1] |
||||
} |
||||
} |
||||
package require punk::mix |
||||
package require punk::repo |
||||
} finally { |
||||
catch {rename ::package ""} |
||||
catch {rename ::punkmake::package_temp_aside ::package} |
||||
} |
||||
# ** *** *** *** *** *** *** *** *** *** *** *** |
||||
foreach pkg $::punkmake::pkg_requirements { |
||||
if {[catch {package require $pkg} errM]} { |
||||
puts stderr "missing pkg: $pkg" |
||||
lappend ::punkmake::pkg_missing $pkg |
||||
} else { |
||||
lappend ::punkmake::pkg_loaded $pkg |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
proc punkmake_gethelp {args} { |
||||
set scriptname [file tail [info script]] |
||||
append h "Usage:" \n |
||||
append h "" \n |
||||
append h " $scriptname -help or $scriptname --help or $scriptname /? or just $scriptname" \n |
||||
append h " - This help." \n \n |
||||
append h " $scriptname project ?-k?" \n |
||||
append h " - this is the literal word project - and confirms you want to run the project build" \n |
||||
append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n \n |
||||
append h " $scriptname bootsupport" \n |
||||
append h " - update the src/bootsupport modules as well as the mixtemplates/layouts/<layoutname>/src/bootsupport modules if the folder exists" \n \n |
||||
append h " $scriptname get-project-info" \n |
||||
append h " - show the name and base folder of the project to be built" \n |
||||
append h "" \n |
||||
if {[llength $::punkmake::pkg_missing]} { |
||||
append h "* ** NOTE ** ***" \n |
||||
append h " punkmake has detected that the following packages could not be loaded:" \n |
||||
append h " " [join $::punkmake::pkg_missing "\n "] \n |
||||
append h "* ** *** *** ***" \n |
||||
append h " These packages are required for punk make to function" \n \n |
||||
append h "* ** *** *** ***" \n\n |
||||
append h "Successfully Loaded packages:" \n |
||||
append h " " [join $::punkmake::pkg_loaded "\n "] \n |
||||
} |
||||
return $h |
||||
} |
||||
set scriptargs $::argv |
||||
set do_help 0 |
||||
if {![llength $scriptargs]} { |
||||
set do_help 1 |
||||
} else { |
||||
foreach h $::punkmake::help_flags { |
||||
if {[lsearch $scriptargs $h] >= 0} { |
||||
set do_help 1 |
||||
break |
||||
} |
||||
} |
||||
} |
||||
set commands_found [list] |
||||
foreach a $scriptargs { |
||||
if {![string match -* $a]} { |
||||
lappend commands_found $a |
||||
} else { |
||||
if {$a ni $::punkmake::non_help_flags} { |
||||
set do_help 1 |
||||
} |
||||
} |
||||
} |
||||
if {[llength $commands_found] != 1 } { |
||||
set do_help 1 |
||||
} elseif {[lindex $commands_found 0] ni $::punkmake::known_commands} { |
||||
puts stderr "Unknown command: [lindex $commands_found 0]\n\n" |
||||
set do_help 1 |
||||
} |
||||
if {$do_help} { |
||||
puts stderr [punkmake_gethelp] |
||||
exit 0 |
||||
} |
||||
|
||||
set ::punkmake::command [lindex $commands_found 0] |
||||
|
||||
|
||||
if {[lsearch $::argv -k] >= 0} { |
||||
set forcekill 1 |
||||
} else { |
||||
set forcekill 0 |
||||
} |
||||
#puts stdout "::argv $::argv" |
||||
# ---------------------------------------- |
||||
|
||||
set scriptfolder $::punkmake::scriptfolder |
||||
|
||||
|
||||
|
||||
#first look for a project root (something under fossil or git revision control AND matches punk project folder structure) |
||||
#If that fails - just look for a 'project shaped folder' ie meets minimum requirements of /src /src/lib /src/modules /lib /modules |
||||
if {![string length [set projectroot [punk::repo::find_project $scriptfolder]]]} { |
||||
if {![string length [set projectroot [punk::repo::find_candidate $scriptfolder]]]} { |
||||
puts stderr "punkmake script unable to determine an approprite project root at or above the path '$scriptfolder' ensure the make script is within a project folder structure" |
||||
puts stderr " -aborted- " |
||||
exit 2 |
||||
#todo? |
||||
#ask user for a project name and create basic structure? |
||||
#call punk::mix::cli::new $projectname on parent folder? |
||||
} else { |
||||
puts stderr "WARNING punkmake script operating in project space that is not under version control" |
||||
} |
||||
} else { |
||||
|
||||
} |
||||
|
||||
set sourcefolder $projectroot/src |
||||
|
||||
if {$::punkmake::command eq "get-project-info"} { |
||||
puts stdout "- -- --- --- --- --- --- --- --- --- ---" |
||||
puts stdout "- -- get-project-info -- -" |
||||
puts stdout "- -- --- --- --- --- --- --- --- --- ---" |
||||
puts stdout "- projectroot : $projectroot" |
||||
if {[punk::repo::find_fossil $scriptfolder] eq $projectroot} { |
||||
set vc "fossil" |
||||
set rev [punk::repo::fossil_revision $scriptfolder] |
||||
set rem [punk::repo::fossil_remote $scriptfolder] |
||||
} elseif {[punk::repo::find_git $scriptfolder] eq $projectroot} { |
||||
set vc "git" |
||||
set rev [punk::repo::git_revision $scriptfolder] |
||||
set rem [punk::repo::git_remote $scriptfolder] |
||||
} else { |
||||
set vc " - none found -" |
||||
set rev "n/a" |
||||
set remotes "n/a" |
||||
} |
||||
puts stdout "- version control : $vc" |
||||
puts stdout "- revision : $rev" |
||||
puts stdout "- remote : $rem" |
||||
puts stdout "- -- --- --- --- --- --- --- --- --- ---" |
||||
|
||||
exit 0 |
||||
} |
||||
|
||||
if {$::punkmake::command eq "shell"} { |
||||
package require punk |
||||
package require punk::repl |
||||
puts stderr "make shell not fully implemented - dropping into ordinary punk shell" |
||||
repl::start stdin |
||||
|
||||
exit 1 |
||||
} |
||||
|
||||
if {$::punkmake::command eq "bootsupport"} { |
||||
puts "projectroot: $projectroot" |
||||
puts "script: [info script]" |
||||
#puts "-- [tcl::tm::list] --" |
||||
puts stdout "Updating bootsupport from local files" |
||||
|
||||
proc bootsupport_localupdate {projectroot} { |
||||
set bootsupport_modules [list] |
||||
set bootsupport_module_folders [list] |
||||
set bootsupport_config $projectroot/src/bootsupport/include_modules.config ;# |
||||
if {[file exists $bootsupport_config]} { |
||||
set targetroot $projectroot/src/bootsupport/modules |
||||
source $bootsupport_config ;#populate $bootsupport_modules with project-specific list |
||||
if {![llength $bootsupport_modules]} { |
||||
puts stderr "No local bootsupport modules configured for updating" |
||||
} else { |
||||
|
||||
if {[catch { |
||||
#---------- |
||||
set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] |
||||
$boot_installer set_source_target $projectroot $projectroot/src/bootsupport |
||||
set boot_event [$boot_installer start_event {-make_step bootsupport}] |
||||
#---------- |
||||
} errM]} { |
||||
puts stderr "Unable to use punkcheck for bootsupport error: $errM" |
||||
set boot_event "" |
||||
} |
||||
|
||||
foreach {relpath module} $bootsupport_modules { |
||||
set module [string trim $module :] |
||||
set module_subpath [string map [list :: /] [namespace qualifiers $module]] |
||||
set srclocation [file join $projectroot $relpath $module_subpath] |
||||
#puts stdout "$relpath $module $module_subpath $srclocation" |
||||
set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*] |
||||
#lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 |
||||
if {![llength $pkgmatches]} { |
||||
puts stderr "Missing source for bootsupport module $module - not found in $srclocation" |
||||
continue |
||||
} |
||||
set latestfile [lindex $pkgmatches 0] |
||||
set latestver [lindex [split [file rootname $latestfile] -] 1] |
||||
foreach m $pkgmatches { |
||||
lassign [split [file rootname $m] -] _pkg ver |
||||
#puts "comparing $ver vs $latestver" |
||||
if {[package vcompare $ver $latestver] == 1} { |
||||
set latestver $ver |
||||
set latestfile $m |
||||
} |
||||
} |
||||
set srcfile [file join $srclocation $latestfile] |
||||
set tgtfile [file join $targetroot $module_subpath $latestfile] |
||||
if {$boot_event ne ""} { |
||||
#---------- |
||||
$boot_event targetset_init INSTALL $tgtfile |
||||
$boot_event targetset_addsource $srcfile |
||||
#---------- |
||||
if {\ |
||||
[llength [dict get [$boot_event targetset_source_changes] changed]]\ |
||||
|| [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ |
||||
} { |
||||
file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists |
||||
$boot_event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts "BOOTSUPPORT update: $srcfile -> $tgtfile" |
||||
if {[catch { |
||||
file copy -force $srcfile $tgtfile |
||||
} errM]} { |
||||
$boot_event targetset_end FAILED |
||||
} else { |
||||
$boot_event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts -nonewline stderr "." |
||||
$boot_event targetset_end SKIPPED |
||||
} |
||||
$boot_event end |
||||
} else { |
||||
file copy -force $srcfile $tgtfile |
||||
} |
||||
} |
||||
if {$boot_event ne ""} { |
||||
puts \n |
||||
$boot_event destroy |
||||
$boot_installer destroy |
||||
} |
||||
} |
||||
|
||||
if {[llength $bootsupport_module_folders] % 2 != 0} { |
||||
#todo - change include_modules.config structure to be line based? we have no way of verifying paired entries because we accept a flat list |
||||
puts stderr "WARNING - Skipping bootsupport_module_folders - list should be a list of base subpath pairs" |
||||
} else { |
||||
foreach {base subfolder} $bootsupport_module_folders { |
||||
#user should be careful not to include recursive/cyclic structures e.g module that has a folder which contains other modules from this project |
||||
#It will probably work somewhat.. but may make updates confusing.. or worse - start making deeper and deeper copies |
||||
set src [file join $projectroot $base $subfolder] |
||||
if {![file isdirectory $src]} { |
||||
puts stderr "bootsupport folder not found: $src" |
||||
continue |
||||
} |
||||
|
||||
#subfolder is the common relative path - so don't include the base in the target path |
||||
set tgt [file join $targetroot $subfolder] |
||||
file mkdir $tgt |
||||
|
||||
puts stdout "BOOTSUPPORT non_tm_files $src - copying to $tgt (if source file changed)" |
||||
set overwrite "installedsourcechanged-targets" |
||||
set resultdict [punkcheck::install_non_tm_files $src $tgt -installer make.tcl -overwrite $overwrite -punkcheck_folder $projectroot/src/bootsupport] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
} |
||||
} |
||||
|
||||
} |
||||
} |
||||
|
||||
bootsupport_localupdate $projectroot |
||||
|
||||
#/modules/punk/mix/templates/layouts only applies if the project has it's own copy of the punk/mix modules. Generally this should only apply to the punkshell project itself. |
||||
set layout_bases [list\ |
||||
$sourcefolder/project_layouts/custom/_project\ |
||||
] |
||||
foreach project_layout_base $layout_bases { |
||||
if {[file exists $project_layout_base]} { |
||||
set project_layouts [glob -nocomplain -dir $project_layout_base -type d -tail *] |
||||
foreach layoutname $project_layouts { |
||||
#don't auto-create src/bootsupport - just update it if it exists |
||||
if {[file exists [file join $project_layout_base $layoutname/src/bootsupport]]} { |
||||
set antipaths [list\ |
||||
README.md\ |
||||
] |
||||
set sourcemodules $projectroot/src/bootsupport/modules |
||||
set targetroot [file join $project_layout_base $layoutname/src/bootsupport/modules] |
||||
file mkdir $targetroot |
||||
|
||||
puts stdout "BOOTSUPPORT layouts/$layoutname: copying from $sourcemodules to $targetroot (if source file changed)" |
||||
set resultdict [punkcheck::install $sourcemodules $targetroot -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
flush stdout |
||||
} |
||||
} |
||||
} else { |
||||
puts stderr "No layout base at $project_layout_base" |
||||
} |
||||
} |
||||
puts stdout " bootsupport done " |
||||
flush stderr |
||||
flush stdout |
||||
#punk86 can hang if calling make.tcl via 'run' without this 'after' delay. punk87 unaffected. cause unknown. |
||||
#after 500 |
||||
::exit 0 |
||||
} |
||||
|
||||
|
||||
|
||||
if {$::punkmake::command ne "project"} { |
||||
puts stderr "Command $::punkmake::command not implemented - aborting." |
||||
flush stderr |
||||
after 100 |
||||
exit 1 |
||||
} |
||||
|
||||
|
||||
|
||||
#only a single consolidated /modules folder used for target |
||||
set target_modules_base $projectroot/modules |
||||
file mkdir $target_modules_base |
||||
|
||||
#external libs and modules first - and any supporting files - no 'building' required |
||||
if {[file exists $sourcefolder/vendorlib]} { |
||||
#exclude README.md from source folder - but only the root one |
||||
#-antiglob_paths takes relative patterns e.g |
||||
# */test.txt will only match test.txt exactly one level deep. |
||||
# */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. |
||||
# **/test.txt will match at any level below the root (but not in the root) |
||||
set antipaths [list\ |
||||
README.md\ |
||||
] |
||||
|
||||
puts stdout "VENDORLIB: copying from $sourcefolder/vendorlib to $projectroot/lib (if source file changed)" |
||||
set resultdict [punkcheck::install $sourcefolder/vendorlib $projectroot/lib -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
|
||||
} else { |
||||
puts stderr "VENDORLIB: No src/vendorlib folder found." |
||||
} |
||||
|
||||
if {[file exists $sourcefolder/vendormodules]} { |
||||
#install .tm *and other files* |
||||
puts stdout "VENDORMODULES: copying from $sourcefolder/vendormodules to $target_modules_base (if source file changed)" |
||||
set resultdict [punkcheck::install $sourcefolder/vendormodules $target_modules_base -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md}] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
} else { |
||||
puts stderr "VENDORMODULES: No src/vendormodules folder found." |
||||
} |
||||
|
||||
######################################################## |
||||
#templates |
||||
#e.g The default project layout is mainly folder structure and readme files - but has some scripts developed under the main src that we want to sync |
||||
#src to src/modules/punk/mix/templates/layouts/project/src |
||||
|
||||
set old_layout_update_list [list\ |
||||
[list project $sourcefolder/modules/punk/mix/templates]\ |
||||
[list basic $sourcefolder/mixtemplates]\ |
||||
] |
||||
set layout_bases [list\ |
||||
$sourcefolder/project_layouts/custom/_project\ |
||||
] |
||||
|
||||
foreach layoutbase $layout_bases { |
||||
if {![file exists $layoutbase]} { |
||||
continue |
||||
} |
||||
set project_layouts [glob -nocomplain -dir $layoutbase -type d -tail *] |
||||
foreach layoutname $project_layouts { |
||||
set config [dict create\ |
||||
-make-step sync_layouts\ |
||||
] |
||||
#---------- |
||||
set tpl_installer [punkcheck::installtrack new make.tcl $layoutbase/.punkcheck] |
||||
$tpl_installer set_source_target $sourcefolder $layoutbase |
||||
set tpl_event [$tpl_installer start_event $config] |
||||
#---------- |
||||
set pairs [list] |
||||
set pairs [list\ |
||||
[list $sourcefolder/build.tcl $layoutbase/$layoutname/src/build.tcl]\ |
||||
[list $sourcefolder/make.tcl $layoutbase/$layoutname/src/make.tcl]\ |
||||
] |
||||
|
||||
foreach filepair $pairs { |
||||
lassign $filepair srcfile tgtfile |
||||
|
||||
file mkdir [file dirname $tgtfile] |
||||
#---------- |
||||
$tpl_event targetset_init INSTALL $tgtfile |
||||
$tpl_event targetset_addsource $srcfile |
||||
#---------- |
||||
if {\ |
||||
[llength [dict get [$tpl_event targetset_source_changes] changed]]\ |
||||
|| [llength [$tpl_event get_targets_exist]] < [llength [$tpl_event get_targets]]\ |
||||
} { |
||||
$tpl_event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "PROJECT LAYOUT update - layoutname: $layoutname Copying from $srcfile to $tgtfile" |
||||
if {[catch { |
||||
file copy -force $srcfile $tgtfile |
||||
} errM]} { |
||||
$tpl_event targetset_end FAILED -note "layout:$layoutname copy failed with err: $errM" |
||||
} else { |
||||
$tpl_event targetset_end OK -note "layout:$layoutname" |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "." |
||||
$tpl_event targetset_end SKIPPED |
||||
} |
||||
} |
||||
|
||||
$tpl_event end |
||||
$tpl_event destroy |
||||
$tpl_installer destroy |
||||
} |
||||
} |
||||
######################################################## |
||||
|
||||
|
||||
#default source module folder is at projectroot/src/modules |
||||
#There may be multiple other src module folders at same level (e.g folder not being other special-purpose folder and not matching name vendor* that contains at least one .tm file in its root) |
||||
set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] |
||||
foreach src_module_dir $source_module_folderlist { |
||||
puts stderr "Processing source module dir: $src_module_dir" |
||||
set dirtail [file tail $src_module_dir] |
||||
#modules and associated files belonging to this package/app |
||||
set copied [punk::mix::cli::lib::build_modules_from_source_to_base $src_module_dir $target_modules_base -glob *.tm] ;#will only accept a glob ending in .tm |
||||
#set copied [list] |
||||
puts stdout "--------------------------" |
||||
puts stderr "Copied [llength $copied] tm modules from src/$dirtail to $target_modules_base " |
||||
puts stdout "--------------------------" |
||||
|
||||
set overwrite "installedsourcechanged-targets" |
||||
#set overwrite "ALL-TARGETS" |
||||
puts stdout "MODULEFOLDER non_tm_files $src_module_dir - copying to $target_modules_base (if source file changed)" |
||||
set resultdict [punkcheck::install_non_tm_files $src_module_dir $target_modules_base -installer make.tcl -overwrite $overwrite -antiglob_paths {README.md}] |
||||
puts stdout [punkcheck::summarize_install_resultdict $resultdict] |
||||
} |
||||
|
||||
set installername "make.tcl" |
||||
|
||||
# ---------------------------------------- |
||||
if {[punk::repo::is_fossil_root $projectroot]} { |
||||
set config [dict create\ |
||||
-make-step configure_fossil\ |
||||
] |
||||
#---------- |
||||
set installer [punkcheck::installtrack new $installername $projectroot/.punkcheck] |
||||
$installer set_source_target $projectroot $projectroot |
||||
|
||||
set event [$installer start_event $config] |
||||
$event targetset_init VIRTUAL fossil_settings_mainmenu ;#VIRTUAL - since there is no actual target file |
||||
set menufile $projectroot/.fossil-custom/mainmenu |
||||
$event targetset_addsource $menufile |
||||
#---------- |
||||
|
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
} { |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "Configuring fossil setting: mainmenu from: $menufile" |
||||
if {[catch { |
||||
set fd [open $menufile r] |
||||
fconfigure $fd -translation binary |
||||
set data [read $fd] |
||||
close $fd |
||||
exec fossil settings mainmenu $data |
||||
} errM]} { |
||||
$event targetset_end FAILED -note "fossil update failed: $errM" |
||||
} else { |
||||
$event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "." |
||||
$event targetset_end SKIPPED |
||||
} |
||||
$event end |
||||
$event destroy |
||||
$installer destroy |
||||
} |
||||
|
||||
set buildfolder [punk::mix::cli::lib::get_build_workdir $sourcefolder] |
||||
if {$buildfolder ne "$sourcefolder/_build"} { |
||||
puts stderr "$sourcefolder/_build doesn't match the project buildfolder $buildfolder - check project filestructure" |
||||
puts stdout " -aborted- " |
||||
exit 2 |
||||
} |
||||
|
||||
|
||||
#find runtimes |
||||
set rtfolder $sourcefolder/runtime |
||||
set runtimes [glob -nocomplain -dir $rtfolder -types {f x} -tail *] |
||||
if {![llength $runtimes]} { |
||||
puts stderr "No executable runtimes found in $rtfolder - unable to build any .vfs folders into executables." |
||||
puts stderr "Add runtimes to $sourcefolder/runtime if required" |
||||
exit 0 |
||||
} |
||||
|
||||
if {[catch {exec sdx help} errM]} { |
||||
puts stderr "FAILED to find usable sdx command - check that sdx executable is on path" |
||||
puts stderr "err: $errM" |
||||
exit 1 |
||||
} |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- |
||||
#load mapvfs.config file (if any) in runtime folder to map runtimes to vfs folders. |
||||
#build a dict keyed on runtime executable name. |
||||
#If no mapfile (or no mapfile entry for that runtime) - the runtime will be paired with a matching .vfs folder in src folder. e.g punk.exe to src/punk.vfs |
||||
#If vfs folders or runtime executables which are explicitly listed in the mapfile don't exist - warn on stderr - but continue. if such nonexistants found; prompt user for whether to continue or abort. |
||||
set mapfile $rtfolder/mapvfs.config |
||||
set runtime_vfs_map [dict create] |
||||
set vfs_runtime_map [dict create] |
||||
if {[file exists $mapfile]} { |
||||
set fdmap [open $mapfile r] |
||||
fconfigure $fdmap -translation binary |
||||
set mapdata [read $fdmap] |
||||
close $fdmap |
||||
set mapdata [string map [list \r\n \n] $mapdata] |
||||
set missing [list] |
||||
foreach ln [split $mapdata \n] { |
||||
set ln [string trim $ln] |
||||
if {$ln eq "" || [string match #* $ln]} { |
||||
continue |
||||
} |
||||
set vfspaths [lassign $ln runtime] |
||||
if {[string match *.exe $runtime]} { |
||||
#.exe is superfluous but allowed |
||||
#drop windows .exe suffix so same config can work cross platform - extension will be re-added if necessary later |
||||
set runtime [string range $runtime 0 end-4] |
||||
} |
||||
if {$runtime ne "-"} { |
||||
set runtime_test $runtime |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
set runtime_test $runtime.exe |
||||
} |
||||
if {![file exists [file join $rtfolder $runtime_test]]} { |
||||
puts stderr "WARNING: Missing runtime file $rtfolder/$runtime_test (line in mapvfs.config: $ln)" |
||||
lappend missing $runtime |
||||
} |
||||
} |
||||
foreach vfs $vfspaths { |
||||
if {![file isdirectory [file join $sourcefolder $vfs]]} { |
||||
puts stderr "WARNNING: Missing vfs folder [file join $sourcefolder $vfs] specified in mapvfs.config for runtime $runtime" |
||||
lappend missing $vfs |
||||
} |
||||
dict lappend vfs_runtime_map $vfs $runtime |
||||
} |
||||
if {[dict exists $runtime_vfs_map $runtime]} { |
||||
puts stderr "CONFIG FILE ERROR. runtime: $runtime was specified more than once in $mapfile." |
||||
exit 3 |
||||
} |
||||
dict set runtime_vfs_map $runtime $vfspaths |
||||
} |
||||
if {[llength $missing]} { |
||||
puts stderr "WARNING [llength $missing] missing items from $mapfile. (TODO - prompt user to continue/abort)" |
||||
foreach m $missing { |
||||
puts stderr " $m" |
||||
} |
||||
puts stderr "continuing..." |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- --- --- |
||||
|
||||
set vfs_folders [glob -nocomplain -dir $sourcefolder -types d -tail *.vfs] |
||||
#add any extra .vfs folders found in runtime/mapvfs.config file (e.g myotherruntimes/something.vfs) |
||||
dict for {vfs -} $vfs_runtime_map { |
||||
if {$vfs ni $vfs_folders} { |
||||
lappend vfs_folders $vfs |
||||
} |
||||
} |
||||
if {![llength $vfs_folders]} { |
||||
puts stdout "No .vfs folders found at '$sourcefolder' - no kits to build" |
||||
puts stdout " -done- " |
||||
exit 0 |
||||
} |
||||
|
||||
set vfs_folder_changes [dict create] ;#cache whether each .vfs folder has changes so we don't re-run tests if building from same .vfs with multiple runtime executables |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
#set runtimefile [lindex $runtimes 0] |
||||
foreach runtimefile $runtimes { |
||||
#runtimefile e.g tclkit86bi.exe on windows tclkit86bi on other platforms |
||||
|
||||
#sdx *may* be pointed to use the runtime we use to build the kit, or the user may manually use this runtime if they don't have tclsh |
||||
#sdx will complain if the same runtime is used for the shell as is used in the -runtime argument - so we make a copy (REVIEW) |
||||
#if {![file exists $buildfolder/buildruntime.exe]} { |
||||
# file copy $rtfolder/$runtimefile $buildfolder/buildruntime.exe |
||||
#} |
||||
|
||||
set basedir $buildfolder |
||||
set config [dict create\ |
||||
-make-step copy_runtime\ |
||||
] |
||||
#---------- |
||||
set installer [punkcheck::installtrack new $installername $basedir/.punkcheck] |
||||
$installer set_source_target $rtfolder $buildfolder |
||||
set event [$installer start_event $config] |
||||
$event targetset_init INSTALL $buildfolder/build_$runtimefile |
||||
$event targetset_addsource $rtfolder/$runtimefile |
||||
#---------- |
||||
|
||||
#set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] |
||||
if {\ |
||||
[llength [dict get [$event targetset_source_changes] changed]]\ |
||||
|| [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ |
||||
} { |
||||
$event targetset_started |
||||
# -- --- --- --- --- --- |
||||
puts stdout "Copying runtime from $rtfolder/$runtimefile to $buildfolder/build_$runtimefile" |
||||
if {[catch { |
||||
file copy -force $rtfolder/$runtimefile $buildfolder/build_$runtimefile |
||||
} errM]} { |
||||
$event targetset_end FAILED |
||||
} else { |
||||
$event targetset_end OK |
||||
} |
||||
# -- --- --- --- --- --- |
||||
} else { |
||||
puts stderr "." |
||||
$event targetset_end SKIPPED |
||||
} |
||||
$event end |
||||
|
||||
} |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
|
||||
# |
||||
# loop over vfs_folders and for each one, loop over configured (or matching) runtimes - build with sdx if source .vfs or source runtime exe has changed. |
||||
# we are using punkcheck to install result to buildfolder so we create a .punkcheck file at the target folder to store metadata. |
||||
# punkcheck allows us to not rely purely on timestamps (which may be unreliable) |
||||
# |
||||
set startdir [pwd] |
||||
puts stdout "Found [llength $vfs_folders] .vfs folders - building executable for each..." |
||||
cd [file dirname $buildfolder] |
||||
#root folder mtime is insufficient for change detection. Tree mtime of folders only is a barely passable mechanism for vfs change detection in some circumstances - e.g if files added/removed but never edited in place |
||||
#a hash of full tree file & dir mtime may be more reasonable - but it remains to be seen if just tar & checksum is any/much slower. |
||||
#Simply rebuilding all the time may be close the speed of detecting change anyway - and almost certainly much faster when there is a change. |
||||
#Using first mtime encountered that is later than target is another option - but likely to be highly variable in speed. Last file in the tree could happen to be the latest, and this mechanism doesn't handle build on reversion to older source. |
||||
set exe_names_seen [list] |
||||
foreach vfs $vfs_folders { |
||||
|
||||
set vfsname [file rootname $vfs] |
||||
puts stdout " Processing vfs $sourcefolder/$vfs" |
||||
puts stdout " ------------------------------------" |
||||
set skipped_vfs_build 0 |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
set basedir $buildfolder |
||||
set config [dict create\ |
||||
-make-step build_vfs\ |
||||
] |
||||
|
||||
set runtimes [list] |
||||
if {[dict exists $vfs_runtime_map $vfs]} { |
||||
set runtimes [dict get $vfs_runtime_map $vfs] ;#map dict is unsuffixed (.exe stripped or was not present) |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
set runtimes_raw $runtimes |
||||
set runtimes [list] |
||||
foreach rt $runtimes_raw { |
||||
if {![string match *.exe $rt] && $rt ne "-"} { |
||||
set rt $rt.exe |
||||
} |
||||
lappend runtimes $rt |
||||
} |
||||
} |
||||
} else { |
||||
#only match this vfs to a correspondingly named runtime if there was no explicit entry for that runtime |
||||
set matchrt [file rootname [file tail $vfs]] ;#e.g project.vfs -> project |
||||
if {![dict exists $runtime_vfs_map $matchrt]} { |
||||
if {"windows" eq $::tcl_platform(platform)} { |
||||
if {[file exists $rtfolder/$matchrt.exe]} { |
||||
lappend runtimes $matchrt.exe |
||||
} |
||||
} else { |
||||
lappend runtimes $matchrt |
||||
} |
||||
} |
||||
} |
||||
#assertion $runtimes is a list of executable names suffixed with .exe if on windows - whether or not specified with .exe in the mapvfs.config |
||||
|
||||
|
||||
#todo - non kit based - zipkit? |
||||
# $runtimes may now include a dash entry "-" (from mapvfs.config file) |
||||
foreach rtname $runtimes { |
||||
#rtname of "-" indicates build a kit without a runtime |
||||
|
||||
#first configured runtime will be the one to use the same name as .vfs folder for output executable. Additional runtimes on this .vfs will need to suffix the runtime name to disambiguate. |
||||
#review: This mechanism may not be great for multiplatform builds ? We may be better off consistently combining vfsname and rtname and letting a later platform-specific step choose ones to install in bin with simpler names. |
||||
if {$rtname eq "-"} { |
||||
set targetkit $vfsname.kit |
||||
} else { |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
set targetkit ${vfsname}.exe |
||||
} else { |
||||
set targetkit $vfsname |
||||
} |
||||
if {$targetkit in $exe_names_seen} { |
||||
#more than one runtime for this .vfs |
||||
set targetkit ${vfsname}_$rtname |
||||
} |
||||
} |
||||
lappend exe_names_seen $targetkit |
||||
# -- ---------- |
||||
set vfs_installer [punkcheck::installtrack new $installername $basedir/.punkcheck] |
||||
$vfs_installer set_source_target $sourcefolder $buildfolder |
||||
set vfs_event [$vfs_installer start_event {-make-step build_vfs}] |
||||
$vfs_event targetset_init INSTALL $buildfolder/$targetkit |
||||
$vfs_event targetset_addsource $sourcefolder/$vfs |
||||
if {$rtname ne "-"} { |
||||
$vfs_event targetset_addsource $buildfolder/build_$rtname |
||||
} |
||||
# -- ---------- |
||||
|
||||
set changed_unchanged [$vfs_event targetset_source_changes] |
||||
|
||||
if {[llength [dict get $changed_unchanged changed]] || [llength [$vfs_event get_targets_exist]] < [llength [$vfs_event get_targets]]} { |
||||
#source .vfs folder has changes |
||||
$vfs_event targetset_started |
||||
# -- --- --- --- --- --- |
||||
|
||||
#use |
||||
if {[file exists $buildfolder/$vfsname.new]} { |
||||
puts stderr "deleting existing $buildfolder/$vfsname.new" |
||||
file delete $buildfolder/$vfsname.new |
||||
} |
||||
|
||||
puts stdout "building $vfsname with sdx.. vfsdir:$vfs cwd: [pwd]" |
||||
|
||||
|
||||
if {[catch { |
||||
if {$rtname ne "-"} { |
||||
exec sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -runtime $buildfolder/build_$rtname -verbose |
||||
} else { |
||||
exec sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -verbose |
||||
} |
||||
} result]} { |
||||
if {$rtname ne "-"} { |
||||
puts stderr "sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -runtime $buildfolder/build_$rtname -verbose failed with msg: $result" |
||||
} else { |
||||
puts stderr "sdx wrap $buildfolder/$vfsname.new -vfs $sourcefolder/$vfs -verbose failed with msg: $result" |
||||
} |
||||
} else { |
||||
puts stdout "ok - finished sdx" |
||||
set separator [string repeat = 40] |
||||
puts stdout $separator |
||||
puts stdout $result |
||||
puts stdout $separator |
||||
} |
||||
|
||||
if {![file exists $buildfolder/$vfsname.new]} { |
||||
puts stderr "|err> make.tcl build didn't seem to produce output at $sourcefolder/_build/$vfsname.new" |
||||
$vfs_event targetset_end FAILED |
||||
exit 2 |
||||
} |
||||
|
||||
# -- --- --- |
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
set pscmd "tasklist" |
||||
} else { |
||||
set pscmd "ps" |
||||
} |
||||
|
||||
#killing process doesn't apply to .kit build |
||||
if {$rtname ne "-"} { |
||||
if {![catch { |
||||
exec $pscmd | grep $vfsname |
||||
} still_running]} { |
||||
|
||||
puts stdout "found $vfsname instances still running\n" |
||||
set count_killed 0 |
||||
foreach ln [split $still_running \n] { |
||||
puts stdout " $ln" |
||||
|
||||
if {$::tcl_platform(platform) eq "windows"} { |
||||
set pid [lindex $ln 1] |
||||
if {$forcekill} { |
||||
set killcmd [list taskkill /F /PID $pid] |
||||
} else { |
||||
set killcmd [list taskkill /PID $pid] |
||||
} |
||||
} else { |
||||
set pid [lindex $ln 0] |
||||
#review! |
||||
if {$forcekill} { |
||||
set killcmd [list kill -9 $pid] |
||||
} else { |
||||
set killcmd [list kill $pid] |
||||
} |
||||
} |
||||
puts stdout " pid: $pid (attempting to kill now using '$killcmd')" |
||||
if {[catch { |
||||
exec {*}$killcmd |
||||
} errMsg]} { |
||||
puts stderr "$killcmd returned an error:" |
||||
puts stderr $errMsg |
||||
if {!$forcekill} { |
||||
puts stderr "(try '[info script] -k' option to force kill)" |
||||
} |
||||
#avoid exiting if the kill failure was because the task has already exited |
||||
#review - *no running instance* works with windows taskkill - "*No such process*" works with kill -9 on FreeBSD and linux - other platforms? |
||||
if {![string match "*no running instance*" $errMsg] && ![string match "*No such process*" $errMsg]} { |
||||
exit 4 |
||||
} |
||||
} else { |
||||
puts stderr "$killcmd ran without error" |
||||
incr count_killed |
||||
} |
||||
} |
||||
if {$count_killed > 0} { |
||||
puts stderr "\nKilled $count_killed processes. Waiting a short time before attempting to delete executable" |
||||
after 1000 |
||||
} |
||||
} else { |
||||
puts stderr "Ok.. no running '$vfsname' processes found" |
||||
} |
||||
} |
||||
|
||||
if {[file exists $buildfolder/$targetkit]} { |
||||
puts stderr "deleting existing $buildfolder/$targetkit" |
||||
if {[catch { |
||||
file delete $buildfolder/$targetkit |
||||
} msg]} { |
||||
puts stderr "Failed to delete $buildfolder/$targetkit" |
||||
exit 4 |
||||
} |
||||
} |
||||
#WINDOWS filesystem 'tunneling' (file replacement within 15secs) could cause targetkit to copy ctime & shortname metadata from previous file! |
||||
#This is probably harmless - but worth being aware of. |
||||
file rename $buildfolder/$vfsname.new $buildfolder/$targetkit |
||||
# -- --- --- --- --- --- |
||||
$vfs_event targetset_end OK |
||||
|
||||
|
||||
after 200 |
||||
set deployment_folder [file dirname $sourcefolder]/bin |
||||
file mkdir $deployment_folder |
||||
|
||||
# -- ---------- |
||||
set bin_installer [punkcheck::installtrack new "make.tcl" $deployment_folder/.punkcheck] |
||||
$bin_installer set_source_target $buildfolder $deployment_folder |
||||
set bin_event [$bin_installer start_event {-make-step final_kit_install}] |
||||
$bin_event targetset_init INSTALL $deployment_folder/$targetkit |
||||
#todo - move final deployment step outside of the build vfs loop? (final deployment can fail and then isn't rerun even though _build and deployed versions differ, unless .vfs modified again) |
||||
#set last_completion [$bin_event targetset_last_complete] |
||||
|
||||
$bin_event targetset_addsource $buildfolder/$targetkit |
||||
$bin_event targetset_started |
||||
# -- ---------- |
||||
|
||||
|
||||
set delete_failed 0 |
||||
if {[file exists $deployment_folder/$targetkit]} { |
||||
puts stderr "deleting existing deployed at $deployment_folder/$targetkit" |
||||
if {[catch { |
||||
file delete $deployment_folder/$targetkit |
||||
} errMsg]} { |
||||
puts stderr "deletion of deployed version at $deployment_folder/$targetkit failed: $errMsg" |
||||
set delete_failed 1 |
||||
} |
||||
} |
||||
if {!$delete_failed} { |
||||
puts stdout "copying.." |
||||
puts stdout "$buildfolder/$targetkit" |
||||
puts stdout "to:" |
||||
puts stdout "$deployment_folder/$targetkit" |
||||
after 300 |
||||
file copy $buildfolder/$targetkit $deployment_folder/$targetkit |
||||
# -- ---------- |
||||
$bin_event targetset_end OK |
||||
# -- ---------- |
||||
} else { |
||||
$bin_event targetset_end FAILED -note "could not delete" |
||||
exit 5 |
||||
} |
||||
$bin_event destroy |
||||
$bin_installer destroy |
||||
|
||||
} else { |
||||
set skipped_vfs_build 1 |
||||
puts stderr "." |
||||
puts stdout "Skipping build for vfs $vfs with runtime $rtname - no change detected" |
||||
$vfs_event targetset_end SKIPPED |
||||
} |
||||
$vfs_event destroy |
||||
$vfs_installer destroy |
||||
} ;#end foreach rtname in runtimes |
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- |
||||
} |
||||
cd $startdir |
||||
|
||||
puts stdout "done" |
||||
exit 0 |
||||
|
||||
|
||||
@ -0,0 +1,245 @@
|
||||
# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# UUIDs are 128 bit values that attempt to be unique in time and space. |
||||
# |
||||
# Reference: |
||||
# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt |
||||
# |
||||
# uuid: scheme: |
||||
# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html |
||||
# |
||||
# Usage: uuid::uuid generate |
||||
# uuid::uuid equal $idA $idB |
||||
|
||||
package require Tcl 8.5 |
||||
|
||||
namespace eval uuid { |
||||
variable accel |
||||
array set accel {critcl 0} |
||||
|
||||
namespace export uuid |
||||
|
||||
variable uid |
||||
if {![info exists uid]} { |
||||
set uid 1 |
||||
} |
||||
|
||||
proc K {a b} {set a} |
||||
} |
||||
|
||||
### |
||||
# Optimization |
||||
# Caches machine info after the first pass |
||||
### |
||||
|
||||
proc ::uuid::generate_tcl_machinfo {} { |
||||
variable machinfo |
||||
if {[info exists machinfo]} { |
||||
return $machinfo |
||||
} |
||||
lappend machinfo [clock seconds]; # timestamp |
||||
lappend machinfo [clock clicks]; # system incrementing counter |
||||
lappend machinfo [info hostname]; # spatial unique id (poor) |
||||
lappend machinfo [pid]; # additional entropy |
||||
lappend machinfo [array get ::tcl_platform] |
||||
|
||||
### |
||||
# If we have /dev/urandom just stream 128 bits from that |
||||
### |
||||
if {[file exists /dev/urandom]} { |
||||
set fin [open /dev/urandom r] |
||||
binary scan [read $fin 128] H* machinfo |
||||
close $fin |
||||
} elseif {[catch {package require nettool}]} { |
||||
# More spatial information -- better than hostname. |
||||
# bug 1150714: opening a server socket may raise a warning messagebox |
||||
# with WinXP firewall, using ipconfig will return all IP addresses |
||||
# including ipv6 ones if available. ipconfig is OK on win98+ |
||||
if {[string equal $::tcl_platform(platform) "windows"]} { |
||||
catch {exec ipconfig} config |
||||
lappend machinfo $config |
||||
} else { |
||||
catch { |
||||
set s [socket -server void -myaddr [info hostname] 0] |
||||
K [fconfigure $s -sockname] [close $s] |
||||
} r |
||||
lappend machinfo $r |
||||
} |
||||
|
||||
if {[package provide Tk] != {}} { |
||||
lappend machinfo [winfo pointerxy .] |
||||
lappend machinfo [winfo id .] |
||||
} |
||||
} else { |
||||
### |
||||
# If the nettool package works on this platform |
||||
# use the stream of hardware ids from it |
||||
### |
||||
lappend machinfo {*}[::nettool::hwid_list] |
||||
} |
||||
return $machinfo |
||||
} |
||||
|
||||
# Generates a binary UUID as per the draft spec. We generate a pseudo-random |
||||
# type uuid (type 4). See section 3.4 |
||||
# |
||||
proc ::uuid::generate_tcl {} { |
||||
package require md5 2 |
||||
variable uid |
||||
|
||||
set tok [md5::MD5Init] |
||||
md5::MD5Update $tok [incr uid]; # package incrementing counter |
||||
foreach string [generate_tcl_machinfo] { |
||||
md5::MD5Update $tok $string |
||||
} |
||||
set r [md5::MD5Final $tok] |
||||
binary scan $r c* r |
||||
|
||||
# 3.4: set uuid versioning fields |
||||
lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] |
||||
lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] |
||||
|
||||
return [binary format c* $r] |
||||
} |
||||
|
||||
if {[string equal $tcl_platform(platform) "windows"] |
||||
&& [package provide critcl] != {}} { |
||||
namespace eval uuid { |
||||
critcl::ccode { |
||||
#define WIN32_LEAN_AND_MEAN |
||||
#define STRICT |
||||
#include <windows.h> |
||||
#include <ole2.h> |
||||
typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); |
||||
typedef const unsigned char cu_char; |
||||
} |
||||
critcl::cproc generate_c {Tcl_Interp* interp} ok { |
||||
HRESULT hr = S_OK; |
||||
int r = TCL_OK; |
||||
UUID uuid = {0}; |
||||
HMODULE hLib; |
||||
LPFNUUIDCREATE lpfnUuidCreate = NULL; |
||||
hLib = LoadLibraryA(("rpcrt4.dll")); |
||||
if (hLib) |
||||
lpfnUuidCreate = (LPFNUUIDCREATE) |
||||
GetProcAddress(hLib, "UuidCreate"); |
||||
if (lpfnUuidCreate) { |
||||
Tcl_Obj *obj; |
||||
lpfnUuidCreate(&uuid); |
||||
obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); |
||||
Tcl_SetObjResult(interp, obj); |
||||
} else { |
||||
Tcl_SetResult(interp, "error: failed to create a guid", |
||||
TCL_STATIC); |
||||
r = TCL_ERROR; |
||||
} |
||||
return r; |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Convert a binary uuid into its string representation. |
||||
# |
||||
proc ::uuid::tostring {uuid} { |
||||
binary scan $uuid H* s |
||||
foreach {a b} {0 7 8 11 12 15 16 19 20 end} { |
||||
append r [string range $s $a $b] - |
||||
} |
||||
return [string tolower [string trimright $r -]] |
||||
} |
||||
|
||||
# Convert a string representation of a uuid into its binary format. |
||||
# |
||||
proc ::uuid::fromstring {uuid} { |
||||
return [binary format H* [string map {- {}} $uuid]] |
||||
} |
||||
|
||||
# Compare two uuids for equality. |
||||
# |
||||
proc ::uuid::equal {left right} { |
||||
set l [fromstring $left] |
||||
set r [fromstring $right] |
||||
return [string equal $l $r] |
||||
} |
||||
|
||||
# Call our generate uuid implementation |
||||
proc ::uuid::generate {} { |
||||
variable accel |
||||
if {$accel(critcl)} { |
||||
return [generate_c] |
||||
} else { |
||||
return [generate_tcl] |
||||
} |
||||
} |
||||
|
||||
# uuid generate -> string rep of a new uuid |
||||
# uuid equal uuid1 uuid2 |
||||
# |
||||
proc uuid::uuid {cmd args} { |
||||
switch -exact -- $cmd { |
||||
generate { |
||||
if {[llength $args] != 0} { |
||||
return -code error "wrong # args:\ |
||||
should be \"uuid generate\"" |
||||
} |
||||
return [tostring [generate]] |
||||
} |
||||
equal { |
||||
if {[llength $args] != 2} { |
||||
return -code error "wrong \# args:\ |
||||
should be \"uuid equal uuid1 uuid2\"" |
||||
} |
||||
return [eval [linsert $args 0 equal]] |
||||
} |
||||
default { |
||||
return -code error "bad option \"$cmd\":\ |
||||
must be generate or equal" |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# LoadAccelerator -- |
||||
# |
||||
# This package can make use of a number of compiled extensions to |
||||
# accelerate the digest computation. This procedure manages the |
||||
# use of these extensions within the package. During normal usage |
||||
# this should not be called, but the test package manipulates the |
||||
# list of enabled accelerators. |
||||
# |
||||
proc ::uuid::LoadAccelerator {name} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $name { |
||||
critcl { |
||||
if {![catch {package require tcllibc}]} { |
||||
set r [expr {[info commands ::uuid::generate_c] != {}}] |
||||
} |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator package:\ |
||||
must be one of [join [array names accel] {, }]" |
||||
} |
||||
} |
||||
set accel($name) $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# Try and load a compiled extension to help. |
||||
namespace eval ::uuid { |
||||
variable e {} |
||||
foreach e {critcl} { |
||||
if {[LoadAccelerator $e]} break |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
package provide uuid 1.0.7 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Local variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
||||
Loading…
Reference in new issue