64 changed files with 13791 additions and 1788 deletions
@ -0,0 +1,786 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.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) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::auto_exec 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
#---------------------- |
||||
# registry notes |
||||
|
||||
#Computer\HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ApplicationAssociationToasts |
||||
# - associates applications/file types with extensions and protocols. |
||||
|
||||
#.cp items have a shell\cplopen\command subkey instead of shell\open\command |
||||
#- but the command string has the same format and placeholders as the shell\open\command entries for other file types, |
||||
#so we can handle them in the same way as other file types when we extract the associated command string. |
||||
|
||||
#---------------------- |
||||
|
||||
|
||||
|
||||
tcl::namespace::eval punk::auto_exec { |
||||
namespace eval argdoc { |
||||
variable PUNKARGS |
||||
set I "\x1b\[3m" ;# [a+ italic] |
||||
set NI "\x1b\[23m" ;# [a+ noitalic] |
||||
set B "\x1b\[1m" ;# [a+ bold] |
||||
set N "\x1b\[22m" ;# [a+ normal] |
||||
set T "\x1b\[1\;4m" ;# [a+ bold underline] |
||||
set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] |
||||
} |
||||
|
||||
variable PUNKARGS |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::shell_open_command" |
||||
@cmd -name "punk::auto_exec::assoc" -help\ |
||||
{Returns the raw 'open' command string associated with the file type for the given file extension, |
||||
by looking up the user-specific association in the registry and falling back to the system |
||||
association if no user-specific association is found. |
||||
|
||||
The resulting command string can contain placeholders like "%1" for the file name. |
||||
e.g .py -> "c:\Program Files\Python\python.exe" "%1" |
||||
e.g .rb -> "C:\tools\ruby31\bin\ruby.exe" "%1" %* |
||||
e.g .vbs -> "%SystemRoot%\System32\WScript.exe" "%1" %* |
||||
|
||||
Note that the resulting string has unescaped backslashes within double quotes, so it is |
||||
not suitable for direct execution by Tcl without further processing to handle the backslashes |
||||
and placeholders. |
||||
|
||||
see 'shell_command_as_tcl_list' for processing the command string into a Tcl list of command and |
||||
arguments with placeholders substituted. |
||||
} |
||||
@opts |
||||
@values -min 0 -max 1 |
||||
ext -type string -default "" -optional true -help\ |
||||
"File extension to look up, e.g .txt or .py" |
||||
}] |
||||
proc shell_open_command {ext} { |
||||
#look up assoc and ftype to find associated file type and application. |
||||
#Note that the windows 'ftype' and 'assoc' commands only examine the system's data - not the user-specific data which may override the system data. |
||||
#to get the user-specific associations we need to read the registry keys. |
||||
|
||||
#extensions in the registry seem to be stored lower case wnd with a leading dot. |
||||
set lext [string tolower $ext] |
||||
package require registry |
||||
set user_assoc_path [join [list HKEY_CURRENT_USER Software Microsoft Windows CurrentVersion Explorer FileExts $lext UserChoice] "\\"] |
||||
|
||||
#The UserChoice subkey under this key is where the user-specific association is stored when the user has made a choice. It contains a Progid value which points to the associated file type. |
||||
#It can return something like "Python.File" or "Applications\python.exe" or even tcl_auto_file (for .tcl files associated with tclsh by a tcl installer) |
||||
|
||||
set openverb "open" |
||||
|
||||
|
||||
#The UserChoice key may not exist if the user hasn't made an explicit choice, in which case we fall back to the system association which is stored under HKEY_CLASSES_ROOT\$ext (which also contains user-specific overrides but is more cumbersome to query for them) |
||||
if {![catch {registry get $user_assoc_path Progid} user_choice]} { |
||||
if {$user_choice ne ""} { |
||||
#examples such as Applications\python.exe and tcl_auto_file are found under HKEY_CURRENT_USER\Software\Classes |
||||
#they then have a sub-path shell\open\command which contains the command to open files of that type, which is what we need to extract the associated application. |
||||
#it is faster to query for the key directly within a catch than to retrieve keys as lists and iterate through them to find the one we want. |
||||
|
||||
#special case .cpl cplfile |
||||
if {$user_choice eq "cplfile"} { |
||||
set openverb "cplopen" |
||||
} |
||||
set verbinfo [ftype $user_choice] |
||||
if {[dict exists $verbinfo $openverb]} { |
||||
set ftypeinfo [dict get $verbinfo $openverb] |
||||
return [dict set ftypeinfo filetype $user_choice] |
||||
} else { |
||||
return [dict create type "notfound" value "" scope user filetype $user_choice] |
||||
} |
||||
|
||||
} else { |
||||
#review - is it possible for Progid to be empty string? If so we should probably fall back to system association instead of returning no association. |
||||
#alternatively it could mean the user has explicitly chosen to have no association for this file type - in which case returning an empty association may be the correct behaviour. |
||||
return [dict create type "empty" value "" scope user filetype ""] |
||||
} |
||||
} else { |
||||
#fall back to system association and ftype |
||||
if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $lext] "\\"] ""} ftype]} { |
||||
#ftype is the file type associated with the extension, e.g "Python.File" |
||||
#we then need to look up the command associated with this file type under the same path but with the file type instead of the extension and with the additional sub-path shell\open\command |
||||
|
||||
#special case .cpl cplfile |
||||
if {$ftype eq "cplfile"} { |
||||
set openverb "cplopen" |
||||
} |
||||
set verbinfo [ftype $ftype] |
||||
if {[dict exists $verbinfo $openverb]} { |
||||
set ftypeinfo [dict get $verbinfo $openverb] |
||||
return [dict set ftypeinfo filetype $ftype] |
||||
} else { |
||||
return [dict create type "notfound" value "" scope system filetype $ftype] |
||||
} |
||||
} else { |
||||
return [dict create type "notfound" value "" scope "" filetype ""] |
||||
} |
||||
} |
||||
#shouldn't get here - there is a return in each branch above. |
||||
return "no-result" |
||||
} |
||||
|
||||
# %1 - standard placeholder for the first file parameter. |
||||
# %L (or %l) - Long File Name form of the path. |
||||
# %* - replaces with all parameters passed to the command. (ie not including the command itself) |
||||
# %W (or %w) - working directory. |
||||
|
||||
# other placeholders that we won't handle for now: |
||||
# %I (or %i) - handle to an Item ID List (IDList) |
||||
# e.g for filetype ArchiveFolder (associated with .7z, .gz, .CPIO etc) we have "%SystemRoot%\Explorer.exe" /idlist,%I,%L |
||||
# %D (or %d) - Desktop absolute parsing name of the first parameter |
||||
# (for items that don't have file system paths) will be the same as %1 for file system items. |
||||
|
||||
#todo - we need to substitute other placeholders such as %SystemRoot% etc. (case insensitively) |
||||
# - but only if the type of the key is expand_sz. |
||||
|
||||
#These are environment variables that can be used in the command string. |
||||
#when type is sz - only the single letter placeholders are substituted, and environment variables are not substituted. |
||||
#when type is expand_sz - the single letter placeholders are substituted, and environment variables are also substituted |
||||
#(case insensitively) - but only if they are in the form %VAR% |
||||
#A matching environment variable will take precedence over a single letter placeholder if there is a conflict, |
||||
#e.g if the string is %1% and there is an environment variable named "1" then it will be substituted instead of the %1 placeholder. |
||||
#a non-existant environment variable will not be substituted and it's wrapping % characters will not be included in the output. |
||||
#similarly a single letter placeholder that is not recognised, such as %x, will result in only the x being included in the output without the leading % character. |
||||
|
||||
|
||||
#todo - tests for shell_command_as_tcl_list with various combinations of placeholders, quoted and unquoted, |
||||
#and with both reg_sz and reg_expand_sz types, and with various edge cases such as missing arguments, extra arguments, |
||||
#empty arguments, unrecognized placeholders, invalid env var references etc. |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::shell_command_as_tcl_list" |
||||
@cmd -name "punk::auto_exec::shell_command_as_tcl_list" -help\ |
||||
{} |
||||
@opts |
||||
-type -type string -default sz -choices {sz expand_sz} -help\ |
||||
"The type of the registry value containing the command string, which determines how |
||||
environment variables are substituted. sz means environment variables will not |
||||
be substituted, and expand_sz means environment variables will be substituted |
||||
if they are in the form %VAR% (case insensitively) and will take precedence over |
||||
single letter placeholders if there is a conflict. |
||||
|
||||
In either case, the single letter placeholders will be substituted as follows: |
||||
%1 - standard placeholder for the first file parameter. |
||||
%L (or %l) - Long File Name form of the path. |
||||
%* - replaced with all subsequent parameters passed to the command. |
||||
(but not including the script name itself) |
||||
%W (or %w) - working directory." |
||||
-workingdir -type string -default "" -help\ |
||||
"The working directory to substitute for the %W (or %w) placeholder." |
||||
@values -min 1 -max -1 |
||||
commandspec -type string -help\ |
||||
"The command string to process, which can contain placeholders like %1 for the file name, |
||||
and a list of arguments to substitute for the placeholders. The command string is typically |
||||
obtained from the registry for a file type association, and the arguments are typically the |
||||
file name and other parameters to substitute into the command string." |
||||
arg -type any -multiple 1 -optional 1 -help\ |
||||
{One or more arguments to substitute for the placeholders in the command string. |
||||
The first argument (often a script or document path) will be substituted for %1, |
||||
the second argument will be substituted for %2, and so on. If the command string |
||||
contains a %* placeholder, then all of the arguments will be substituted for that |
||||
placeholder starting from %2. |
||||
If there are more placeholders than arguments, then the extra placeholders will be |
||||
substituted with empty string. |
||||
If missing arguments are specified in the commandspec as quoted strings, eg "%3" then |
||||
corresponding empty strings as separate arguments will be included in the output.} |
||||
}] |
||||
proc shell_command_as_tcl_list {args} { |
||||
set argd [punk::args::parse $args withid ::punk::auto_exec::shell_command_as_tcl_list] |
||||
lassign [dict values $argd] _leaders opts values received |
||||
set type [dict get $opts -type] |
||||
set workingdir [dict get $opts -workingdir] |
||||
set commandspec [dict get $values commandspec] |
||||
if {[dict exists $received arg]} { |
||||
set arglist [dict get $values arg] |
||||
} else { |
||||
set arglist [list] |
||||
} |
||||
|
||||
set result [list] |
||||
set quoted [list 0] ;#track whether the current chunk is quoted or not. Only the last item is relevant. |
||||
|
||||
set chars [split [string trim $commandspec] ""] |
||||
set in_quote 0 |
||||
set current_chunk {} |
||||
set new_chunk 1 |
||||
set got_placeholder 0 |
||||
for {set i 0} {$i < [llength $chars]} {incr i} { |
||||
set char [lindex $chars $i] |
||||
if {$in_quote} { |
||||
if {$char eq "\""} { |
||||
if {$got_placeholder} { |
||||
#wasn't a valid placeholder - % not emitted. |
||||
set got_placeholder 0 |
||||
} |
||||
#The windows implementation doesn't seem to close off a chunk just because it encounters a closing quote, |
||||
#so we don't do that either. |
||||
#The closing quote just affects whether the next space will terminate the chunk or not. |
||||
set in_quote 0 |
||||
} else { |
||||
if {$char eq "%"} { |
||||
#we do not handle the trailing % of an env var such as %VAR% here |
||||
#- as we scan for that in the default case of the switch below. |
||||
if {$got_placeholder} { |
||||
#this is a % escaped by doubling up ie a literal % in the output |
||||
append current_chunk "%" |
||||
set got_placeholder 0 |
||||
} else { |
||||
set got_placeholder 1 |
||||
} |
||||
} elseif {$got_placeholder} { |
||||
if {$type eq "expand_sz"} { |
||||
#we scan for environment variables in the form %VAR% (case insensitively) and substitute them if found, taking precedence over single letter placeholders if there is a conflict. |
||||
#a non-existant environment variable will not be substituted and it's wrapping % characters will not be included in the output. |
||||
set env_var_name $char |
||||
for {set j [expr {$i+1}]} {$j < [llength $chars]} {incr j} { |
||||
set next_char [lindex $chars $j] |
||||
if {$next_char in {" " \t}} { |
||||
#end of env var name - we don't expect to see spaces within environment variable names, |
||||
#treat space as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "\""} { |
||||
#end of env var name - we don't expect to see quotes within environment variable names, |
||||
#treat quote as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "%"} { |
||||
#end of *possible* env var name |
||||
break |
||||
} else { |
||||
append env_var_name $next_char |
||||
} |
||||
} |
||||
if {$next_char eq "%"} { |
||||
#we found a closing % character, so we have a possible env var name between the two % characters. |
||||
#we will substitute the env var value if it exists, |
||||
# or the value of any single letter placeholder if there is a match, |
||||
# or the original string between the two % characters if there is no match for either an env var or a single letter placeholder. |
||||
if {[info exists ::env($env_var_name)]} { |
||||
append current_chunk $::env($env_var_name) |
||||
set got_placeholder 0 |
||||
set i $j ;#advance past the env var name and closing % character for next iteration of main loop |
||||
continue |
||||
} |
||||
} else { |
||||
#we didn't find a closing % character, so this isn't a valid env var reference. |
||||
set env_var_name "" |
||||
#fall through to single % placeholder handling below, |
||||
#which will treat the first character after the % as a single letter placeholder and include the rest of the string as literal characters in the output. |
||||
} |
||||
} |
||||
|
||||
switch -- $char { |
||||
1 - L - l { |
||||
append current_chunk [lindex $arglist 0] |
||||
} |
||||
2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { |
||||
append current_chunk [lindex $arglist $char-1] |
||||
} |
||||
D - d { |
||||
#review |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute the same value as %1 for now, |
||||
#which is what windows seems to do for file system items that have file paths. |
||||
append current_chunk [lindex $arglist 0] |
||||
} |
||||
I - i { |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute something for now. |
||||
#format seems to be 9 and 5 digits :nnnnnnnnn:nnnnn |
||||
#REVIEW! unknown consequences! |
||||
append current_chunk ":000000000:00000" |
||||
} |
||||
"*" { |
||||
append current_chunk [lrange $arglist 1 end] |
||||
} |
||||
W - w { |
||||
append current_chunk $workingdir |
||||
} |
||||
default { |
||||
if {$type eq "expand_sz"} { |
||||
#if expand_sz we would have already scanned for environment variables in the form %VAR% and substituted them if found, |
||||
#taking precedence over single letter placeholders if there is a conflict. |
||||
append current_chunk "$char" [string range $env_var_name 1 end] ;#if env_var_name is empty string then this will just append the single char after the % as a literal, |
||||
#which is the correct behaviour for unrecognized placeholders such as %x and for invalid env var references such as %NONEXISTANT% |
||||
} else { |
||||
append current_chunk $char |
||||
} |
||||
} |
||||
} |
||||
set got_placeholder 0 |
||||
} else { |
||||
append current_chunk $char |
||||
} |
||||
} |
||||
} else { |
||||
#NOT in quoted string |
||||
if {$char eq "\""} { |
||||
if {$got_placeholder} { |
||||
append current_chunk "%" ;#wasn't a valid placeholder char, so we need to add the % that we stripped off back into the output |
||||
set got_placeholder 0 |
||||
} |
||||
set in_quote 1 |
||||
set new_chunk 0 |
||||
lset quoted end 1 ;#we'll mark as quoted if any quote found in it - review |
||||
} elseif {$char in [list " " \t ]} { |
||||
#we don't expect to see tabs or other whitespace characters as separators in the command string, but we'll treat tab the same as spaces just in case. |
||||
if {$got_placeholder} { |
||||
#wasn't a valid placeholder char. The % is stripped and not included in the output. |
||||
set got_placeholder 0 |
||||
} |
||||
#space terminates an unquoted chunk, so we add it to the result list and start a new chunk. |
||||
#we also need to ensure that consecutive spaces are treated as a single separator and don't result in empty items in the output list, |
||||
|
||||
if {!$new_chunk} { |
||||
if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { |
||||
#we add the current chunk to the result list if it's not empty, or if it is empty but is quoted (because in that case we want to preserve it as an empty argument). |
||||
lappend result $current_chunk |
||||
lappend quoted 0 |
||||
set current_chunk {} |
||||
} |
||||
set new_chunk 1 |
||||
} |
||||
for {set j [expr {$i+1}]} {$j < [llength $chars]} {incr j} { |
||||
if {[lindex $chars $j] in {" " \t}} { |
||||
incr i |
||||
} else { |
||||
break |
||||
} |
||||
} |
||||
} else { |
||||
if {$got_placeholder} { |
||||
if {$type eq "expand_sz"} { |
||||
#we scan for environment variables in the form %VAR% (case insensitively) and substitute them if found, taking precedence over single letter placeholders if there is a conflict. |
||||
#a non-existant environment variable will not be substituted and it's wrapping % characters will not be included in the output. |
||||
set env_var_name $char |
||||
for {set j [expr {$i+1}]} {$j < [llength $chars]} {incr j} { |
||||
set next_char [lindex $chars $j] |
||||
if {$next_char in {" " \t}} { |
||||
#end of env var name - we don't expect to see spaces within environment variable names, |
||||
#treat space as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "\""} { |
||||
#end of env var name - we don't expect to see quotes within environment variable names, |
||||
#treat quote as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "%"} { |
||||
#end of *possible* env var name |
||||
break |
||||
} else { |
||||
append env_var_name $next_char |
||||
} |
||||
} |
||||
if {$next_char eq "%"} { |
||||
#we found a closing % character, so we have a possible env var name between the two % characters. |
||||
#we will substitute the env var value if it exists, |
||||
# or the value of any single letter placeholder if there is a match, |
||||
# or the original string between the two % characters if there is no match for either an env var or a single letter placeholder. |
||||
if {[info exists ::env($env_var_name)]} { |
||||
append current_chunk $::env($env_var_name) |
||||
set got_placeholder 0 |
||||
set i $j ;#advance past the env var name and closing % character for next iteration of main loop |
||||
continue |
||||
} |
||||
} else { |
||||
#we didn't find a closing % character, so this isn't a valid env var reference. |
||||
set env_var_name "" |
||||
#fall through to single % placeholder handling below, |
||||
#which will treat the first character after the % as a single letter placeholder and include the rest of the string as literal characters in the output. |
||||
} |
||||
} |
||||
|
||||
switch -- $char { |
||||
"%" { |
||||
append current_chunk "%" |
||||
set got_placeholder 1 |
||||
continue |
||||
} |
||||
1 - |
||||
L - l { |
||||
#append current_chunk [lindex $arglist 0] |
||||
set append_value [string trim [lindex $arglist 0]] |
||||
foreach ch [split $append_value ""] { |
||||
if {$ch eq " "} { |
||||
#we need to split on spaces within arguments as well, because unquoted %1 can expand to multiple arguments if the first argument contains spaces, and we need to preserve the correct splitting of arguments in that case. |
||||
#e.g if %1 is substituted with "C:\My Documents\file.txt" then we need to split that into three items in the output list: "C:\My", "Documents\file.txt" |
||||
if {$current_chunk ne ""} { |
||||
lappend result $current_chunk |
||||
lappend quoted 0 |
||||
set current_chunk {} |
||||
} |
||||
set new_chunk 1 |
||||
} else { |
||||
append current_chunk $ch |
||||
set new_chunk 0 |
||||
} |
||||
} |
||||
} |
||||
2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { |
||||
append current_chunk [lindex $arglist $char-1] |
||||
} |
||||
D - d { |
||||
#review |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute the same value as %1 for now, |
||||
#which is what windows seems to do for file system items that have file paths. |
||||
append current_chunk [lindex $arglist 0] |
||||
} |
||||
I - i { |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute something for now. |
||||
#format seems to be 9 and 5 digits :nnnnnnnnn:nnnnn |
||||
#REVIEW! unknown consequences! |
||||
append current_chunk ":000000000:00000" |
||||
} |
||||
"*" { |
||||
#the window implementation of unquoted %* always seems to emit the previous chunk before the %* placeholder as a separate item |
||||
#in the command line, even if there is no space between them, so we will do the same. |
||||
#Note that a following string (quoted or not) immediately after the %* will be appended to the last item in the output list rather than being a separate item, |
||||
#which is also consistent with the microsoft implementation. |
||||
if {!$new_chunk} { |
||||
if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { |
||||
lappend result $current_chunk |
||||
lappend quoted 0 |
||||
set current_chunk {} |
||||
} |
||||
} |
||||
lappend result {*}[lrange $arglist 1 end] |
||||
lappend quoted {*}[lrepeat [llength $arglist] 0] |
||||
} |
||||
W - w { |
||||
append current_chunk $workingdir |
||||
} |
||||
default { |
||||
if {$type eq "expand_sz"} { |
||||
#if expand_sz we would have already scanned for environment variables in the form %VAR% and substituted them if found, |
||||
#taking precedence over single letter placeholders if there is a conflict. |
||||
append current_chunk "$char" [string range $env_var_name 1 end] ;#if env_var_name is empty string then this will just append the single char after the % as a literal, |
||||
#which is the correct behaviour for unrecognized placeholders such as %x and for invalid env var references such as %NONEXISTANT% |
||||
} else { |
||||
append current_chunk $char |
||||
} |
||||
} |
||||
} |
||||
set got_placeholder 0 |
||||
set new_chunk 0 |
||||
} else { |
||||
if {$char eq "%"} { |
||||
set got_placeholder 1 |
||||
} else { |
||||
append current_chunk $char |
||||
set new_chunk 0 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { |
||||
#review - edge case - if the command string ends with a space then we would have already added the last chunk to the result list and started a new chunk, so we shouldn't add an empty chunk to the result list in that case. |
||||
#however if the last chunk was quoted and is empty because the command string ends with a placeholder that is substituted with an empty string, then we should add the empty chunk to the result list. |
||||
lappend result $current_chunk |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
namespace eval punk::auto_exec::system { |
||||
proc assoc_get_info {ext} { |
||||
set lext [string tolower $ext] |
||||
set result [dict create system "" user ""] |
||||
set user_assoc_path [join [list HKEY_CURRENT_USER Software Microsoft Windows CurrentVersion Explorer FileExts $lext UserChoice] "\\"] |
||||
if {![catch {registry get $user_assoc_path Progid} user_choice]} { |
||||
dict set result user $user_choice |
||||
} |
||||
if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $lext] "\\"] ""} ftype]} { |
||||
dict set result system $ftype |
||||
} |
||||
return $result |
||||
} |
||||
} |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::assoc" |
||||
@cmd -name "punk::auto_exec::assoc"\ |
||||
-summary\ |
||||
"Look up the associated file type (system and user) for a file extension"\ |
||||
-help\ |
||||
"Get the associated file type for a file extension by looking up the user-specific |
||||
file type in the registry and falling back to the system file type if no |
||||
user-specific association is found. |
||||
|
||||
Returns a dict with keys ${$I}system${$NI} and ${$I}user${$NI}. |
||||
One or more of the key values may be empty string if there is no defined |
||||
file type for the extension. |
||||
|
||||
This is somewhat like the windows 'assoc' command except that the windows command |
||||
only looks up the system association and does not take into account any user-specific |
||||
overrides. |
||||
This function returns both values in the result dictionary if they are available." |
||||
@opts |
||||
@values -min 0 -max 1 |
||||
ext -type string -default "" -optional true -help\ |
||||
"File extension to look up, e.g .txt or .py" |
||||
}] |
||||
proc assoc {args} { |
||||
package require registry |
||||
set argd [punk::args::parse $args withid ::punk::auto_exec::assoc] |
||||
set ext [dict get $argd values ext] |
||||
|
||||
if {$ext ne ""} { |
||||
return [punk::auto_exec::system::assoc_get_info $ext] |
||||
} else { |
||||
#look up all associated ftypes |
||||
set user_ftypes [registry keys {HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts} .*] |
||||
|
||||
set system_ftypes [registry keys {HKEY_LOCAL_MACHINE\SOFTWARE\Classes} .*] |
||||
set all_ftypes [lsort -unique [concat $user_ftypes $system_ftypes]] |
||||
set results [list] |
||||
foreach ftype $all_ftypes { |
||||
dict set results $ftype [punk::auto_exec::system::assoc_get_info $ftype] |
||||
} |
||||
return $results |
||||
} |
||||
} |
||||
namespace eval argdoc { |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::ftype" |
||||
@cmd -name "punk::auto_exec::ftype"\ |
||||
-summary\ |
||||
"Look up shell verb command values from windows file type."\ |
||||
-help\ |
||||
"Get the associated shell verb information (such as open) for a file type by looking up the user-specific |
||||
association in the registry and falling back to the system association if no |
||||
user-specific association is found. |
||||
|
||||
Returns a dict of dicts with toplevel keys for each shell verb (e.g open, runas) and values that are dicts with keys |
||||
${$I}type${$NI} and ${$I}value${$NI} and ${$I}scope${$NI}, where |
||||
type is determined from the registry value type (e.g sz or expand_sz) |
||||
string is the raw command string from the registry |
||||
scope is either "user" or "system" depending on whether the value was found in the user-specific registry keys or |
||||
the system registry keys. |
||||
|
||||
This is somewhat like the windows 'ftype' command except that the windows command only looks for the 'open' verb and |
||||
only looks up the system association and does not take into account any user-specific |
||||
overrides. |
||||
|
||||
The file type can be looked up using the ${$B}assoc${$N} function in this package. |
||||
|
||||
The command string can contain placeholders like \"%1\" for the file name, and environment variables |
||||
in the form %VAR% (case insensitive) if the registry value type is reg_expand_sz (expand_sz), |
||||
which will be substituted by the ${$B}shell_command_as_tcl_list${$N} function when processing the command |
||||
string into a Tcl list of command and arguments with placeholders substituted." |
||||
@opts |
||||
@values -min 0 -max 1 |
||||
filetype -type string -default "" -optional true -help\ |
||||
"File type associated with a file extension, e.g Python.File. |
||||
This can be looked up using the 'assoc' function in this package." |
||||
}] |
||||
} |
||||
#proc ftype {filetype} { |
||||
# package require registry |
||||
|
||||
# if {$filetype eq "cplfile"} { |
||||
# #special case for cplfile (associated with .cpl files) which doesn't follow the usual pattern of having the command string under shell\open\command, |
||||
# #but instead has it under HKEY_LOCAL_MACHINE\SOFTWARE\Classes\cplfile\shell\cplopen\command. |
||||
# #There doesn't seem to be any user-specific override for this file type |
||||
# #- but we will check for one under HKEY_CURRENT_USER\Software\Classes\cplfile\shell\cplopen\command anyway for consistency with the way we check |
||||
# #for user-specific overrides for other file types. |
||||
# set key [join [list HKEY_CURRENT_USER Software Classes cplfile shell cplopen command] "\\"] |
||||
# } else { |
||||
# set key [join [list HKEY_CURRENT_USER Software Classes $filetype shell open command] "\\"] |
||||
# } |
||||
# if {![catch {registry get $key ""} raw_assoc]} { |
||||
# set tp [registry type $key ""] |
||||
# return [dict create open [dict create type $tp string $raw_assoc]] |
||||
# } else { |
||||
# #e.g Python.File |
||||
# if {$filetype eq "cplfile"} { |
||||
# set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes cplfile shell cplopen command] "\\"] |
||||
# } else { |
||||
# set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell open command] "\\"] |
||||
# } |
||||
# if {![catch {registry get $key ""} raw_assoc]} { |
||||
# set tp [registry type $key ""] |
||||
# return [dict create type $tp string $raw_assoc] |
||||
# } else { |
||||
# return [dict create type "" string ""] ;#no association found |
||||
# } |
||||
# } |
||||
#} |
||||
proc ftype {filetype} { |
||||
package require registry |
||||
set resultdict [dict create] |
||||
|
||||
#e.g Python.File |
||||
set shellpath [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell] "\\"] |
||||
if {![catch {registry keys $shellpath *} shellverbs]} { |
||||
foreach verb $shellverbs { |
||||
set commandkey [join [list $shellpath $verb command] "\\"] |
||||
if {![catch {registry get $commandkey ""} cmdstring]} { |
||||
#registry queryies are case insensitive but some are cased differently e.g Open vs open. |
||||
#when using the verb as a key in the output dict, we need to normalize so that it is useful for lookups. We'll use lowercase for that. |
||||
set verb [string tolower $verb] |
||||
set tp [registry type $commandkey ""] |
||||
dict set resultdict $verb [dict create type $tp value $cmdstring scope system] |
||||
} |
||||
} |
||||
} |
||||
|
||||
#allow user-specific verbs to be overridden. |
||||
set shellpath [join [list HKEY_CURRENT_USER Software Classes $filetype shell] "\\"] |
||||
if {![catch {registry keys $shellpath *} shellverbs]} { |
||||
foreach verb $shellverbs { |
||||
set commandkey [join [list $shellpath $verb command] "\\"] |
||||
if {![catch {registry get $commandkey ""} cmdstring]} { |
||||
set verb [string tolower $verb] |
||||
set tp [registry type $commandkey ""] |
||||
dict set resultdict $verb [dict create type $tp value $cmdstring scope user] |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $resultdict |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::auto_exec::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
#tcl::namespace::eval punk::auto_exec::system { |
||||
#} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval punk::auto_exec { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)punk::auto_exec" |
||||
@package -name "punk::auto_exec" -help\ |
||||
"Package |
||||
Description" |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return punk::auto_exec |
||||
} |
||||
proc about_topics {} { |
||||
#info commands results are returned in an arbitrary order (like array keys) |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
#Adjust this function or 'default_topics' if a different order is required |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
# ------------------------------------------------------------- |
||||
# get_topic_ functions add more to auto-include in about topics |
||||
# ------------------------------------------------------------- |
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package punk::auto_exec |
||||
description to come.. |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "<unspecified>" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::punk::auto_exec::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{<julian@precisium.com.au> {Julian Noble}}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_custom-topic {} { |
||||
punk::args::lib::tstr -return string { |
||||
A custom |
||||
topic |
||||
etc |
||||
} |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# we re-use the argument definition from punk::args::standard_about and override some items |
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::punk::auto_exec::about" |
||||
dict set overrides @cmd -name "punk::auto_exec::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About punk::auto_exec |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[punk::auto_exec::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [punk::auto_exec::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||
set argd [punk::args::parse $args withid ::punk::auto_exec::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::punk::auto_exec::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
# variable PUNKARGS |
||||
# variable PUNKARGS_aliases |
||||
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::auto_exec |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::auto_exec [tcl::namespace::eval punk::auto_exec { |
||||
variable pkg punk::auto_exec |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,786 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.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) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::auto_exec 999999.0a1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
#---------------------- |
||||
# registry notes |
||||
|
||||
#Computer\HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ApplicationAssociationToasts |
||||
# - associates applications/file types with extensions and protocols. |
||||
|
||||
#.cp items have a shell\cplopen\command subkey instead of shell\open\command |
||||
#- but the command string has the same format and placeholders as the shell\open\command entries for other file types, |
||||
#so we can handle them in the same way as other file types when we extract the associated command string. |
||||
|
||||
#---------------------- |
||||
|
||||
|
||||
|
||||
tcl::namespace::eval punk::auto_exec { |
||||
namespace eval argdoc { |
||||
variable PUNKARGS |
||||
set I "\x1b\[3m" ;# [a+ italic] |
||||
set NI "\x1b\[23m" ;# [a+ noitalic] |
||||
set B "\x1b\[1m" ;# [a+ bold] |
||||
set N "\x1b\[22m" ;# [a+ normal] |
||||
set T "\x1b\[1\;4m" ;# [a+ bold underline] |
||||
set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] |
||||
} |
||||
|
||||
variable PUNKARGS |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::shell_open_command" |
||||
@cmd -name "punk::auto_exec::assoc" -help\ |
||||
{Returns the raw 'open' command string associated with the file type for the given file extension, |
||||
by looking up the user-specific association in the registry and falling back to the system |
||||
association if no user-specific association is found. |
||||
|
||||
The resulting command string can contain placeholders like "%1" for the file name. |
||||
e.g .py -> "c:\Program Files\Python\python.exe" "%1" |
||||
e.g .rb -> "C:\tools\ruby31\bin\ruby.exe" "%1" %* |
||||
e.g .vbs -> "%SystemRoot%\System32\WScript.exe" "%1" %* |
||||
|
||||
Note that the resulting string has unescaped backslashes within double quotes, so it is |
||||
not suitable for direct execution by Tcl without further processing to handle the backslashes |
||||
and placeholders. |
||||
|
||||
see 'shell_command_as_tcl_list' for processing the command string into a Tcl list of command and |
||||
arguments with placeholders substituted. |
||||
} |
||||
@opts |
||||
@values -min 0 -max 1 |
||||
ext -type string -default "" -optional true -help\ |
||||
"File extension to look up, e.g .txt or .py" |
||||
}] |
||||
proc shell_open_command {ext} { |
||||
#look up assoc and ftype to find associated file type and application. |
||||
#Note that the windows 'ftype' and 'assoc' commands only examine the system's data - not the user-specific data which may override the system data. |
||||
#to get the user-specific associations we need to read the registry keys. |
||||
|
||||
#extensions in the registry seem to be stored lower case wnd with a leading dot. |
||||
set lext [string tolower $ext] |
||||
package require registry |
||||
set user_assoc_path [join [list HKEY_CURRENT_USER Software Microsoft Windows CurrentVersion Explorer FileExts $lext UserChoice] "\\"] |
||||
|
||||
#The UserChoice subkey under this key is where the user-specific association is stored when the user has made a choice. It contains a Progid value which points to the associated file type. |
||||
#It can return something like "Python.File" or "Applications\python.exe" or even tcl_auto_file (for .tcl files associated with tclsh by a tcl installer) |
||||
|
||||
set openverb "open" |
||||
|
||||
|
||||
#The UserChoice key may not exist if the user hasn't made an explicit choice, in which case we fall back to the system association which is stored under HKEY_CLASSES_ROOT\$ext (which also contains user-specific overrides but is more cumbersome to query for them) |
||||
if {![catch {registry get $user_assoc_path Progid} user_choice]} { |
||||
if {$user_choice ne ""} { |
||||
#examples such as Applications\python.exe and tcl_auto_file are found under HKEY_CURRENT_USER\Software\Classes |
||||
#they then have a sub-path shell\open\command which contains the command to open files of that type, which is what we need to extract the associated application. |
||||
#it is faster to query for the key directly within a catch than to retrieve keys as lists and iterate through them to find the one we want. |
||||
|
||||
#special case .cpl cplfile |
||||
if {$user_choice eq "cplfile"} { |
||||
set openverb "cplopen" |
||||
} |
||||
set verbinfo [ftype $user_choice] |
||||
if {[dict exists $verbinfo $openverb]} { |
||||
set ftypeinfo [dict get $verbinfo $openverb] |
||||
return [dict set ftypeinfo filetype $user_choice] |
||||
} else { |
||||
return [dict create type "notfound" value "" scope user filetype $user_choice] |
||||
} |
||||
|
||||
} else { |
||||
#review - is it possible for Progid to be empty string? If so we should probably fall back to system association instead of returning no association. |
||||
#alternatively it could mean the user has explicitly chosen to have no association for this file type - in which case returning an empty association may be the correct behaviour. |
||||
return [dict create type "empty" value "" scope user filetype ""] |
||||
} |
||||
} else { |
||||
#fall back to system association and ftype |
||||
if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $lext] "\\"] ""} ftype]} { |
||||
#ftype is the file type associated with the extension, e.g "Python.File" |
||||
#we then need to look up the command associated with this file type under the same path but with the file type instead of the extension and with the additional sub-path shell\open\command |
||||
|
||||
#special case .cpl cplfile |
||||
if {$ftype eq "cplfile"} { |
||||
set openverb "cplopen" |
||||
} |
||||
set verbinfo [ftype $ftype] |
||||
if {[dict exists $verbinfo $openverb]} { |
||||
set ftypeinfo [dict get $verbinfo $openverb] |
||||
return [dict set ftypeinfo filetype $ftype] |
||||
} else { |
||||
return [dict create type "notfound" value "" scope system filetype $ftype] |
||||
} |
||||
} else { |
||||
return [dict create type "notfound" value "" scope "" filetype ""] |
||||
} |
||||
} |
||||
#shouldn't get here - there is a return in each branch above. |
||||
return "no-result" |
||||
} |
||||
|
||||
# %1 - standard placeholder for the first file parameter. |
||||
# %L (or %l) - Long File Name form of the path. |
||||
# %* - replaces with all parameters passed to the command. (ie not including the command itself) |
||||
# %W (or %w) - working directory. |
||||
|
||||
# other placeholders that we won't handle for now: |
||||
# %I (or %i) - handle to an Item ID List (IDList) |
||||
# e.g for filetype ArchiveFolder (associated with .7z, .gz, .CPIO etc) we have "%SystemRoot%\Explorer.exe" /idlist,%I,%L |
||||
# %D (or %d) - Desktop absolute parsing name of the first parameter |
||||
# (for items that don't have file system paths) will be the same as %1 for file system items. |
||||
|
||||
#todo - we need to substitute other placeholders such as %SystemRoot% etc. (case insensitively) |
||||
# - but only if the type of the key is expand_sz. |
||||
|
||||
#These are environment variables that can be used in the command string. |
||||
#when type is sz - only the single letter placeholders are substituted, and environment variables are not substituted. |
||||
#when type is expand_sz - the single letter placeholders are substituted, and environment variables are also substituted |
||||
#(case insensitively) - but only if they are in the form %VAR% |
||||
#A matching environment variable will take precedence over a single letter placeholder if there is a conflict, |
||||
#e.g if the string is %1% and there is an environment variable named "1" then it will be substituted instead of the %1 placeholder. |
||||
#a non-existant environment variable will not be substituted and it's wrapping % characters will not be included in the output. |
||||
#similarly a single letter placeholder that is not recognised, such as %x, will result in only the x being included in the output without the leading % character. |
||||
|
||||
|
||||
#todo - tests for shell_command_as_tcl_list with various combinations of placeholders, quoted and unquoted, |
||||
#and with both reg_sz and reg_expand_sz types, and with various edge cases such as missing arguments, extra arguments, |
||||
#empty arguments, unrecognized placeholders, invalid env var references etc. |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::shell_command_as_tcl_list" |
||||
@cmd -name "punk::auto_exec::shell_command_as_tcl_list" -help\ |
||||
{} |
||||
@opts |
||||
-type -type string -default sz -choices {sz expand_sz} -help\ |
||||
"The type of the registry value containing the command string, which determines how |
||||
environment variables are substituted. sz means environment variables will not |
||||
be substituted, and expand_sz means environment variables will be substituted |
||||
if they are in the form %VAR% (case insensitively) and will take precedence over |
||||
single letter placeholders if there is a conflict. |
||||
|
||||
In either case, the single letter placeholders will be substituted as follows: |
||||
%1 - standard placeholder for the first file parameter. |
||||
%L (or %l) - Long File Name form of the path. |
||||
%* - replaced with all subsequent parameters passed to the command. |
||||
(but not including the script name itself) |
||||
%W (or %w) - working directory." |
||||
-workingdir -type string -default "" -help\ |
||||
"The working directory to substitute for the %W (or %w) placeholder." |
||||
@values -min 1 -max -1 |
||||
commandspec -type string -help\ |
||||
"The command string to process, which can contain placeholders like %1 for the file name, |
||||
and a list of arguments to substitute for the placeholders. The command string is typically |
||||
obtained from the registry for a file type association, and the arguments are typically the |
||||
file name and other parameters to substitute into the command string." |
||||
arg -type any -multiple 1 -optional 1 -help\ |
||||
{One or more arguments to substitute for the placeholders in the command string. |
||||
The first argument (often a script or document path) will be substituted for %1, |
||||
the second argument will be substituted for %2, and so on. If the command string |
||||
contains a %* placeholder, then all of the arguments will be substituted for that |
||||
placeholder starting from %2. |
||||
If there are more placeholders than arguments, then the extra placeholders will be |
||||
substituted with empty string. |
||||
If missing arguments are specified in the commandspec as quoted strings, eg "%3" then |
||||
corresponding empty strings as separate arguments will be included in the output.} |
||||
}] |
||||
proc shell_command_as_tcl_list {args} { |
||||
set argd [punk::args::parse $args withid ::punk::auto_exec::shell_command_as_tcl_list] |
||||
lassign [dict values $argd] _leaders opts values received |
||||
set type [dict get $opts -type] |
||||
set workingdir [dict get $opts -workingdir] |
||||
set commandspec [dict get $values commandspec] |
||||
if {[dict exists $received arg]} { |
||||
set arglist [dict get $values arg] |
||||
} else { |
||||
set arglist [list] |
||||
} |
||||
|
||||
set result [list] |
||||
set quoted [list 0] ;#track whether the current chunk is quoted or not. Only the last item is relevant. |
||||
|
||||
set chars [split [string trim $commandspec] ""] |
||||
set in_quote 0 |
||||
set current_chunk {} |
||||
set new_chunk 1 |
||||
set got_placeholder 0 |
||||
for {set i 0} {$i < [llength $chars]} {incr i} { |
||||
set char [lindex $chars $i] |
||||
if {$in_quote} { |
||||
if {$char eq "\""} { |
||||
if {$got_placeholder} { |
||||
#wasn't a valid placeholder - % not emitted. |
||||
set got_placeholder 0 |
||||
} |
||||
#The windows implementation doesn't seem to close off a chunk just because it encounters a closing quote, |
||||
#so we don't do that either. |
||||
#The closing quote just affects whether the next space will terminate the chunk or not. |
||||
set in_quote 0 |
||||
} else { |
||||
if {$char eq "%"} { |
||||
#we do not handle the trailing % of an env var such as %VAR% here |
||||
#- as we scan for that in the default case of the switch below. |
||||
if {$got_placeholder} { |
||||
#this is a % escaped by doubling up ie a literal % in the output |
||||
append current_chunk "%" |
||||
set got_placeholder 0 |
||||
} else { |
||||
set got_placeholder 1 |
||||
} |
||||
} elseif {$got_placeholder} { |
||||
if {$type eq "expand_sz"} { |
||||
#we scan for environment variables in the form %VAR% (case insensitively) and substitute them if found, taking precedence over single letter placeholders if there is a conflict. |
||||
#a non-existant environment variable will not be substituted and it's wrapping % characters will not be included in the output. |
||||
set env_var_name $char |
||||
for {set j [expr {$i+1}]} {$j < [llength $chars]} {incr j} { |
||||
set next_char [lindex $chars $j] |
||||
if {$next_char in {" " \t}} { |
||||
#end of env var name - we don't expect to see spaces within environment variable names, |
||||
#treat space as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "\""} { |
||||
#end of env var name - we don't expect to see quotes within environment variable names, |
||||
#treat quote as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "%"} { |
||||
#end of *possible* env var name |
||||
break |
||||
} else { |
||||
append env_var_name $next_char |
||||
} |
||||
} |
||||
if {$next_char eq "%"} { |
||||
#we found a closing % character, so we have a possible env var name between the two % characters. |
||||
#we will substitute the env var value if it exists, |
||||
# or the value of any single letter placeholder if there is a match, |
||||
# or the original string between the two % characters if there is no match for either an env var or a single letter placeholder. |
||||
if {[info exists ::env($env_var_name)]} { |
||||
append current_chunk $::env($env_var_name) |
||||
set got_placeholder 0 |
||||
set i $j ;#advance past the env var name and closing % character for next iteration of main loop |
||||
continue |
||||
} |
||||
} else { |
||||
#we didn't find a closing % character, so this isn't a valid env var reference. |
||||
set env_var_name "" |
||||
#fall through to single % placeholder handling below, |
||||
#which will treat the first character after the % as a single letter placeholder and include the rest of the string as literal characters in the output. |
||||
} |
||||
} |
||||
|
||||
switch -- $char { |
||||
1 - L - l { |
||||
append current_chunk [lindex $arglist 0] |
||||
} |
||||
2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { |
||||
append current_chunk [lindex $arglist $char-1] |
||||
} |
||||
D - d { |
||||
#review |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute the same value as %1 for now, |
||||
#which is what windows seems to do for file system items that have file paths. |
||||
append current_chunk [lindex $arglist 0] |
||||
} |
||||
I - i { |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute something for now. |
||||
#format seems to be 9 and 5 digits :nnnnnnnnn:nnnnn |
||||
#REVIEW! unknown consequences! |
||||
append current_chunk ":000000000:00000" |
||||
} |
||||
"*" { |
||||
append current_chunk [lrange $arglist 1 end] |
||||
} |
||||
W - w { |
||||
append current_chunk $workingdir |
||||
} |
||||
default { |
||||
if {$type eq "expand_sz"} { |
||||
#if expand_sz we would have already scanned for environment variables in the form %VAR% and substituted them if found, |
||||
#taking precedence over single letter placeholders if there is a conflict. |
||||
append current_chunk "$char" [string range $env_var_name 1 end] ;#if env_var_name is empty string then this will just append the single char after the % as a literal, |
||||
#which is the correct behaviour for unrecognized placeholders such as %x and for invalid env var references such as %NONEXISTANT% |
||||
} else { |
||||
append current_chunk $char |
||||
} |
||||
} |
||||
} |
||||
set got_placeholder 0 |
||||
} else { |
||||
append current_chunk $char |
||||
} |
||||
} |
||||
} else { |
||||
#NOT in quoted string |
||||
if {$char eq "\""} { |
||||
if {$got_placeholder} { |
||||
append current_chunk "%" ;#wasn't a valid placeholder char, so we need to add the % that we stripped off back into the output |
||||
set got_placeholder 0 |
||||
} |
||||
set in_quote 1 |
||||
set new_chunk 0 |
||||
lset quoted end 1 ;#we'll mark as quoted if any quote found in it - review |
||||
} elseif {$char in [list " " \t ]} { |
||||
#we don't expect to see tabs or other whitespace characters as separators in the command string, but we'll treat tab the same as spaces just in case. |
||||
if {$got_placeholder} { |
||||
#wasn't a valid placeholder char. The % is stripped and not included in the output. |
||||
set got_placeholder 0 |
||||
} |
||||
#space terminates an unquoted chunk, so we add it to the result list and start a new chunk. |
||||
#we also need to ensure that consecutive spaces are treated as a single separator and don't result in empty items in the output list, |
||||
|
||||
if {!$new_chunk} { |
||||
if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { |
||||
#we add the current chunk to the result list if it's not empty, or if it is empty but is quoted (because in that case we want to preserve it as an empty argument). |
||||
lappend result $current_chunk |
||||
lappend quoted 0 |
||||
set current_chunk {} |
||||
} |
||||
set new_chunk 1 |
||||
} |
||||
for {set j [expr {$i+1}]} {$j < [llength $chars]} {incr j} { |
||||
if {[lindex $chars $j] in {" " \t}} { |
||||
incr i |
||||
} else { |
||||
break |
||||
} |
||||
} |
||||
} else { |
||||
if {$got_placeholder} { |
||||
if {$type eq "expand_sz"} { |
||||
#we scan for environment variables in the form %VAR% (case insensitively) and substitute them if found, taking precedence over single letter placeholders if there is a conflict. |
||||
#a non-existant environment variable will not be substituted and it's wrapping % characters will not be included in the output. |
||||
set env_var_name $char |
||||
for {set j [expr {$i+1}]} {$j < [llength $chars]} {incr j} { |
||||
set next_char [lindex $chars $j] |
||||
if {$next_char in {" " \t}} { |
||||
#end of env var name - we don't expect to see spaces within environment variable names, |
||||
#treat space as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "\""} { |
||||
#end of env var name - we don't expect to see quotes within environment variable names, |
||||
#treat quote as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "%"} { |
||||
#end of *possible* env var name |
||||
break |
||||
} else { |
||||
append env_var_name $next_char |
||||
} |
||||
} |
||||
if {$next_char eq "%"} { |
||||
#we found a closing % character, so we have a possible env var name between the two % characters. |
||||
#we will substitute the env var value if it exists, |
||||
# or the value of any single letter placeholder if there is a match, |
||||
# or the original string between the two % characters if there is no match for either an env var or a single letter placeholder. |
||||
if {[info exists ::env($env_var_name)]} { |
||||
append current_chunk $::env($env_var_name) |
||||
set got_placeholder 0 |
||||
set i $j ;#advance past the env var name and closing % character for next iteration of main loop |
||||
continue |
||||
} |
||||
} else { |
||||
#we didn't find a closing % character, so this isn't a valid env var reference. |
||||
set env_var_name "" |
||||
#fall through to single % placeholder handling below, |
||||
#which will treat the first character after the % as a single letter placeholder and include the rest of the string as literal characters in the output. |
||||
} |
||||
} |
||||
|
||||
switch -- $char { |
||||
"%" { |
||||
append current_chunk "%" |
||||
set got_placeholder 1 |
||||
continue |
||||
} |
||||
1 - |
||||
L - l { |
||||
#append current_chunk [lindex $arglist 0] |
||||
set append_value [string trim [lindex $arglist 0]] |
||||
foreach ch [split $append_value ""] { |
||||
if {$ch eq " "} { |
||||
#we need to split on spaces within arguments as well, because unquoted %1 can expand to multiple arguments if the first argument contains spaces, and we need to preserve the correct splitting of arguments in that case. |
||||
#e.g if %1 is substituted with "C:\My Documents\file.txt" then we need to split that into three items in the output list: "C:\My", "Documents\file.txt" |
||||
if {$current_chunk ne ""} { |
||||
lappend result $current_chunk |
||||
lappend quoted 0 |
||||
set current_chunk {} |
||||
} |
||||
set new_chunk 1 |
||||
} else { |
||||
append current_chunk $ch |
||||
set new_chunk 0 |
||||
} |
||||
} |
||||
} |
||||
2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { |
||||
append current_chunk [lindex $arglist $char-1] |
||||
} |
||||
D - d { |
||||
#review |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute the same value as %1 for now, |
||||
#which is what windows seems to do for file system items that have file paths. |
||||
append current_chunk [lindex $arglist 0] |
||||
} |
||||
I - i { |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute something for now. |
||||
#format seems to be 9 and 5 digits :nnnnnnnnn:nnnnn |
||||
#REVIEW! unknown consequences! |
||||
append current_chunk ":000000000:00000" |
||||
} |
||||
"*" { |
||||
#the window implementation of unquoted %* always seems to emit the previous chunk before the %* placeholder as a separate item |
||||
#in the command line, even if there is no space between them, so we will do the same. |
||||
#Note that a following string (quoted or not) immediately after the %* will be appended to the last item in the output list rather than being a separate item, |
||||
#which is also consistent with the microsoft implementation. |
||||
if {!$new_chunk} { |
||||
if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { |
||||
lappend result $current_chunk |
||||
lappend quoted 0 |
||||
set current_chunk {} |
||||
} |
||||
} |
||||
lappend result {*}[lrange $arglist 1 end] |
||||
lappend quoted {*}[lrepeat [llength $arglist] 0] |
||||
} |
||||
W - w { |
||||
append current_chunk $workingdir |
||||
} |
||||
default { |
||||
if {$type eq "expand_sz"} { |
||||
#if expand_sz we would have already scanned for environment variables in the form %VAR% and substituted them if found, |
||||
#taking precedence over single letter placeholders if there is a conflict. |
||||
append current_chunk "$char" [string range $env_var_name 1 end] ;#if env_var_name is empty string then this will just append the single char after the % as a literal, |
||||
#which is the correct behaviour for unrecognized placeholders such as %x and for invalid env var references such as %NONEXISTANT% |
||||
} else { |
||||
append current_chunk $char |
||||
} |
||||
} |
||||
} |
||||
set got_placeholder 0 |
||||
set new_chunk 0 |
||||
} else { |
||||
if {$char eq "%"} { |
||||
set got_placeholder 1 |
||||
} else { |
||||
append current_chunk $char |
||||
set new_chunk 0 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { |
||||
#review - edge case - if the command string ends with a space then we would have already added the last chunk to the result list and started a new chunk, so we shouldn't add an empty chunk to the result list in that case. |
||||
#however if the last chunk was quoted and is empty because the command string ends with a placeholder that is substituted with an empty string, then we should add the empty chunk to the result list. |
||||
lappend result $current_chunk |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
namespace eval punk::auto_exec::system { |
||||
proc assoc_get_info {ext} { |
||||
set lext [string tolower $ext] |
||||
set result [dict create system "" user ""] |
||||
set user_assoc_path [join [list HKEY_CURRENT_USER Software Microsoft Windows CurrentVersion Explorer FileExts $lext UserChoice] "\\"] |
||||
if {![catch {registry get $user_assoc_path Progid} user_choice]} { |
||||
dict set result user $user_choice |
||||
} |
||||
if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $lext] "\\"] ""} ftype]} { |
||||
dict set result system $ftype |
||||
} |
||||
return $result |
||||
} |
||||
} |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::assoc" |
||||
@cmd -name "punk::auto_exec::assoc"\ |
||||
-summary\ |
||||
"Look up the associated file type (system and user) for a file extension"\ |
||||
-help\ |
||||
"Get the associated file type for a file extension by looking up the user-specific |
||||
file type in the registry and falling back to the system file type if no |
||||
user-specific association is found. |
||||
|
||||
Returns a dict with keys ${$I}system${$NI} and ${$I}user${$NI}. |
||||
One or more of the key values may be empty string if there is no defined |
||||
file type for the extension. |
||||
|
||||
This is somewhat like the windows 'assoc' command except that the windows command |
||||
only looks up the system association and does not take into account any user-specific |
||||
overrides. |
||||
This function returns both values in the result dictionary if they are available." |
||||
@opts |
||||
@values -min 0 -max 1 |
||||
ext -type string -default "" -optional true -help\ |
||||
"File extension to look up, e.g .txt or .py" |
||||
}] |
||||
proc assoc {args} { |
||||
package require registry |
||||
set argd [punk::args::parse $args withid ::punk::auto_exec::assoc] |
||||
set ext [dict get $argd values ext] |
||||
|
||||
if {$ext ne ""} { |
||||
return [punk::auto_exec::system::assoc_get_info $ext] |
||||
} else { |
||||
#look up all associated ftypes |
||||
set user_ftypes [registry keys {HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts} .*] |
||||
|
||||
set system_ftypes [registry keys {HKEY_LOCAL_MACHINE\SOFTWARE\Classes} .*] |
||||
set all_ftypes [lsort -unique [concat $user_ftypes $system_ftypes]] |
||||
set results [list] |
||||
foreach ftype $all_ftypes { |
||||
dict set results $ftype [punk::auto_exec::system::assoc_get_info $ftype] |
||||
} |
||||
return $results |
||||
} |
||||
} |
||||
namespace eval argdoc { |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::ftype" |
||||
@cmd -name "punk::auto_exec::ftype"\ |
||||
-summary\ |
||||
"Look up shell verb command values from windows file type."\ |
||||
-help\ |
||||
"Get the associated shell verb information (such as open) for a file type by looking up the user-specific |
||||
association in the registry and falling back to the system association if no |
||||
user-specific association is found. |
||||
|
||||
Returns a dict of dicts with toplevel keys for each shell verb (e.g open, runas) and values that are dicts with keys |
||||
${$I}type${$NI} and ${$I}value${$NI} and ${$I}scope${$NI}, where |
||||
type is determined from the registry value type (e.g sz or expand_sz) |
||||
string is the raw command string from the registry |
||||
scope is either "user" or "system" depending on whether the value was found in the user-specific registry keys or |
||||
the system registry keys. |
||||
|
||||
This is somewhat like the windows 'ftype' command except that the windows command only looks for the 'open' verb and |
||||
only looks up the system association and does not take into account any user-specific |
||||
overrides. |
||||
|
||||
The file type can be looked up using the ${$B}assoc${$N} function in this package. |
||||
|
||||
The command string can contain placeholders like \"%1\" for the file name, and environment variables |
||||
in the form %VAR% (case insensitive) if the registry value type is reg_expand_sz (expand_sz), |
||||
which will be substituted by the ${$B}shell_command_as_tcl_list${$N} function when processing the command |
||||
string into a Tcl list of command and arguments with placeholders substituted." |
||||
@opts |
||||
@values -min 0 -max 1 |
||||
filetype -type string -default "" -optional true -help\ |
||||
"File type associated with a file extension, e.g Python.File. |
||||
This can be looked up using the 'assoc' function in this package." |
||||
}] |
||||
} |
||||
#proc ftype {filetype} { |
||||
# package require registry |
||||
|
||||
# if {$filetype eq "cplfile"} { |
||||
# #special case for cplfile (associated with .cpl files) which doesn't follow the usual pattern of having the command string under shell\open\command, |
||||
# #but instead has it under HKEY_LOCAL_MACHINE\SOFTWARE\Classes\cplfile\shell\cplopen\command. |
||||
# #There doesn't seem to be any user-specific override for this file type |
||||
# #- but we will check for one under HKEY_CURRENT_USER\Software\Classes\cplfile\shell\cplopen\command anyway for consistency with the way we check |
||||
# #for user-specific overrides for other file types. |
||||
# set key [join [list HKEY_CURRENT_USER Software Classes cplfile shell cplopen command] "\\"] |
||||
# } else { |
||||
# set key [join [list HKEY_CURRENT_USER Software Classes $filetype shell open command] "\\"] |
||||
# } |
||||
# if {![catch {registry get $key ""} raw_assoc]} { |
||||
# set tp [registry type $key ""] |
||||
# return [dict create open [dict create type $tp string $raw_assoc]] |
||||
# } else { |
||||
# #e.g Python.File |
||||
# if {$filetype eq "cplfile"} { |
||||
# set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes cplfile shell cplopen command] "\\"] |
||||
# } else { |
||||
# set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell open command] "\\"] |
||||
# } |
||||
# if {![catch {registry get $key ""} raw_assoc]} { |
||||
# set tp [registry type $key ""] |
||||
# return [dict create type $tp string $raw_assoc] |
||||
# } else { |
||||
# return [dict create type "" string ""] ;#no association found |
||||
# } |
||||
# } |
||||
#} |
||||
proc ftype {filetype} { |
||||
package require registry |
||||
set resultdict [dict create] |
||||
|
||||
#e.g Python.File |
||||
set shellpath [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell] "\\"] |
||||
if {![catch {registry keys $shellpath *} shellverbs]} { |
||||
foreach verb $shellverbs { |
||||
set commandkey [join [list $shellpath $verb command] "\\"] |
||||
if {![catch {registry get $commandkey ""} cmdstring]} { |
||||
#registry queryies are case insensitive but some are cased differently e.g Open vs open. |
||||
#when using the verb as a key in the output dict, we need to normalize so that it is useful for lookups. We'll use lowercase for that. |
||||
set verb [string tolower $verb] |
||||
set tp [registry type $commandkey ""] |
||||
dict set resultdict $verb [dict create type $tp value $cmdstring scope system] |
||||
} |
||||
} |
||||
} |
||||
|
||||
#allow user-specific verbs to be overridden. |
||||
set shellpath [join [list HKEY_CURRENT_USER Software Classes $filetype shell] "\\"] |
||||
if {![catch {registry keys $shellpath *} shellverbs]} { |
||||
foreach verb $shellverbs { |
||||
set commandkey [join [list $shellpath $verb command] "\\"] |
||||
if {![catch {registry get $commandkey ""} cmdstring]} { |
||||
set verb [string tolower $verb] |
||||
set tp [registry type $commandkey ""] |
||||
dict set resultdict $verb [dict create type $tp value $cmdstring scope user] |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $resultdict |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::auto_exec::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
#tcl::namespace::eval punk::auto_exec::system { |
||||
#} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval punk::auto_exec { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)punk::auto_exec" |
||||
@package -name "punk::auto_exec" -help\ |
||||
"Package |
||||
Description" |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return punk::auto_exec |
||||
} |
||||
proc about_topics {} { |
||||
#info commands results are returned in an arbitrary order (like array keys) |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
#Adjust this function or 'default_topics' if a different order is required |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
# ------------------------------------------------------------- |
||||
# get_topic_ functions add more to auto-include in about topics |
||||
# ------------------------------------------------------------- |
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package punk::auto_exec |
||||
description to come.. |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "<unspecified>" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::punk::auto_exec::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{<julian@precisium.com.au> {Julian Noble}}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_custom-topic {} { |
||||
punk::args::lib::tstr -return string { |
||||
A custom |
||||
topic |
||||
etc |
||||
} |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# we re-use the argument definition from punk::args::standard_about and override some items |
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::punk::auto_exec::about" |
||||
dict set overrides @cmd -name "punk::auto_exec::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About punk::auto_exec |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[punk::auto_exec::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [punk::auto_exec::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||
set argd [punk::args::parse $args withid ::punk::auto_exec::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::punk::auto_exec::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
# variable PUNKARGS |
||||
# variable PUNKARGS_aliases |
||||
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::auto_exec |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::auto_exec [tcl::namespace::eval punk::auto_exec { |
||||
variable pkg punk::auto_exec |
||||
variable version |
||||
set version 999999.0a1.0 |
||||
}] |
||||
return |
||||
|
||||
@ -0,0 +1,3 @@
|
||||
0.1.0 |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,786 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.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) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::auto_exec 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
#---------------------- |
||||
# registry notes |
||||
|
||||
#Computer\HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ApplicationAssociationToasts |
||||
# - associates applications/file types with extensions and protocols. |
||||
|
||||
#.cp items have a shell\cplopen\command subkey instead of shell\open\command |
||||
#- but the command string has the same format and placeholders as the shell\open\command entries for other file types, |
||||
#so we can handle them in the same way as other file types when we extract the associated command string. |
||||
|
||||
#---------------------- |
||||
|
||||
|
||||
|
||||
tcl::namespace::eval punk::auto_exec { |
||||
namespace eval argdoc { |
||||
variable PUNKARGS |
||||
set I "\x1b\[3m" ;# [a+ italic] |
||||
set NI "\x1b\[23m" ;# [a+ noitalic] |
||||
set B "\x1b\[1m" ;# [a+ bold] |
||||
set N "\x1b\[22m" ;# [a+ normal] |
||||
set T "\x1b\[1\;4m" ;# [a+ bold underline] |
||||
set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] |
||||
} |
||||
|
||||
variable PUNKARGS |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::shell_open_command" |
||||
@cmd -name "punk::auto_exec::assoc" -help\ |
||||
{Returns the raw 'open' command string associated with the file type for the given file extension, |
||||
by looking up the user-specific association in the registry and falling back to the system |
||||
association if no user-specific association is found. |
||||
|
||||
The resulting command string can contain placeholders like "%1" for the file name. |
||||
e.g .py -> "c:\Program Files\Python\python.exe" "%1" |
||||
e.g .rb -> "C:\tools\ruby31\bin\ruby.exe" "%1" %* |
||||
e.g .vbs -> "%SystemRoot%\System32\WScript.exe" "%1" %* |
||||
|
||||
Note that the resulting string has unescaped backslashes within double quotes, so it is |
||||
not suitable for direct execution by Tcl without further processing to handle the backslashes |
||||
and placeholders. |
||||
|
||||
see 'shell_command_as_tcl_list' for processing the command string into a Tcl list of command and |
||||
arguments with placeholders substituted. |
||||
} |
||||
@opts |
||||
@values -min 0 -max 1 |
||||
ext -type string -default "" -optional true -help\ |
||||
"File extension to look up, e.g .txt or .py" |
||||
}] |
||||
proc shell_open_command {ext} { |
||||
#look up assoc and ftype to find associated file type and application. |
||||
#Note that the windows 'ftype' and 'assoc' commands only examine the system's data - not the user-specific data which may override the system data. |
||||
#to get the user-specific associations we need to read the registry keys. |
||||
|
||||
#extensions in the registry seem to be stored lower case wnd with a leading dot. |
||||
set lext [string tolower $ext] |
||||
package require registry |
||||
set user_assoc_path [join [list HKEY_CURRENT_USER Software Microsoft Windows CurrentVersion Explorer FileExts $lext UserChoice] "\\"] |
||||
|
||||
#The UserChoice subkey under this key is where the user-specific association is stored when the user has made a choice. It contains a Progid value which points to the associated file type. |
||||
#It can return something like "Python.File" or "Applications\python.exe" or even tcl_auto_file (for .tcl files associated with tclsh by a tcl installer) |
||||
|
||||
set openverb "open" |
||||
|
||||
|
||||
#The UserChoice key may not exist if the user hasn't made an explicit choice, in which case we fall back to the system association which is stored under HKEY_CLASSES_ROOT\$ext (which also contains user-specific overrides but is more cumbersome to query for them) |
||||
if {![catch {registry get $user_assoc_path Progid} user_choice]} { |
||||
if {$user_choice ne ""} { |
||||
#examples such as Applications\python.exe and tcl_auto_file are found under HKEY_CURRENT_USER\Software\Classes |
||||
#they then have a sub-path shell\open\command which contains the command to open files of that type, which is what we need to extract the associated application. |
||||
#it is faster to query for the key directly within a catch than to retrieve keys as lists and iterate through them to find the one we want. |
||||
|
||||
#special case .cpl cplfile |
||||
if {$user_choice eq "cplfile"} { |
||||
set openverb "cplopen" |
||||
} |
||||
set verbinfo [ftype $user_choice] |
||||
if {[dict exists $verbinfo $openverb]} { |
||||
set ftypeinfo [dict get $verbinfo $openverb] |
||||
return [dict set ftypeinfo filetype $user_choice] |
||||
} else { |
||||
return [dict create type "notfound" value "" scope user filetype $user_choice] |
||||
} |
||||
|
||||
} else { |
||||
#review - is it possible for Progid to be empty string? If so we should probably fall back to system association instead of returning no association. |
||||
#alternatively it could mean the user has explicitly chosen to have no association for this file type - in which case returning an empty association may be the correct behaviour. |
||||
return [dict create type "empty" value "" scope user filetype ""] |
||||
} |
||||
} else { |
||||
#fall back to system association and ftype |
||||
if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $lext] "\\"] ""} ftype]} { |
||||
#ftype is the file type associated with the extension, e.g "Python.File" |
||||
#we then need to look up the command associated with this file type under the same path but with the file type instead of the extension and with the additional sub-path shell\open\command |
||||
|
||||
#special case .cpl cplfile |
||||
if {$ftype eq "cplfile"} { |
||||
set openverb "cplopen" |
||||
} |
||||
set verbinfo [ftype $ftype] |
||||
if {[dict exists $verbinfo $openverb]} { |
||||
set ftypeinfo [dict get $verbinfo $openverb] |
||||
return [dict set ftypeinfo filetype $ftype] |
||||
} else { |
||||
return [dict create type "notfound" value "" scope system filetype $ftype] |
||||
} |
||||
} else { |
||||
return [dict create type "notfound" value "" scope "" filetype ""] |
||||
} |
||||
} |
||||
#shouldn't get here - there is a return in each branch above. |
||||
return "no-result" |
||||
} |
||||
|
||||
# %1 - standard placeholder for the first file parameter. |
||||
# %L (or %l) - Long File Name form of the path. |
||||
# %* - replaces with all parameters passed to the command. (ie not including the command itself) |
||||
# %W (or %w) - working directory. |
||||
|
||||
# other placeholders that we won't handle for now: |
||||
# %I (or %i) - handle to an Item ID List (IDList) |
||||
# e.g for filetype ArchiveFolder (associated with .7z, .gz, .CPIO etc) we have "%SystemRoot%\Explorer.exe" /idlist,%I,%L |
||||
# %D (or %d) - Desktop absolute parsing name of the first parameter |
||||
# (for items that don't have file system paths) will be the same as %1 for file system items. |
||||
|
||||
#todo - we need to substitute other placeholders such as %SystemRoot% etc. (case insensitively) |
||||
# - but only if the type of the key is expand_sz. |
||||
|
||||
#These are environment variables that can be used in the command string. |
||||
#when type is sz - only the single letter placeholders are substituted, and environment variables are not substituted. |
||||
#when type is expand_sz - the single letter placeholders are substituted, and environment variables are also substituted |
||||
#(case insensitively) - but only if they are in the form %VAR% |
||||
#A matching environment variable will take precedence over a single letter placeholder if there is a conflict, |
||||
#e.g if the string is %1% and there is an environment variable named "1" then it will be substituted instead of the %1 placeholder. |
||||
#a non-existant environment variable will not be substituted and it's wrapping % characters will not be included in the output. |
||||
#similarly a single letter placeholder that is not recognised, such as %x, will result in only the x being included in the output without the leading % character. |
||||
|
||||
|
||||
#todo - tests for shell_command_as_tcl_list with various combinations of placeholders, quoted and unquoted, |
||||
#and with both reg_sz and reg_expand_sz types, and with various edge cases such as missing arguments, extra arguments, |
||||
#empty arguments, unrecognized placeholders, invalid env var references etc. |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::shell_command_as_tcl_list" |
||||
@cmd -name "punk::auto_exec::shell_command_as_tcl_list" -help\ |
||||
{} |
||||
@opts |
||||
-type -type string -default sz -choices {sz expand_sz} -help\ |
||||
"The type of the registry value containing the command string, which determines how |
||||
environment variables are substituted. sz means environment variables will not |
||||
be substituted, and expand_sz means environment variables will be substituted |
||||
if they are in the form %VAR% (case insensitively) and will take precedence over |
||||
single letter placeholders if there is a conflict. |
||||
|
||||
In either case, the single letter placeholders will be substituted as follows: |
||||
%1 - standard placeholder for the first file parameter. |
||||
%L (or %l) - Long File Name form of the path. |
||||
%* - replaced with all subsequent parameters passed to the command. |
||||
(but not including the script name itself) |
||||
%W (or %w) - working directory." |
||||
-workingdir -type string -default "" -help\ |
||||
"The working directory to substitute for the %W (or %w) placeholder." |
||||
@values -min 1 -max -1 |
||||
commandspec -type string -help\ |
||||
"The command string to process, which can contain placeholders like %1 for the file name, |
||||
and a list of arguments to substitute for the placeholders. The command string is typically |
||||
obtained from the registry for a file type association, and the arguments are typically the |
||||
file name and other parameters to substitute into the command string." |
||||
arg -type any -multiple 1 -optional 1 -help\ |
||||
{One or more arguments to substitute for the placeholders in the command string. |
||||
The first argument (often a script or document path) will be substituted for %1, |
||||
the second argument will be substituted for %2, and so on. If the command string |
||||
contains a %* placeholder, then all of the arguments will be substituted for that |
||||
placeholder starting from %2. |
||||
If there are more placeholders than arguments, then the extra placeholders will be |
||||
substituted with empty string. |
||||
If missing arguments are specified in the commandspec as quoted strings, eg "%3" then |
||||
corresponding empty strings as separate arguments will be included in the output.} |
||||
}] |
||||
proc shell_command_as_tcl_list {args} { |
||||
set argd [punk::args::parse $args withid ::punk::auto_exec::shell_command_as_tcl_list] |
||||
lassign [dict values $argd] _leaders opts values received |
||||
set type [dict get $opts -type] |
||||
set workingdir [dict get $opts -workingdir] |
||||
set commandspec [dict get $values commandspec] |
||||
if {[dict exists $received arg]} { |
||||
set arglist [dict get $values arg] |
||||
} else { |
||||
set arglist [list] |
||||
} |
||||
|
||||
set result [list] |
||||
set quoted [list 0] ;#track whether the current chunk is quoted or not. Only the last item is relevant. |
||||
|
||||
set chars [split [string trim $commandspec] ""] |
||||
set in_quote 0 |
||||
set current_chunk {} |
||||
set new_chunk 1 |
||||
set got_placeholder 0 |
||||
for {set i 0} {$i < [llength $chars]} {incr i} { |
||||
set char [lindex $chars $i] |
||||
if {$in_quote} { |
||||
if {$char eq "\""} { |
||||
if {$got_placeholder} { |
||||
#wasn't a valid placeholder - % not emitted. |
||||
set got_placeholder 0 |
||||
} |
||||
#The windows implementation doesn't seem to close off a chunk just because it encounters a closing quote, |
||||
#so we don't do that either. |
||||
#The closing quote just affects whether the next space will terminate the chunk or not. |
||||
set in_quote 0 |
||||
} else { |
||||
if {$char eq "%"} { |
||||
#we do not handle the trailing % of an env var such as %VAR% here |
||||
#- as we scan for that in the default case of the switch below. |
||||
if {$got_placeholder} { |
||||
#this is a % escaped by doubling up ie a literal % in the output |
||||
append current_chunk "%" |
||||
set got_placeholder 0 |
||||
} else { |
||||
set got_placeholder 1 |
||||
} |
||||
} elseif {$got_placeholder} { |
||||
if {$type eq "expand_sz"} { |
||||
#we scan for environment variables in the form %VAR% (case insensitively) and substitute them if found, taking precedence over single letter placeholders if there is a conflict. |
||||
#a non-existant environment variable will not be substituted and it's wrapping % characters will not be included in the output. |
||||
set env_var_name $char |
||||
for {set j [expr {$i+1}]} {$j < [llength $chars]} {incr j} { |
||||
set next_char [lindex $chars $j] |
||||
if {$next_char in {" " \t}} { |
||||
#end of env var name - we don't expect to see spaces within environment variable names, |
||||
#treat space as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "\""} { |
||||
#end of env var name - we don't expect to see quotes within environment variable names, |
||||
#treat quote as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "%"} { |
||||
#end of *possible* env var name |
||||
break |
||||
} else { |
||||
append env_var_name $next_char |
||||
} |
||||
} |
||||
if {$next_char eq "%"} { |
||||
#we found a closing % character, so we have a possible env var name between the two % characters. |
||||
#we will substitute the env var value if it exists, |
||||
# or the value of any single letter placeholder if there is a match, |
||||
# or the original string between the two % characters if there is no match for either an env var or a single letter placeholder. |
||||
if {[info exists ::env($env_var_name)]} { |
||||
append current_chunk $::env($env_var_name) |
||||
set got_placeholder 0 |
||||
set i $j ;#advance past the env var name and closing % character for next iteration of main loop |
||||
continue |
||||
} |
||||
} else { |
||||
#we didn't find a closing % character, so this isn't a valid env var reference. |
||||
set env_var_name "" |
||||
#fall through to single % placeholder handling below, |
||||
#which will treat the first character after the % as a single letter placeholder and include the rest of the string as literal characters in the output. |
||||
} |
||||
} |
||||
|
||||
switch -- $char { |
||||
1 - L - l { |
||||
append current_chunk [lindex $arglist 0] |
||||
} |
||||
2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { |
||||
append current_chunk [lindex $arglist $char-1] |
||||
} |
||||
D - d { |
||||
#review |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute the same value as %1 for now, |
||||
#which is what windows seems to do for file system items that have file paths. |
||||
append current_chunk [lindex $arglist 0] |
||||
} |
||||
I - i { |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute something for now. |
||||
#format seems to be 9 and 5 digits :nnnnnnnnn:nnnnn |
||||
#REVIEW! unknown consequences! |
||||
append current_chunk ":000000000:00000" |
||||
} |
||||
"*" { |
||||
append current_chunk [lrange $arglist 1 end] |
||||
} |
||||
W - w { |
||||
append current_chunk $workingdir |
||||
} |
||||
default { |
||||
if {$type eq "expand_sz"} { |
||||
#if expand_sz we would have already scanned for environment variables in the form %VAR% and substituted them if found, |
||||
#taking precedence over single letter placeholders if there is a conflict. |
||||
append current_chunk "$char" [string range $env_var_name 1 end] ;#if env_var_name is empty string then this will just append the single char after the % as a literal, |
||||
#which is the correct behaviour for unrecognized placeholders such as %x and for invalid env var references such as %NONEXISTANT% |
||||
} else { |
||||
append current_chunk $char |
||||
} |
||||
} |
||||
} |
||||
set got_placeholder 0 |
||||
} else { |
||||
append current_chunk $char |
||||
} |
||||
} |
||||
} else { |
||||
#NOT in quoted string |
||||
if {$char eq "\""} { |
||||
if {$got_placeholder} { |
||||
append current_chunk "%" ;#wasn't a valid placeholder char, so we need to add the % that we stripped off back into the output |
||||
set got_placeholder 0 |
||||
} |
||||
set in_quote 1 |
||||
set new_chunk 0 |
||||
lset quoted end 1 ;#we'll mark as quoted if any quote found in it - review |
||||
} elseif {$char in [list " " \t ]} { |
||||
#we don't expect to see tabs or other whitespace characters as separators in the command string, but we'll treat tab the same as spaces just in case. |
||||
if {$got_placeholder} { |
||||
#wasn't a valid placeholder char. The % is stripped and not included in the output. |
||||
set got_placeholder 0 |
||||
} |
||||
#space terminates an unquoted chunk, so we add it to the result list and start a new chunk. |
||||
#we also need to ensure that consecutive spaces are treated as a single separator and don't result in empty items in the output list, |
||||
|
||||
if {!$new_chunk} { |
||||
if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { |
||||
#we add the current chunk to the result list if it's not empty, or if it is empty but is quoted (because in that case we want to preserve it as an empty argument). |
||||
lappend result $current_chunk |
||||
lappend quoted 0 |
||||
set current_chunk {} |
||||
} |
||||
set new_chunk 1 |
||||
} |
||||
for {set j [expr {$i+1}]} {$j < [llength $chars]} {incr j} { |
||||
if {[lindex $chars $j] in {" " \t}} { |
||||
incr i |
||||
} else { |
||||
break |
||||
} |
||||
} |
||||
} else { |
||||
if {$got_placeholder} { |
||||
if {$type eq "expand_sz"} { |
||||
#we scan for environment variables in the form %VAR% (case insensitively) and substitute them if found, taking precedence over single letter placeholders if there is a conflict. |
||||
#a non-existant environment variable will not be substituted and it's wrapping % characters will not be included in the output. |
||||
set env_var_name $char |
||||
for {set j [expr {$i+1}]} {$j < [llength $chars]} {incr j} { |
||||
set next_char [lindex $chars $j] |
||||
if {$next_char in {" " \t}} { |
||||
#end of env var name - we don't expect to see spaces within environment variable names, |
||||
#treat space as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "\""} { |
||||
#end of env var name - we don't expect to see quotes within environment variable names, |
||||
#treat quote as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "%"} { |
||||
#end of *possible* env var name |
||||
break |
||||
} else { |
||||
append env_var_name $next_char |
||||
} |
||||
} |
||||
if {$next_char eq "%"} { |
||||
#we found a closing % character, so we have a possible env var name between the two % characters. |
||||
#we will substitute the env var value if it exists, |
||||
# or the value of any single letter placeholder if there is a match, |
||||
# or the original string between the two % characters if there is no match for either an env var or a single letter placeholder. |
||||
if {[info exists ::env($env_var_name)]} { |
||||
append current_chunk $::env($env_var_name) |
||||
set got_placeholder 0 |
||||
set i $j ;#advance past the env var name and closing % character for next iteration of main loop |
||||
continue |
||||
} |
||||
} else { |
||||
#we didn't find a closing % character, so this isn't a valid env var reference. |
||||
set env_var_name "" |
||||
#fall through to single % placeholder handling below, |
||||
#which will treat the first character after the % as a single letter placeholder and include the rest of the string as literal characters in the output. |
||||
} |
||||
} |
||||
|
||||
switch -- $char { |
||||
"%" { |
||||
append current_chunk "%" |
||||
set got_placeholder 1 |
||||
continue |
||||
} |
||||
1 - |
||||
L - l { |
||||
#append current_chunk [lindex $arglist 0] |
||||
set append_value [string trim [lindex $arglist 0]] |
||||
foreach ch [split $append_value ""] { |
||||
if {$ch eq " "} { |
||||
#we need to split on spaces within arguments as well, because unquoted %1 can expand to multiple arguments if the first argument contains spaces, and we need to preserve the correct splitting of arguments in that case. |
||||
#e.g if %1 is substituted with "C:\My Documents\file.txt" then we need to split that into three items in the output list: "C:\My", "Documents\file.txt" |
||||
if {$current_chunk ne ""} { |
||||
lappend result $current_chunk |
||||
lappend quoted 0 |
||||
set current_chunk {} |
||||
} |
||||
set new_chunk 1 |
||||
} else { |
||||
append current_chunk $ch |
||||
set new_chunk 0 |
||||
} |
||||
} |
||||
} |
||||
2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { |
||||
append current_chunk [lindex $arglist $char-1] |
||||
} |
||||
D - d { |
||||
#review |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute the same value as %1 for now, |
||||
#which is what windows seems to do for file system items that have file paths. |
||||
append current_chunk [lindex $arglist 0] |
||||
} |
||||
I - i { |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute something for now. |
||||
#format seems to be 9 and 5 digits :nnnnnnnnn:nnnnn |
||||
#REVIEW! unknown consequences! |
||||
append current_chunk ":000000000:00000" |
||||
} |
||||
"*" { |
||||
#the window implementation of unquoted %* always seems to emit the previous chunk before the %* placeholder as a separate item |
||||
#in the command line, even if there is no space between them, so we will do the same. |
||||
#Note that a following string (quoted or not) immediately after the %* will be appended to the last item in the output list rather than being a separate item, |
||||
#which is also consistent with the microsoft implementation. |
||||
if {!$new_chunk} { |
||||
if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { |
||||
lappend result $current_chunk |
||||
lappend quoted 0 |
||||
set current_chunk {} |
||||
} |
||||
} |
||||
lappend result {*}[lrange $arglist 1 end] |
||||
lappend quoted {*}[lrepeat [llength $arglist] 0] |
||||
} |
||||
W - w { |
||||
append current_chunk $workingdir |
||||
} |
||||
default { |
||||
if {$type eq "expand_sz"} { |
||||
#if expand_sz we would have already scanned for environment variables in the form %VAR% and substituted them if found, |
||||
#taking precedence over single letter placeholders if there is a conflict. |
||||
append current_chunk "$char" [string range $env_var_name 1 end] ;#if env_var_name is empty string then this will just append the single char after the % as a literal, |
||||
#which is the correct behaviour for unrecognized placeholders such as %x and for invalid env var references such as %NONEXISTANT% |
||||
} else { |
||||
append current_chunk $char |
||||
} |
||||
} |
||||
} |
||||
set got_placeholder 0 |
||||
set new_chunk 0 |
||||
} else { |
||||
if {$char eq "%"} { |
||||
set got_placeholder 1 |
||||
} else { |
||||
append current_chunk $char |
||||
set new_chunk 0 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { |
||||
#review - edge case - if the command string ends with a space then we would have already added the last chunk to the result list and started a new chunk, so we shouldn't add an empty chunk to the result list in that case. |
||||
#however if the last chunk was quoted and is empty because the command string ends with a placeholder that is substituted with an empty string, then we should add the empty chunk to the result list. |
||||
lappend result $current_chunk |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
namespace eval punk::auto_exec::system { |
||||
proc assoc_get_info {ext} { |
||||
set lext [string tolower $ext] |
||||
set result [dict create system "" user ""] |
||||
set user_assoc_path [join [list HKEY_CURRENT_USER Software Microsoft Windows CurrentVersion Explorer FileExts $lext UserChoice] "\\"] |
||||
if {![catch {registry get $user_assoc_path Progid} user_choice]} { |
||||
dict set result user $user_choice |
||||
} |
||||
if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $lext] "\\"] ""} ftype]} { |
||||
dict set result system $ftype |
||||
} |
||||
return $result |
||||
} |
||||
} |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::assoc" |
||||
@cmd -name "punk::auto_exec::assoc"\ |
||||
-summary\ |
||||
"Look up the associated file type (system and user) for a file extension"\ |
||||
-help\ |
||||
"Get the associated file type for a file extension by looking up the user-specific |
||||
file type in the registry and falling back to the system file type if no |
||||
user-specific association is found. |
||||
|
||||
Returns a dict with keys ${$I}system${$NI} and ${$I}user${$NI}. |
||||
One or more of the key values may be empty string if there is no defined |
||||
file type for the extension. |
||||
|
||||
This is somewhat like the windows 'assoc' command except that the windows command |
||||
only looks up the system association and does not take into account any user-specific |
||||
overrides. |
||||
This function returns both values in the result dictionary if they are available." |
||||
@opts |
||||
@values -min 0 -max 1 |
||||
ext -type string -default "" -optional true -help\ |
||||
"File extension to look up, e.g .txt or .py" |
||||
}] |
||||
proc assoc {args} { |
||||
package require registry |
||||
set argd [punk::args::parse $args withid ::punk::auto_exec::assoc] |
||||
set ext [dict get $argd values ext] |
||||
|
||||
if {$ext ne ""} { |
||||
return [punk::auto_exec::system::assoc_get_info $ext] |
||||
} else { |
||||
#look up all associated ftypes |
||||
set user_ftypes [registry keys {HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts} .*] |
||||
|
||||
set system_ftypes [registry keys {HKEY_LOCAL_MACHINE\SOFTWARE\Classes} .*] |
||||
set all_ftypes [lsort -unique [concat $user_ftypes $system_ftypes]] |
||||
set results [list] |
||||
foreach ftype $all_ftypes { |
||||
dict set results $ftype [punk::auto_exec::system::assoc_get_info $ftype] |
||||
} |
||||
return $results |
||||
} |
||||
} |
||||
namespace eval argdoc { |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::ftype" |
||||
@cmd -name "punk::auto_exec::ftype"\ |
||||
-summary\ |
||||
"Look up shell verb command values from windows file type."\ |
||||
-help\ |
||||
"Get the associated shell verb information (such as open) for a file type by looking up the user-specific |
||||
association in the registry and falling back to the system association if no |
||||
user-specific association is found. |
||||
|
||||
Returns a dict of dicts with toplevel keys for each shell verb (e.g open, runas) and values that are dicts with keys |
||||
${$I}type${$NI} and ${$I}value${$NI} and ${$I}scope${$NI}, where |
||||
type is determined from the registry value type (e.g sz or expand_sz) |
||||
string is the raw command string from the registry |
||||
scope is either "user" or "system" depending on whether the value was found in the user-specific registry keys or |
||||
the system registry keys. |
||||
|
||||
This is somewhat like the windows 'ftype' command except that the windows command only looks for the 'open' verb and |
||||
only looks up the system association and does not take into account any user-specific |
||||
overrides. |
||||
|
||||
The file type can be looked up using the ${$B}assoc${$N} function in this package. |
||||
|
||||
The command string can contain placeholders like \"%1\" for the file name, and environment variables |
||||
in the form %VAR% (case insensitive) if the registry value type is reg_expand_sz (expand_sz), |
||||
which will be substituted by the ${$B}shell_command_as_tcl_list${$N} function when processing the command |
||||
string into a Tcl list of command and arguments with placeholders substituted." |
||||
@opts |
||||
@values -min 0 -max 1 |
||||
filetype -type string -default "" -optional true -help\ |
||||
"File type associated with a file extension, e.g Python.File. |
||||
This can be looked up using the 'assoc' function in this package." |
||||
}] |
||||
} |
||||
#proc ftype {filetype} { |
||||
# package require registry |
||||
|
||||
# if {$filetype eq "cplfile"} { |
||||
# #special case for cplfile (associated with .cpl files) which doesn't follow the usual pattern of having the command string under shell\open\command, |
||||
# #but instead has it under HKEY_LOCAL_MACHINE\SOFTWARE\Classes\cplfile\shell\cplopen\command. |
||||
# #There doesn't seem to be any user-specific override for this file type |
||||
# #- but we will check for one under HKEY_CURRENT_USER\Software\Classes\cplfile\shell\cplopen\command anyway for consistency with the way we check |
||||
# #for user-specific overrides for other file types. |
||||
# set key [join [list HKEY_CURRENT_USER Software Classes cplfile shell cplopen command] "\\"] |
||||
# } else { |
||||
# set key [join [list HKEY_CURRENT_USER Software Classes $filetype shell open command] "\\"] |
||||
# } |
||||
# if {![catch {registry get $key ""} raw_assoc]} { |
||||
# set tp [registry type $key ""] |
||||
# return [dict create open [dict create type $tp string $raw_assoc]] |
||||
# } else { |
||||
# #e.g Python.File |
||||
# if {$filetype eq "cplfile"} { |
||||
# set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes cplfile shell cplopen command] "\\"] |
||||
# } else { |
||||
# set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell open command] "\\"] |
||||
# } |
||||
# if {![catch {registry get $key ""} raw_assoc]} { |
||||
# set tp [registry type $key ""] |
||||
# return [dict create type $tp string $raw_assoc] |
||||
# } else { |
||||
# return [dict create type "" string ""] ;#no association found |
||||
# } |
||||
# } |
||||
#} |
||||
proc ftype {filetype} { |
||||
package require registry |
||||
set resultdict [dict create] |
||||
|
||||
#e.g Python.File |
||||
set shellpath [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell] "\\"] |
||||
if {![catch {registry keys $shellpath *} shellverbs]} { |
||||
foreach verb $shellverbs { |
||||
set commandkey [join [list $shellpath $verb command] "\\"] |
||||
if {![catch {registry get $commandkey ""} cmdstring]} { |
||||
#registry queryies are case insensitive but some are cased differently e.g Open vs open. |
||||
#when using the verb as a key in the output dict, we need to normalize so that it is useful for lookups. We'll use lowercase for that. |
||||
set verb [string tolower $verb] |
||||
set tp [registry type $commandkey ""] |
||||
dict set resultdict $verb [dict create type $tp value $cmdstring scope system] |
||||
} |
||||
} |
||||
} |
||||
|
||||
#allow user-specific verbs to be overridden. |
||||
set shellpath [join [list HKEY_CURRENT_USER Software Classes $filetype shell] "\\"] |
||||
if {![catch {registry keys $shellpath *} shellverbs]} { |
||||
foreach verb $shellverbs { |
||||
set commandkey [join [list $shellpath $verb command] "\\"] |
||||
if {![catch {registry get $commandkey ""} cmdstring]} { |
||||
set verb [string tolower $verb] |
||||
set tp [registry type $commandkey ""] |
||||
dict set resultdict $verb [dict create type $tp value $cmdstring scope user] |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $resultdict |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::auto_exec::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
#tcl::namespace::eval punk::auto_exec::system { |
||||
#} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval punk::auto_exec { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)punk::auto_exec" |
||||
@package -name "punk::auto_exec" -help\ |
||||
"Package |
||||
Description" |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return punk::auto_exec |
||||
} |
||||
proc about_topics {} { |
||||
#info commands results are returned in an arbitrary order (like array keys) |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
#Adjust this function or 'default_topics' if a different order is required |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
# ------------------------------------------------------------- |
||||
# get_topic_ functions add more to auto-include in about topics |
||||
# ------------------------------------------------------------- |
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package punk::auto_exec |
||||
description to come.. |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "<unspecified>" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::punk::auto_exec::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{<julian@precisium.com.au> {Julian Noble}}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_custom-topic {} { |
||||
punk::args::lib::tstr -return string { |
||||
A custom |
||||
topic |
||||
etc |
||||
} |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# we re-use the argument definition from punk::args::standard_about and override some items |
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::punk::auto_exec::about" |
||||
dict set overrides @cmd -name "punk::auto_exec::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About punk::auto_exec |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[punk::auto_exec::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [punk::auto_exec::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||
set argd [punk::args::parse $args withid ::punk::auto_exec::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::punk::auto_exec::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
# variable PUNKARGS |
||||
# variable PUNKARGS_aliases |
||||
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::auto_exec |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::auto_exec [tcl::namespace::eval punk::auto_exec { |
||||
variable pkg punk::auto_exec |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,786 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.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) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::auto_exec 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
#---------------------- |
||||
# registry notes |
||||
|
||||
#Computer\HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ApplicationAssociationToasts |
||||
# - associates applications/file types with extensions and protocols. |
||||
|
||||
#.cp items have a shell\cplopen\command subkey instead of shell\open\command |
||||
#- but the command string has the same format and placeholders as the shell\open\command entries for other file types, |
||||
#so we can handle them in the same way as other file types when we extract the associated command string. |
||||
|
||||
#---------------------- |
||||
|
||||
|
||||
|
||||
tcl::namespace::eval punk::auto_exec { |
||||
namespace eval argdoc { |
||||
variable PUNKARGS |
||||
set I "\x1b\[3m" ;# [a+ italic] |
||||
set NI "\x1b\[23m" ;# [a+ noitalic] |
||||
set B "\x1b\[1m" ;# [a+ bold] |
||||
set N "\x1b\[22m" ;# [a+ normal] |
||||
set T "\x1b\[1\;4m" ;# [a+ bold underline] |
||||
set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] |
||||
} |
||||
|
||||
variable PUNKARGS |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::shell_open_command" |
||||
@cmd -name "punk::auto_exec::assoc" -help\ |
||||
{Returns the raw 'open' command string associated with the file type for the given file extension, |
||||
by looking up the user-specific association in the registry and falling back to the system |
||||
association if no user-specific association is found. |
||||
|
||||
The resulting command string can contain placeholders like "%1" for the file name. |
||||
e.g .py -> "c:\Program Files\Python\python.exe" "%1" |
||||
e.g .rb -> "C:\tools\ruby31\bin\ruby.exe" "%1" %* |
||||
e.g .vbs -> "%SystemRoot%\System32\WScript.exe" "%1" %* |
||||
|
||||
Note that the resulting string has unescaped backslashes within double quotes, so it is |
||||
not suitable for direct execution by Tcl without further processing to handle the backslashes |
||||
and placeholders. |
||||
|
||||
see 'shell_command_as_tcl_list' for processing the command string into a Tcl list of command and |
||||
arguments with placeholders substituted. |
||||
} |
||||
@opts |
||||
@values -min 0 -max 1 |
||||
ext -type string -default "" -optional true -help\ |
||||
"File extension to look up, e.g .txt or .py" |
||||
}] |
||||
proc shell_open_command {ext} { |
||||
#look up assoc and ftype to find associated file type and application. |
||||
#Note that the windows 'ftype' and 'assoc' commands only examine the system's data - not the user-specific data which may override the system data. |
||||
#to get the user-specific associations we need to read the registry keys. |
||||
|
||||
#extensions in the registry seem to be stored lower case wnd with a leading dot. |
||||
set lext [string tolower $ext] |
||||
package require registry |
||||
set user_assoc_path [join [list HKEY_CURRENT_USER Software Microsoft Windows CurrentVersion Explorer FileExts $lext UserChoice] "\\"] |
||||
|
||||
#The UserChoice subkey under this key is where the user-specific association is stored when the user has made a choice. It contains a Progid value which points to the associated file type. |
||||
#It can return something like "Python.File" or "Applications\python.exe" or even tcl_auto_file (for .tcl files associated with tclsh by a tcl installer) |
||||
|
||||
set openverb "open" |
||||
|
||||
|
||||
#The UserChoice key may not exist if the user hasn't made an explicit choice, in which case we fall back to the system association which is stored under HKEY_CLASSES_ROOT\$ext (which also contains user-specific overrides but is more cumbersome to query for them) |
||||
if {![catch {registry get $user_assoc_path Progid} user_choice]} { |
||||
if {$user_choice ne ""} { |
||||
#examples such as Applications\python.exe and tcl_auto_file are found under HKEY_CURRENT_USER\Software\Classes |
||||
#they then have a sub-path shell\open\command which contains the command to open files of that type, which is what we need to extract the associated application. |
||||
#it is faster to query for the key directly within a catch than to retrieve keys as lists and iterate through them to find the one we want. |
||||
|
||||
#special case .cpl cplfile |
||||
if {$user_choice eq "cplfile"} { |
||||
set openverb "cplopen" |
||||
} |
||||
set verbinfo [ftype $user_choice] |
||||
if {[dict exists $verbinfo $openverb]} { |
||||
set ftypeinfo [dict get $verbinfo $openverb] |
||||
return [dict set ftypeinfo filetype $user_choice] |
||||
} else { |
||||
return [dict create type "notfound" value "" scope user filetype $user_choice] |
||||
} |
||||
|
||||
} else { |
||||
#review - is it possible for Progid to be empty string? If so we should probably fall back to system association instead of returning no association. |
||||
#alternatively it could mean the user has explicitly chosen to have no association for this file type - in which case returning an empty association may be the correct behaviour. |
||||
return [dict create type "empty" value "" scope user filetype ""] |
||||
} |
||||
} else { |
||||
#fall back to system association and ftype |
||||
if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $lext] "\\"] ""} ftype]} { |
||||
#ftype is the file type associated with the extension, e.g "Python.File" |
||||
#we then need to look up the command associated with this file type under the same path but with the file type instead of the extension and with the additional sub-path shell\open\command |
||||
|
||||
#special case .cpl cplfile |
||||
if {$ftype eq "cplfile"} { |
||||
set openverb "cplopen" |
||||
} |
||||
set verbinfo [ftype $ftype] |
||||
if {[dict exists $verbinfo $openverb]} { |
||||
set ftypeinfo [dict get $verbinfo $openverb] |
||||
return [dict set ftypeinfo filetype $ftype] |
||||
} else { |
||||
return [dict create type "notfound" value "" scope system filetype $ftype] |
||||
} |
||||
} else { |
||||
return [dict create type "notfound" value "" scope "" filetype ""] |
||||
} |
||||
} |
||||
#shouldn't get here - there is a return in each branch above. |
||||
return "no-result" |
||||
} |
||||
|
||||
# %1 - standard placeholder for the first file parameter. |
||||
# %L (or %l) - Long File Name form of the path. |
||||
# %* - replaces with all parameters passed to the command. (ie not including the command itself) |
||||
# %W (or %w) - working directory. |
||||
|
||||
# other placeholders that we won't handle for now: |
||||
# %I (or %i) - handle to an Item ID List (IDList) |
||||
# e.g for filetype ArchiveFolder (associated with .7z, .gz, .CPIO etc) we have "%SystemRoot%\Explorer.exe" /idlist,%I,%L |
||||
# %D (or %d) - Desktop absolute parsing name of the first parameter |
||||
# (for items that don't have file system paths) will be the same as %1 for file system items. |
||||
|
||||
#todo - we need to substitute other placeholders such as %SystemRoot% etc. (case insensitively) |
||||
# - but only if the type of the key is expand_sz. |
||||
|
||||
#These are environment variables that can be used in the command string. |
||||
#when type is sz - only the single letter placeholders are substituted, and environment variables are not substituted. |
||||
#when type is expand_sz - the single letter placeholders are substituted, and environment variables are also substituted |
||||
#(case insensitively) - but only if they are in the form %VAR% |
||||
#A matching environment variable will take precedence over a single letter placeholder if there is a conflict, |
||||
#e.g if the string is %1% and there is an environment variable named "1" then it will be substituted instead of the %1 placeholder. |
||||
#a non-existant environment variable will not be substituted and it's wrapping % characters will not be included in the output. |
||||
#similarly a single letter placeholder that is not recognised, such as %x, will result in only the x being included in the output without the leading % character. |
||||
|
||||
|
||||
#todo - tests for shell_command_as_tcl_list with various combinations of placeholders, quoted and unquoted, |
||||
#and with both reg_sz and reg_expand_sz types, and with various edge cases such as missing arguments, extra arguments, |
||||
#empty arguments, unrecognized placeholders, invalid env var references etc. |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::shell_command_as_tcl_list" |
||||
@cmd -name "punk::auto_exec::shell_command_as_tcl_list" -help\ |
||||
{} |
||||
@opts |
||||
-type -type string -default sz -choices {sz expand_sz} -help\ |
||||
"The type of the registry value containing the command string, which determines how |
||||
environment variables are substituted. sz means environment variables will not |
||||
be substituted, and expand_sz means environment variables will be substituted |
||||
if they are in the form %VAR% (case insensitively) and will take precedence over |
||||
single letter placeholders if there is a conflict. |
||||
|
||||
In either case, the single letter placeholders will be substituted as follows: |
||||
%1 - standard placeholder for the first file parameter. |
||||
%L (or %l) - Long File Name form of the path. |
||||
%* - replaced with all subsequent parameters passed to the command. |
||||
(but not including the script name itself) |
||||
%W (or %w) - working directory." |
||||
-workingdir -type string -default "" -help\ |
||||
"The working directory to substitute for the %W (or %w) placeholder." |
||||
@values -min 1 -max -1 |
||||
commandspec -type string -help\ |
||||
"The command string to process, which can contain placeholders like %1 for the file name, |
||||
and a list of arguments to substitute for the placeholders. The command string is typically |
||||
obtained from the registry for a file type association, and the arguments are typically the |
||||
file name and other parameters to substitute into the command string." |
||||
arg -type any -multiple 1 -optional 1 -help\ |
||||
{One or more arguments to substitute for the placeholders in the command string. |
||||
The first argument (often a script or document path) will be substituted for %1, |
||||
the second argument will be substituted for %2, and so on. If the command string |
||||
contains a %* placeholder, then all of the arguments will be substituted for that |
||||
placeholder starting from %2. |
||||
If there are more placeholders than arguments, then the extra placeholders will be |
||||
substituted with empty string. |
||||
If missing arguments are specified in the commandspec as quoted strings, eg "%3" then |
||||
corresponding empty strings as separate arguments will be included in the output.} |
||||
}] |
||||
proc shell_command_as_tcl_list {args} { |
||||
set argd [punk::args::parse $args withid ::punk::auto_exec::shell_command_as_tcl_list] |
||||
lassign [dict values $argd] _leaders opts values received |
||||
set type [dict get $opts -type] |
||||
set workingdir [dict get $opts -workingdir] |
||||
set commandspec [dict get $values commandspec] |
||||
if {[dict exists $received arg]} { |
||||
set arglist [dict get $values arg] |
||||
} else { |
||||
set arglist [list] |
||||
} |
||||
|
||||
set result [list] |
||||
set quoted [list 0] ;#track whether the current chunk is quoted or not. Only the last item is relevant. |
||||
|
||||
set chars [split [string trim $commandspec] ""] |
||||
set in_quote 0 |
||||
set current_chunk {} |
||||
set new_chunk 1 |
||||
set got_placeholder 0 |
||||
for {set i 0} {$i < [llength $chars]} {incr i} { |
||||
set char [lindex $chars $i] |
||||
if {$in_quote} { |
||||
if {$char eq "\""} { |
||||
if {$got_placeholder} { |
||||
#wasn't a valid placeholder - % not emitted. |
||||
set got_placeholder 0 |
||||
} |
||||
#The windows implementation doesn't seem to close off a chunk just because it encounters a closing quote, |
||||
#so we don't do that either. |
||||
#The closing quote just affects whether the next space will terminate the chunk or not. |
||||
set in_quote 0 |
||||
} else { |
||||
if {$char eq "%"} { |
||||
#we do not handle the trailing % of an env var such as %VAR% here |
||||
#- as we scan for that in the default case of the switch below. |
||||
if {$got_placeholder} { |
||||
#this is a % escaped by doubling up ie a literal % in the output |
||||
append current_chunk "%" |
||||
set got_placeholder 0 |
||||
} else { |
||||
set got_placeholder 1 |
||||
} |
||||
} elseif {$got_placeholder} { |
||||
if {$type eq "expand_sz"} { |
||||
#we scan for environment variables in the form %VAR% (case insensitively) and substitute them if found, taking precedence over single letter placeholders if there is a conflict. |
||||
#a non-existant environment variable will not be substituted and it's wrapping % characters will not be included in the output. |
||||
set env_var_name $char |
||||
for {set j [expr {$i+1}]} {$j < [llength $chars]} {incr j} { |
||||
set next_char [lindex $chars $j] |
||||
if {$next_char in {" " \t}} { |
||||
#end of env var name - we don't expect to see spaces within environment variable names, |
||||
#treat space as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "\""} { |
||||
#end of env var name - we don't expect to see quotes within environment variable names, |
||||
#treat quote as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "%"} { |
||||
#end of *possible* env var name |
||||
break |
||||
} else { |
||||
append env_var_name $next_char |
||||
} |
||||
} |
||||
if {$next_char eq "%"} { |
||||
#we found a closing % character, so we have a possible env var name between the two % characters. |
||||
#we will substitute the env var value if it exists, |
||||
# or the value of any single letter placeholder if there is a match, |
||||
# or the original string between the two % characters if there is no match for either an env var or a single letter placeholder. |
||||
if {[info exists ::env($env_var_name)]} { |
||||
append current_chunk $::env($env_var_name) |
||||
set got_placeholder 0 |
||||
set i $j ;#advance past the env var name and closing % character for next iteration of main loop |
||||
continue |
||||
} |
||||
} else { |
||||
#we didn't find a closing % character, so this isn't a valid env var reference. |
||||
set env_var_name "" |
||||
#fall through to single % placeholder handling below, |
||||
#which will treat the first character after the % as a single letter placeholder and include the rest of the string as literal characters in the output. |
||||
} |
||||
} |
||||
|
||||
switch -- $char { |
||||
1 - L - l { |
||||
append current_chunk [lindex $arglist 0] |
||||
} |
||||
2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { |
||||
append current_chunk [lindex $arglist $char-1] |
||||
} |
||||
D - d { |
||||
#review |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute the same value as %1 for now, |
||||
#which is what windows seems to do for file system items that have file paths. |
||||
append current_chunk [lindex $arglist 0] |
||||
} |
||||
I - i { |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute something for now. |
||||
#format seems to be 9 and 5 digits :nnnnnnnnn:nnnnn |
||||
#REVIEW! unknown consequences! |
||||
append current_chunk ":000000000:00000" |
||||
} |
||||
"*" { |
||||
append current_chunk [lrange $arglist 1 end] |
||||
} |
||||
W - w { |
||||
append current_chunk $workingdir |
||||
} |
||||
default { |
||||
if {$type eq "expand_sz"} { |
||||
#if expand_sz we would have already scanned for environment variables in the form %VAR% and substituted them if found, |
||||
#taking precedence over single letter placeholders if there is a conflict. |
||||
append current_chunk "$char" [string range $env_var_name 1 end] ;#if env_var_name is empty string then this will just append the single char after the % as a literal, |
||||
#which is the correct behaviour for unrecognized placeholders such as %x and for invalid env var references such as %NONEXISTANT% |
||||
} else { |
||||
append current_chunk $char |
||||
} |
||||
} |
||||
} |
||||
set got_placeholder 0 |
||||
} else { |
||||
append current_chunk $char |
||||
} |
||||
} |
||||
} else { |
||||
#NOT in quoted string |
||||
if {$char eq "\""} { |
||||
if {$got_placeholder} { |
||||
append current_chunk "%" ;#wasn't a valid placeholder char, so we need to add the % that we stripped off back into the output |
||||
set got_placeholder 0 |
||||
} |
||||
set in_quote 1 |
||||
set new_chunk 0 |
||||
lset quoted end 1 ;#we'll mark as quoted if any quote found in it - review |
||||
} elseif {$char in [list " " \t ]} { |
||||
#we don't expect to see tabs or other whitespace characters as separators in the command string, but we'll treat tab the same as spaces just in case. |
||||
if {$got_placeholder} { |
||||
#wasn't a valid placeholder char. The % is stripped and not included in the output. |
||||
set got_placeholder 0 |
||||
} |
||||
#space terminates an unquoted chunk, so we add it to the result list and start a new chunk. |
||||
#we also need to ensure that consecutive spaces are treated as a single separator and don't result in empty items in the output list, |
||||
|
||||
if {!$new_chunk} { |
||||
if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { |
||||
#we add the current chunk to the result list if it's not empty, or if it is empty but is quoted (because in that case we want to preserve it as an empty argument). |
||||
lappend result $current_chunk |
||||
lappend quoted 0 |
||||
set current_chunk {} |
||||
} |
||||
set new_chunk 1 |
||||
} |
||||
for {set j [expr {$i+1}]} {$j < [llength $chars]} {incr j} { |
||||
if {[lindex $chars $j] in {" " \t}} { |
||||
incr i |
||||
} else { |
||||
break |
||||
} |
||||
} |
||||
} else { |
||||
if {$got_placeholder} { |
||||
if {$type eq "expand_sz"} { |
||||
#we scan for environment variables in the form %VAR% (case insensitively) and substitute them if found, taking precedence over single letter placeholders if there is a conflict. |
||||
#a non-existant environment variable will not be substituted and it's wrapping % characters will not be included in the output. |
||||
set env_var_name $char |
||||
for {set j [expr {$i+1}]} {$j < [llength $chars]} {incr j} { |
||||
set next_char [lindex $chars $j] |
||||
if {$next_char in {" " \t}} { |
||||
#end of env var name - we don't expect to see spaces within environment variable names, |
||||
#treat space as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "\""} { |
||||
#end of env var name - we don't expect to see quotes within environment variable names, |
||||
#treat quote as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "%"} { |
||||
#end of *possible* env var name |
||||
break |
||||
} else { |
||||
append env_var_name $next_char |
||||
} |
||||
} |
||||
if {$next_char eq "%"} { |
||||
#we found a closing % character, so we have a possible env var name between the two % characters. |
||||
#we will substitute the env var value if it exists, |
||||
# or the value of any single letter placeholder if there is a match, |
||||
# or the original string between the two % characters if there is no match for either an env var or a single letter placeholder. |
||||
if {[info exists ::env($env_var_name)]} { |
||||
append current_chunk $::env($env_var_name) |
||||
set got_placeholder 0 |
||||
set i $j ;#advance past the env var name and closing % character for next iteration of main loop |
||||
continue |
||||
} |
||||
} else { |
||||
#we didn't find a closing % character, so this isn't a valid env var reference. |
||||
set env_var_name "" |
||||
#fall through to single % placeholder handling below, |
||||
#which will treat the first character after the % as a single letter placeholder and include the rest of the string as literal characters in the output. |
||||
} |
||||
} |
||||
|
||||
switch -- $char { |
||||
"%" { |
||||
append current_chunk "%" |
||||
set got_placeholder 1 |
||||
continue |
||||
} |
||||
1 - |
||||
L - l { |
||||
#append current_chunk [lindex $arglist 0] |
||||
set append_value [string trim [lindex $arglist 0]] |
||||
foreach ch [split $append_value ""] { |
||||
if {$ch eq " "} { |
||||
#we need to split on spaces within arguments as well, because unquoted %1 can expand to multiple arguments if the first argument contains spaces, and we need to preserve the correct splitting of arguments in that case. |
||||
#e.g if %1 is substituted with "C:\My Documents\file.txt" then we need to split that into three items in the output list: "C:\My", "Documents\file.txt" |
||||
if {$current_chunk ne ""} { |
||||
lappend result $current_chunk |
||||
lappend quoted 0 |
||||
set current_chunk {} |
||||
} |
||||
set new_chunk 1 |
||||
} else { |
||||
append current_chunk $ch |
||||
set new_chunk 0 |
||||
} |
||||
} |
||||
} |
||||
2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { |
||||
append current_chunk [lindex $arglist $char-1] |
||||
} |
||||
D - d { |
||||
#review |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute the same value as %1 for now, |
||||
#which is what windows seems to do for file system items that have file paths. |
||||
append current_chunk [lindex $arglist 0] |
||||
} |
||||
I - i { |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute something for now. |
||||
#format seems to be 9 and 5 digits :nnnnnnnnn:nnnnn |
||||
#REVIEW! unknown consequences! |
||||
append current_chunk ":000000000:00000" |
||||
} |
||||
"*" { |
||||
#the window implementation of unquoted %* always seems to emit the previous chunk before the %* placeholder as a separate item |
||||
#in the command line, even if there is no space between them, so we will do the same. |
||||
#Note that a following string (quoted or not) immediately after the %* will be appended to the last item in the output list rather than being a separate item, |
||||
#which is also consistent with the microsoft implementation. |
||||
if {!$new_chunk} { |
||||
if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { |
||||
lappend result $current_chunk |
||||
lappend quoted 0 |
||||
set current_chunk {} |
||||
} |
||||
} |
||||
lappend result {*}[lrange $arglist 1 end] |
||||
lappend quoted {*}[lrepeat [llength $arglist] 0] |
||||
} |
||||
W - w { |
||||
append current_chunk $workingdir |
||||
} |
||||
default { |
||||
if {$type eq "expand_sz"} { |
||||
#if expand_sz we would have already scanned for environment variables in the form %VAR% and substituted them if found, |
||||
#taking precedence over single letter placeholders if there is a conflict. |
||||
append current_chunk "$char" [string range $env_var_name 1 end] ;#if env_var_name is empty string then this will just append the single char after the % as a literal, |
||||
#which is the correct behaviour for unrecognized placeholders such as %x and for invalid env var references such as %NONEXISTANT% |
||||
} else { |
||||
append current_chunk $char |
||||
} |
||||
} |
||||
} |
||||
set got_placeholder 0 |
||||
set new_chunk 0 |
||||
} else { |
||||
if {$char eq "%"} { |
||||
set got_placeholder 1 |
||||
} else { |
||||
append current_chunk $char |
||||
set new_chunk 0 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { |
||||
#review - edge case - if the command string ends with a space then we would have already added the last chunk to the result list and started a new chunk, so we shouldn't add an empty chunk to the result list in that case. |
||||
#however if the last chunk was quoted and is empty because the command string ends with a placeholder that is substituted with an empty string, then we should add the empty chunk to the result list. |
||||
lappend result $current_chunk |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
namespace eval punk::auto_exec::system { |
||||
proc assoc_get_info {ext} { |
||||
set lext [string tolower $ext] |
||||
set result [dict create system "" user ""] |
||||
set user_assoc_path [join [list HKEY_CURRENT_USER Software Microsoft Windows CurrentVersion Explorer FileExts $lext UserChoice] "\\"] |
||||
if {![catch {registry get $user_assoc_path Progid} user_choice]} { |
||||
dict set result user $user_choice |
||||
} |
||||
if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $lext] "\\"] ""} ftype]} { |
||||
dict set result system $ftype |
||||
} |
||||
return $result |
||||
} |
||||
} |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::assoc" |
||||
@cmd -name "punk::auto_exec::assoc"\ |
||||
-summary\ |
||||
"Look up the associated file type (system and user) for a file extension"\ |
||||
-help\ |
||||
"Get the associated file type for a file extension by looking up the user-specific |
||||
file type in the registry and falling back to the system file type if no |
||||
user-specific association is found. |
||||
|
||||
Returns a dict with keys ${$I}system${$NI} and ${$I}user${$NI}. |
||||
One or more of the key values may be empty string if there is no defined |
||||
file type for the extension. |
||||
|
||||
This is somewhat like the windows 'assoc' command except that the windows command |
||||
only looks up the system association and does not take into account any user-specific |
||||
overrides. |
||||
This function returns both values in the result dictionary if they are available." |
||||
@opts |
||||
@values -min 0 -max 1 |
||||
ext -type string -default "" -optional true -help\ |
||||
"File extension to look up, e.g .txt or .py" |
||||
}] |
||||
proc assoc {args} { |
||||
package require registry |
||||
set argd [punk::args::parse $args withid ::punk::auto_exec::assoc] |
||||
set ext [dict get $argd values ext] |
||||
|
||||
if {$ext ne ""} { |
||||
return [punk::auto_exec::system::assoc_get_info $ext] |
||||
} else { |
||||
#look up all associated ftypes |
||||
set user_ftypes [registry keys {HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts} .*] |
||||
|
||||
set system_ftypes [registry keys {HKEY_LOCAL_MACHINE\SOFTWARE\Classes} .*] |
||||
set all_ftypes [lsort -unique [concat $user_ftypes $system_ftypes]] |
||||
set results [list] |
||||
foreach ftype $all_ftypes { |
||||
dict set results $ftype [punk::auto_exec::system::assoc_get_info $ftype] |
||||
} |
||||
return $results |
||||
} |
||||
} |
||||
namespace eval argdoc { |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::ftype" |
||||
@cmd -name "punk::auto_exec::ftype"\ |
||||
-summary\ |
||||
"Look up shell verb command values from windows file type."\ |
||||
-help\ |
||||
"Get the associated shell verb information (such as open) for a file type by looking up the user-specific |
||||
association in the registry and falling back to the system association if no |
||||
user-specific association is found. |
||||
|
||||
Returns a dict of dicts with toplevel keys for each shell verb (e.g open, runas) and values that are dicts with keys |
||||
${$I}type${$NI} and ${$I}value${$NI} and ${$I}scope${$NI}, where |
||||
type is determined from the registry value type (e.g sz or expand_sz) |
||||
string is the raw command string from the registry |
||||
scope is either "user" or "system" depending on whether the value was found in the user-specific registry keys or |
||||
the system registry keys. |
||||
|
||||
This is somewhat like the windows 'ftype' command except that the windows command only looks for the 'open' verb and |
||||
only looks up the system association and does not take into account any user-specific |
||||
overrides. |
||||
|
||||
The file type can be looked up using the ${$B}assoc${$N} function in this package. |
||||
|
||||
The command string can contain placeholders like \"%1\" for the file name, and environment variables |
||||
in the form %VAR% (case insensitive) if the registry value type is reg_expand_sz (expand_sz), |
||||
which will be substituted by the ${$B}shell_command_as_tcl_list${$N} function when processing the command |
||||
string into a Tcl list of command and arguments with placeholders substituted." |
||||
@opts |
||||
@values -min 0 -max 1 |
||||
filetype -type string -default "" -optional true -help\ |
||||
"File type associated with a file extension, e.g Python.File. |
||||
This can be looked up using the 'assoc' function in this package." |
||||
}] |
||||
} |
||||
#proc ftype {filetype} { |
||||
# package require registry |
||||
|
||||
# if {$filetype eq "cplfile"} { |
||||
# #special case for cplfile (associated with .cpl files) which doesn't follow the usual pattern of having the command string under shell\open\command, |
||||
# #but instead has it under HKEY_LOCAL_MACHINE\SOFTWARE\Classes\cplfile\shell\cplopen\command. |
||||
# #There doesn't seem to be any user-specific override for this file type |
||||
# #- but we will check for one under HKEY_CURRENT_USER\Software\Classes\cplfile\shell\cplopen\command anyway for consistency with the way we check |
||||
# #for user-specific overrides for other file types. |
||||
# set key [join [list HKEY_CURRENT_USER Software Classes cplfile shell cplopen command] "\\"] |
||||
# } else { |
||||
# set key [join [list HKEY_CURRENT_USER Software Classes $filetype shell open command] "\\"] |
||||
# } |
||||
# if {![catch {registry get $key ""} raw_assoc]} { |
||||
# set tp [registry type $key ""] |
||||
# return [dict create open [dict create type $tp string $raw_assoc]] |
||||
# } else { |
||||
# #e.g Python.File |
||||
# if {$filetype eq "cplfile"} { |
||||
# set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes cplfile shell cplopen command] "\\"] |
||||
# } else { |
||||
# set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell open command] "\\"] |
||||
# } |
||||
# if {![catch {registry get $key ""} raw_assoc]} { |
||||
# set tp [registry type $key ""] |
||||
# return [dict create type $tp string $raw_assoc] |
||||
# } else { |
||||
# return [dict create type "" string ""] ;#no association found |
||||
# } |
||||
# } |
||||
#} |
||||
proc ftype {filetype} { |
||||
package require registry |
||||
set resultdict [dict create] |
||||
|
||||
#e.g Python.File |
||||
set shellpath [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell] "\\"] |
||||
if {![catch {registry keys $shellpath *} shellverbs]} { |
||||
foreach verb $shellverbs { |
||||
set commandkey [join [list $shellpath $verb command] "\\"] |
||||
if {![catch {registry get $commandkey ""} cmdstring]} { |
||||
#registry queryies are case insensitive but some are cased differently e.g Open vs open. |
||||
#when using the verb as a key in the output dict, we need to normalize so that it is useful for lookups. We'll use lowercase for that. |
||||
set verb [string tolower $verb] |
||||
set tp [registry type $commandkey ""] |
||||
dict set resultdict $verb [dict create type $tp value $cmdstring scope system] |
||||
} |
||||
} |
||||
} |
||||
|
||||
#allow user-specific verbs to be overridden. |
||||
set shellpath [join [list HKEY_CURRENT_USER Software Classes $filetype shell] "\\"] |
||||
if {![catch {registry keys $shellpath *} shellverbs]} { |
||||
foreach verb $shellverbs { |
||||
set commandkey [join [list $shellpath $verb command] "\\"] |
||||
if {![catch {registry get $commandkey ""} cmdstring]} { |
||||
set verb [string tolower $verb] |
||||
set tp [registry type $commandkey ""] |
||||
dict set resultdict $verb [dict create type $tp value $cmdstring scope user] |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $resultdict |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::auto_exec::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
#tcl::namespace::eval punk::auto_exec::system { |
||||
#} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval punk::auto_exec { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)punk::auto_exec" |
||||
@package -name "punk::auto_exec" -help\ |
||||
"Package |
||||
Description" |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return punk::auto_exec |
||||
} |
||||
proc about_topics {} { |
||||
#info commands results are returned in an arbitrary order (like array keys) |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
#Adjust this function or 'default_topics' if a different order is required |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
# ------------------------------------------------------------- |
||||
# get_topic_ functions add more to auto-include in about topics |
||||
# ------------------------------------------------------------- |
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package punk::auto_exec |
||||
description to come.. |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "<unspecified>" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::punk::auto_exec::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{<julian@precisium.com.au> {Julian Noble}}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_custom-topic {} { |
||||
punk::args::lib::tstr -return string { |
||||
A custom |
||||
topic |
||||
etc |
||||
} |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# we re-use the argument definition from punk::args::standard_about and override some items |
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::punk::auto_exec::about" |
||||
dict set overrides @cmd -name "punk::auto_exec::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About punk::auto_exec |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[punk::auto_exec::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [punk::auto_exec::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||
set argd [punk::args::parse $args withid ::punk::auto_exec::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::punk::auto_exec::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
# variable PUNKARGS |
||||
# variable PUNKARGS_aliases |
||||
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::auto_exec |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::auto_exec [tcl::namespace::eval punk::auto_exec { |
||||
variable pkg punk::auto_exec |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,786 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.4.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) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::auto_exec 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
package require Tcl 8.6- |
||||
|
||||
#---------------------- |
||||
# registry notes |
||||
|
||||
#Computer\HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ApplicationAssociationToasts |
||||
# - associates applications/file types with extensions and protocols. |
||||
|
||||
#.cp items have a shell\cplopen\command subkey instead of shell\open\command |
||||
#- but the command string has the same format and placeholders as the shell\open\command entries for other file types, |
||||
#so we can handle them in the same way as other file types when we extract the associated command string. |
||||
|
||||
#---------------------- |
||||
|
||||
|
||||
|
||||
tcl::namespace::eval punk::auto_exec { |
||||
namespace eval argdoc { |
||||
variable PUNKARGS |
||||
set I "\x1b\[3m" ;# [a+ italic] |
||||
set NI "\x1b\[23m" ;# [a+ noitalic] |
||||
set B "\x1b\[1m" ;# [a+ bold] |
||||
set N "\x1b\[22m" ;# [a+ normal] |
||||
set T "\x1b\[1\;4m" ;# [a+ bold underline] |
||||
set NT "\x1b\[22\;24m\x1b\[4:0m" ;# [a+ normal nounderline] |
||||
} |
||||
|
||||
variable PUNKARGS |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::shell_open_command" |
||||
@cmd -name "punk::auto_exec::assoc" -help\ |
||||
{Returns the raw 'open' command string associated with the file type for the given file extension, |
||||
by looking up the user-specific association in the registry and falling back to the system |
||||
association if no user-specific association is found. |
||||
|
||||
The resulting command string can contain placeholders like "%1" for the file name. |
||||
e.g .py -> "c:\Program Files\Python\python.exe" "%1" |
||||
e.g .rb -> "C:\tools\ruby31\bin\ruby.exe" "%1" %* |
||||
e.g .vbs -> "%SystemRoot%\System32\WScript.exe" "%1" %* |
||||
|
||||
Note that the resulting string has unescaped backslashes within double quotes, so it is |
||||
not suitable for direct execution by Tcl without further processing to handle the backslashes |
||||
and placeholders. |
||||
|
||||
see 'shell_command_as_tcl_list' for processing the command string into a Tcl list of command and |
||||
arguments with placeholders substituted. |
||||
} |
||||
@opts |
||||
@values -min 0 -max 1 |
||||
ext -type string -default "" -optional true -help\ |
||||
"File extension to look up, e.g .txt or .py" |
||||
}] |
||||
proc shell_open_command {ext} { |
||||
#look up assoc and ftype to find associated file type and application. |
||||
#Note that the windows 'ftype' and 'assoc' commands only examine the system's data - not the user-specific data which may override the system data. |
||||
#to get the user-specific associations we need to read the registry keys. |
||||
|
||||
#extensions in the registry seem to be stored lower case wnd with a leading dot. |
||||
set lext [string tolower $ext] |
||||
package require registry |
||||
set user_assoc_path [join [list HKEY_CURRENT_USER Software Microsoft Windows CurrentVersion Explorer FileExts $lext UserChoice] "\\"] |
||||
|
||||
#The UserChoice subkey under this key is where the user-specific association is stored when the user has made a choice. It contains a Progid value which points to the associated file type. |
||||
#It can return something like "Python.File" or "Applications\python.exe" or even tcl_auto_file (for .tcl files associated with tclsh by a tcl installer) |
||||
|
||||
set openverb "open" |
||||
|
||||
|
||||
#The UserChoice key may not exist if the user hasn't made an explicit choice, in which case we fall back to the system association which is stored under HKEY_CLASSES_ROOT\$ext (which also contains user-specific overrides but is more cumbersome to query for them) |
||||
if {![catch {registry get $user_assoc_path Progid} user_choice]} { |
||||
if {$user_choice ne ""} { |
||||
#examples such as Applications\python.exe and tcl_auto_file are found under HKEY_CURRENT_USER\Software\Classes |
||||
#they then have a sub-path shell\open\command which contains the command to open files of that type, which is what we need to extract the associated application. |
||||
#it is faster to query for the key directly within a catch than to retrieve keys as lists and iterate through them to find the one we want. |
||||
|
||||
#special case .cpl cplfile |
||||
if {$user_choice eq "cplfile"} { |
||||
set openverb "cplopen" |
||||
} |
||||
set verbinfo [ftype $user_choice] |
||||
if {[dict exists $verbinfo $openverb]} { |
||||
set ftypeinfo [dict get $verbinfo $openverb] |
||||
return [dict set ftypeinfo filetype $user_choice] |
||||
} else { |
||||
return [dict create type "notfound" value "" scope user filetype $user_choice] |
||||
} |
||||
|
||||
} else { |
||||
#review - is it possible for Progid to be empty string? If so we should probably fall back to system association instead of returning no association. |
||||
#alternatively it could mean the user has explicitly chosen to have no association for this file type - in which case returning an empty association may be the correct behaviour. |
||||
return [dict create type "empty" value "" scope user filetype ""] |
||||
} |
||||
} else { |
||||
#fall back to system association and ftype |
||||
if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $lext] "\\"] ""} ftype]} { |
||||
#ftype is the file type associated with the extension, e.g "Python.File" |
||||
#we then need to look up the command associated with this file type under the same path but with the file type instead of the extension and with the additional sub-path shell\open\command |
||||
|
||||
#special case .cpl cplfile |
||||
if {$ftype eq "cplfile"} { |
||||
set openverb "cplopen" |
||||
} |
||||
set verbinfo [ftype $ftype] |
||||
if {[dict exists $verbinfo $openverb]} { |
||||
set ftypeinfo [dict get $verbinfo $openverb] |
||||
return [dict set ftypeinfo filetype $ftype] |
||||
} else { |
||||
return [dict create type "notfound" value "" scope system filetype $ftype] |
||||
} |
||||
} else { |
||||
return [dict create type "notfound" value "" scope "" filetype ""] |
||||
} |
||||
} |
||||
#shouldn't get here - there is a return in each branch above. |
||||
return "no-result" |
||||
} |
||||
|
||||
# %1 - standard placeholder for the first file parameter. |
||||
# %L (or %l) - Long File Name form of the path. |
||||
# %* - replaces with all parameters passed to the command. (ie not including the command itself) |
||||
# %W (or %w) - working directory. |
||||
|
||||
# other placeholders that we won't handle for now: |
||||
# %I (or %i) - handle to an Item ID List (IDList) |
||||
# e.g for filetype ArchiveFolder (associated with .7z, .gz, .CPIO etc) we have "%SystemRoot%\Explorer.exe" /idlist,%I,%L |
||||
# %D (or %d) - Desktop absolute parsing name of the first parameter |
||||
# (for items that don't have file system paths) will be the same as %1 for file system items. |
||||
|
||||
#todo - we need to substitute other placeholders such as %SystemRoot% etc. (case insensitively) |
||||
# - but only if the type of the key is expand_sz. |
||||
|
||||
#These are environment variables that can be used in the command string. |
||||
#when type is sz - only the single letter placeholders are substituted, and environment variables are not substituted. |
||||
#when type is expand_sz - the single letter placeholders are substituted, and environment variables are also substituted |
||||
#(case insensitively) - but only if they are in the form %VAR% |
||||
#A matching environment variable will take precedence over a single letter placeholder if there is a conflict, |
||||
#e.g if the string is %1% and there is an environment variable named "1" then it will be substituted instead of the %1 placeholder. |
||||
#a non-existant environment variable will not be substituted and it's wrapping % characters will not be included in the output. |
||||
#similarly a single letter placeholder that is not recognised, such as %x, will result in only the x being included in the output without the leading % character. |
||||
|
||||
|
||||
#todo - tests for shell_command_as_tcl_list with various combinations of placeholders, quoted and unquoted, |
||||
#and with both reg_sz and reg_expand_sz types, and with various edge cases such as missing arguments, extra arguments, |
||||
#empty arguments, unrecognized placeholders, invalid env var references etc. |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::shell_command_as_tcl_list" |
||||
@cmd -name "punk::auto_exec::shell_command_as_tcl_list" -help\ |
||||
{} |
||||
@opts |
||||
-type -type string -default sz -choices {sz expand_sz} -help\ |
||||
"The type of the registry value containing the command string, which determines how |
||||
environment variables are substituted. sz means environment variables will not |
||||
be substituted, and expand_sz means environment variables will be substituted |
||||
if they are in the form %VAR% (case insensitively) and will take precedence over |
||||
single letter placeholders if there is a conflict. |
||||
|
||||
In either case, the single letter placeholders will be substituted as follows: |
||||
%1 - standard placeholder for the first file parameter. |
||||
%L (or %l) - Long File Name form of the path. |
||||
%* - replaced with all subsequent parameters passed to the command. |
||||
(but not including the script name itself) |
||||
%W (or %w) - working directory." |
||||
-workingdir -type string -default "" -help\ |
||||
"The working directory to substitute for the %W (or %w) placeholder." |
||||
@values -min 1 -max -1 |
||||
commandspec -type string -help\ |
||||
"The command string to process, which can contain placeholders like %1 for the file name, |
||||
and a list of arguments to substitute for the placeholders. The command string is typically |
||||
obtained from the registry for a file type association, and the arguments are typically the |
||||
file name and other parameters to substitute into the command string." |
||||
arg -type any -multiple 1 -optional 1 -help\ |
||||
{One or more arguments to substitute for the placeholders in the command string. |
||||
The first argument (often a script or document path) will be substituted for %1, |
||||
the second argument will be substituted for %2, and so on. If the command string |
||||
contains a %* placeholder, then all of the arguments will be substituted for that |
||||
placeholder starting from %2. |
||||
If there are more placeholders than arguments, then the extra placeholders will be |
||||
substituted with empty string. |
||||
If missing arguments are specified in the commandspec as quoted strings, eg "%3" then |
||||
corresponding empty strings as separate arguments will be included in the output.} |
||||
}] |
||||
proc shell_command_as_tcl_list {args} { |
||||
set argd [punk::args::parse $args withid ::punk::auto_exec::shell_command_as_tcl_list] |
||||
lassign [dict values $argd] _leaders opts values received |
||||
set type [dict get $opts -type] |
||||
set workingdir [dict get $opts -workingdir] |
||||
set commandspec [dict get $values commandspec] |
||||
if {[dict exists $received arg]} { |
||||
set arglist [dict get $values arg] |
||||
} else { |
||||
set arglist [list] |
||||
} |
||||
|
||||
set result [list] |
||||
set quoted [list 0] ;#track whether the current chunk is quoted or not. Only the last item is relevant. |
||||
|
||||
set chars [split [string trim $commandspec] ""] |
||||
set in_quote 0 |
||||
set current_chunk {} |
||||
set new_chunk 1 |
||||
set got_placeholder 0 |
||||
for {set i 0} {$i < [llength $chars]} {incr i} { |
||||
set char [lindex $chars $i] |
||||
if {$in_quote} { |
||||
if {$char eq "\""} { |
||||
if {$got_placeholder} { |
||||
#wasn't a valid placeholder - % not emitted. |
||||
set got_placeholder 0 |
||||
} |
||||
#The windows implementation doesn't seem to close off a chunk just because it encounters a closing quote, |
||||
#so we don't do that either. |
||||
#The closing quote just affects whether the next space will terminate the chunk or not. |
||||
set in_quote 0 |
||||
} else { |
||||
if {$char eq "%"} { |
||||
#we do not handle the trailing % of an env var such as %VAR% here |
||||
#- as we scan for that in the default case of the switch below. |
||||
if {$got_placeholder} { |
||||
#this is a % escaped by doubling up ie a literal % in the output |
||||
append current_chunk "%" |
||||
set got_placeholder 0 |
||||
} else { |
||||
set got_placeholder 1 |
||||
} |
||||
} elseif {$got_placeholder} { |
||||
if {$type eq "expand_sz"} { |
||||
#we scan for environment variables in the form %VAR% (case insensitively) and substitute them if found, taking precedence over single letter placeholders if there is a conflict. |
||||
#a non-existant environment variable will not be substituted and it's wrapping % characters will not be included in the output. |
||||
set env_var_name $char |
||||
for {set j [expr {$i+1}]} {$j < [llength $chars]} {incr j} { |
||||
set next_char [lindex $chars $j] |
||||
if {$next_char in {" " \t}} { |
||||
#end of env var name - we don't expect to see spaces within environment variable names, |
||||
#treat space as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "\""} { |
||||
#end of env var name - we don't expect to see quotes within environment variable names, |
||||
#treat quote as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "%"} { |
||||
#end of *possible* env var name |
||||
break |
||||
} else { |
||||
append env_var_name $next_char |
||||
} |
||||
} |
||||
if {$next_char eq "%"} { |
||||
#we found a closing % character, so we have a possible env var name between the two % characters. |
||||
#we will substitute the env var value if it exists, |
||||
# or the value of any single letter placeholder if there is a match, |
||||
# or the original string between the two % characters if there is no match for either an env var or a single letter placeholder. |
||||
if {[info exists ::env($env_var_name)]} { |
||||
append current_chunk $::env($env_var_name) |
||||
set got_placeholder 0 |
||||
set i $j ;#advance past the env var name and closing % character for next iteration of main loop |
||||
continue |
||||
} |
||||
} else { |
||||
#we didn't find a closing % character, so this isn't a valid env var reference. |
||||
set env_var_name "" |
||||
#fall through to single % placeholder handling below, |
||||
#which will treat the first character after the % as a single letter placeholder and include the rest of the string as literal characters in the output. |
||||
} |
||||
} |
||||
|
||||
switch -- $char { |
||||
1 - L - l { |
||||
append current_chunk [lindex $arglist 0] |
||||
} |
||||
2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { |
||||
append current_chunk [lindex $arglist $char-1] |
||||
} |
||||
D - d { |
||||
#review |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute the same value as %1 for now, |
||||
#which is what windows seems to do for file system items that have file paths. |
||||
append current_chunk [lindex $arglist 0] |
||||
} |
||||
I - i { |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute something for now. |
||||
#format seems to be 9 and 5 digits :nnnnnnnnn:nnnnn |
||||
#REVIEW! unknown consequences! |
||||
append current_chunk ":000000000:00000" |
||||
} |
||||
"*" { |
||||
append current_chunk [lrange $arglist 1 end] |
||||
} |
||||
W - w { |
||||
append current_chunk $workingdir |
||||
} |
||||
default { |
||||
if {$type eq "expand_sz"} { |
||||
#if expand_sz we would have already scanned for environment variables in the form %VAR% and substituted them if found, |
||||
#taking precedence over single letter placeholders if there is a conflict. |
||||
append current_chunk "$char" [string range $env_var_name 1 end] ;#if env_var_name is empty string then this will just append the single char after the % as a literal, |
||||
#which is the correct behaviour for unrecognized placeholders such as %x and for invalid env var references such as %NONEXISTANT% |
||||
} else { |
||||
append current_chunk $char |
||||
} |
||||
} |
||||
} |
||||
set got_placeholder 0 |
||||
} else { |
||||
append current_chunk $char |
||||
} |
||||
} |
||||
} else { |
||||
#NOT in quoted string |
||||
if {$char eq "\""} { |
||||
if {$got_placeholder} { |
||||
append current_chunk "%" ;#wasn't a valid placeholder char, so we need to add the % that we stripped off back into the output |
||||
set got_placeholder 0 |
||||
} |
||||
set in_quote 1 |
||||
set new_chunk 0 |
||||
lset quoted end 1 ;#we'll mark as quoted if any quote found in it - review |
||||
} elseif {$char in [list " " \t ]} { |
||||
#we don't expect to see tabs or other whitespace characters as separators in the command string, but we'll treat tab the same as spaces just in case. |
||||
if {$got_placeholder} { |
||||
#wasn't a valid placeholder char. The % is stripped and not included in the output. |
||||
set got_placeholder 0 |
||||
} |
||||
#space terminates an unquoted chunk, so we add it to the result list and start a new chunk. |
||||
#we also need to ensure that consecutive spaces are treated as a single separator and don't result in empty items in the output list, |
||||
|
||||
if {!$new_chunk} { |
||||
if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { |
||||
#we add the current chunk to the result list if it's not empty, or if it is empty but is quoted (because in that case we want to preserve it as an empty argument). |
||||
lappend result $current_chunk |
||||
lappend quoted 0 |
||||
set current_chunk {} |
||||
} |
||||
set new_chunk 1 |
||||
} |
||||
for {set j [expr {$i+1}]} {$j < [llength $chars]} {incr j} { |
||||
if {[lindex $chars $j] in {" " \t}} { |
||||
incr i |
||||
} else { |
||||
break |
||||
} |
||||
} |
||||
} else { |
||||
if {$got_placeholder} { |
||||
if {$type eq "expand_sz"} { |
||||
#we scan for environment variables in the form %VAR% (case insensitively) and substitute them if found, taking precedence over single letter placeholders if there is a conflict. |
||||
#a non-existant environment variable will not be substituted and it's wrapping % characters will not be included in the output. |
||||
set env_var_name $char |
||||
for {set j [expr {$i+1}]} {$j < [llength $chars]} {incr j} { |
||||
set next_char [lindex $chars $j] |
||||
if {$next_char in {" " \t}} { |
||||
#end of env var name - we don't expect to see spaces within environment variable names, |
||||
#treat space as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "\""} { |
||||
#end of env var name - we don't expect to see quotes within environment variable names, |
||||
#treat quote as terminator indicating failure to match. |
||||
break |
||||
} elseif {$next_char eq "%"} { |
||||
#end of *possible* env var name |
||||
break |
||||
} else { |
||||
append env_var_name $next_char |
||||
} |
||||
} |
||||
if {$next_char eq "%"} { |
||||
#we found a closing % character, so we have a possible env var name between the two % characters. |
||||
#we will substitute the env var value if it exists, |
||||
# or the value of any single letter placeholder if there is a match, |
||||
# or the original string between the two % characters if there is no match for either an env var or a single letter placeholder. |
||||
if {[info exists ::env($env_var_name)]} { |
||||
append current_chunk $::env($env_var_name) |
||||
set got_placeholder 0 |
||||
set i $j ;#advance past the env var name and closing % character for next iteration of main loop |
||||
continue |
||||
} |
||||
} else { |
||||
#we didn't find a closing % character, so this isn't a valid env var reference. |
||||
set env_var_name "" |
||||
#fall through to single % placeholder handling below, |
||||
#which will treat the first character after the % as a single letter placeholder and include the rest of the string as literal characters in the output. |
||||
} |
||||
} |
||||
|
||||
switch -- $char { |
||||
"%" { |
||||
append current_chunk "%" |
||||
set got_placeholder 1 |
||||
continue |
||||
} |
||||
1 - |
||||
L - l { |
||||
#append current_chunk [lindex $arglist 0] |
||||
set append_value [string trim [lindex $arglist 0]] |
||||
foreach ch [split $append_value ""] { |
||||
if {$ch eq " "} { |
||||
#we need to split on spaces within arguments as well, because unquoted %1 can expand to multiple arguments if the first argument contains spaces, and we need to preserve the correct splitting of arguments in that case. |
||||
#e.g if %1 is substituted with "C:\My Documents\file.txt" then we need to split that into three items in the output list: "C:\My", "Documents\file.txt" |
||||
if {$current_chunk ne ""} { |
||||
lappend result $current_chunk |
||||
lappend quoted 0 |
||||
set current_chunk {} |
||||
} |
||||
set new_chunk 1 |
||||
} else { |
||||
append current_chunk $ch |
||||
set new_chunk 0 |
||||
} |
||||
} |
||||
} |
||||
2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { |
||||
append current_chunk [lindex $arglist $char-1] |
||||
} |
||||
D - d { |
||||
#review |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute the same value as %1 for now, |
||||
#which is what windows seems to do for file system items that have file paths. |
||||
append current_chunk [lindex $arglist 0] |
||||
} |
||||
I - i { |
||||
#we don't have a way to represent an Item ID List (IDList) in our API, so we'll just substitute something for now. |
||||
#format seems to be 9 and 5 digits :nnnnnnnnn:nnnnn |
||||
#REVIEW! unknown consequences! |
||||
append current_chunk ":000000000:00000" |
||||
} |
||||
"*" { |
||||
#the window implementation of unquoted %* always seems to emit the previous chunk before the %* placeholder as a separate item |
||||
#in the command line, even if there is no space between them, so we will do the same. |
||||
#Note that a following string (quoted or not) immediately after the %* will be appended to the last item in the output list rather than being a separate item, |
||||
#which is also consistent with the microsoft implementation. |
||||
if {!$new_chunk} { |
||||
if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { |
||||
lappend result $current_chunk |
||||
lappend quoted 0 |
||||
set current_chunk {} |
||||
} |
||||
} |
||||
lappend result {*}[lrange $arglist 1 end] |
||||
lappend quoted {*}[lrepeat [llength $arglist] 0] |
||||
} |
||||
W - w { |
||||
append current_chunk $workingdir |
||||
} |
||||
default { |
||||
if {$type eq "expand_sz"} { |
||||
#if expand_sz we would have already scanned for environment variables in the form %VAR% and substituted them if found, |
||||
#taking precedence over single letter placeholders if there is a conflict. |
||||
append current_chunk "$char" [string range $env_var_name 1 end] ;#if env_var_name is empty string then this will just append the single char after the % as a literal, |
||||
#which is the correct behaviour for unrecognized placeholders such as %x and for invalid env var references such as %NONEXISTANT% |
||||
} else { |
||||
append current_chunk $char |
||||
} |
||||
} |
||||
} |
||||
set got_placeholder 0 |
||||
set new_chunk 0 |
||||
} else { |
||||
if {$char eq "%"} { |
||||
set got_placeholder 1 |
||||
} else { |
||||
append current_chunk $char |
||||
set new_chunk 0 |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
if {$current_chunk ne "" || $current_chunk eq "" && [lindex $quoted end]} { |
||||
#review - edge case - if the command string ends with a space then we would have already added the last chunk to the result list and started a new chunk, so we shouldn't add an empty chunk to the result list in that case. |
||||
#however if the last chunk was quoted and is empty because the command string ends with a placeholder that is substituted with an empty string, then we should add the empty chunk to the result list. |
||||
lappend result $current_chunk |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
namespace eval punk::auto_exec::system { |
||||
proc assoc_get_info {ext} { |
||||
set lext [string tolower $ext] |
||||
set result [dict create system "" user ""] |
||||
set user_assoc_path [join [list HKEY_CURRENT_USER Software Microsoft Windows CurrentVersion Explorer FileExts $lext UserChoice] "\\"] |
||||
if {![catch {registry get $user_assoc_path Progid} user_choice]} { |
||||
dict set result user $user_choice |
||||
} |
||||
if {![catch {registry get [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $lext] "\\"] ""} ftype]} { |
||||
dict set result system $ftype |
||||
} |
||||
return $result |
||||
} |
||||
} |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::assoc" |
||||
@cmd -name "punk::auto_exec::assoc"\ |
||||
-summary\ |
||||
"Look up the associated file type (system and user) for a file extension"\ |
||||
-help\ |
||||
"Get the associated file type for a file extension by looking up the user-specific |
||||
file type in the registry and falling back to the system file type if no |
||||
user-specific association is found. |
||||
|
||||
Returns a dict with keys ${$I}system${$NI} and ${$I}user${$NI}. |
||||
One or more of the key values may be empty string if there is no defined |
||||
file type for the extension. |
||||
|
||||
This is somewhat like the windows 'assoc' command except that the windows command |
||||
only looks up the system association and does not take into account any user-specific |
||||
overrides. |
||||
This function returns both values in the result dictionary if they are available." |
||||
@opts |
||||
@values -min 0 -max 1 |
||||
ext -type string -default "" -optional true -help\ |
||||
"File extension to look up, e.g .txt or .py" |
||||
}] |
||||
proc assoc {args} { |
||||
package require registry |
||||
set argd [punk::args::parse $args withid ::punk::auto_exec::assoc] |
||||
set ext [dict get $argd values ext] |
||||
|
||||
if {$ext ne ""} { |
||||
return [punk::auto_exec::system::assoc_get_info $ext] |
||||
} else { |
||||
#look up all associated ftypes |
||||
set user_ftypes [registry keys {HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\FileExts} .*] |
||||
|
||||
set system_ftypes [registry keys {HKEY_LOCAL_MACHINE\SOFTWARE\Classes} .*] |
||||
set all_ftypes [lsort -unique [concat $user_ftypes $system_ftypes]] |
||||
set results [list] |
||||
foreach ftype $all_ftypes { |
||||
dict set results $ftype [punk::auto_exec::system::assoc_get_info $ftype] |
||||
} |
||||
return $results |
||||
} |
||||
} |
||||
namespace eval argdoc { |
||||
lappend PUNKARGS [list { |
||||
@id -id "::punk::auto_exec::ftype" |
||||
@cmd -name "punk::auto_exec::ftype"\ |
||||
-summary\ |
||||
"Look up shell verb command values from windows file type."\ |
||||
-help\ |
||||
"Get the associated shell verb information (such as open) for a file type by looking up the user-specific |
||||
association in the registry and falling back to the system association if no |
||||
user-specific association is found. |
||||
|
||||
Returns a dict of dicts with toplevel keys for each shell verb (e.g open, runas) and values that are dicts with keys |
||||
${$I}type${$NI} and ${$I}value${$NI} and ${$I}scope${$NI}, where |
||||
type is determined from the registry value type (e.g sz or expand_sz) |
||||
string is the raw command string from the registry |
||||
scope is either "user" or "system" depending on whether the value was found in the user-specific registry keys or |
||||
the system registry keys. |
||||
|
||||
This is somewhat like the windows 'ftype' command except that the windows command only looks for the 'open' verb and |
||||
only looks up the system association and does not take into account any user-specific |
||||
overrides. |
||||
|
||||
The file type can be looked up using the ${$B}assoc${$N} function in this package. |
||||
|
||||
The command string can contain placeholders like \"%1\" for the file name, and environment variables |
||||
in the form %VAR% (case insensitive) if the registry value type is reg_expand_sz (expand_sz), |
||||
which will be substituted by the ${$B}shell_command_as_tcl_list${$N} function when processing the command |
||||
string into a Tcl list of command and arguments with placeholders substituted." |
||||
@opts |
||||
@values -min 0 -max 1 |
||||
filetype -type string -default "" -optional true -help\ |
||||
"File type associated with a file extension, e.g Python.File. |
||||
This can be looked up using the 'assoc' function in this package." |
||||
}] |
||||
} |
||||
#proc ftype {filetype} { |
||||
# package require registry |
||||
|
||||
# if {$filetype eq "cplfile"} { |
||||
# #special case for cplfile (associated with .cpl files) which doesn't follow the usual pattern of having the command string under shell\open\command, |
||||
# #but instead has it under HKEY_LOCAL_MACHINE\SOFTWARE\Classes\cplfile\shell\cplopen\command. |
||||
# #There doesn't seem to be any user-specific override for this file type |
||||
# #- but we will check for one under HKEY_CURRENT_USER\Software\Classes\cplfile\shell\cplopen\command anyway for consistency with the way we check |
||||
# #for user-specific overrides for other file types. |
||||
# set key [join [list HKEY_CURRENT_USER Software Classes cplfile shell cplopen command] "\\"] |
||||
# } else { |
||||
# set key [join [list HKEY_CURRENT_USER Software Classes $filetype shell open command] "\\"] |
||||
# } |
||||
# if {![catch {registry get $key ""} raw_assoc]} { |
||||
# set tp [registry type $key ""] |
||||
# return [dict create open [dict create type $tp string $raw_assoc]] |
||||
# } else { |
||||
# #e.g Python.File |
||||
# if {$filetype eq "cplfile"} { |
||||
# set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes cplfile shell cplopen command] "\\"] |
||||
# } else { |
||||
# set key [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell open command] "\\"] |
||||
# } |
||||
# if {![catch {registry get $key ""} raw_assoc]} { |
||||
# set tp [registry type $key ""] |
||||
# return [dict create type $tp string $raw_assoc] |
||||
# } else { |
||||
# return [dict create type "" string ""] ;#no association found |
||||
# } |
||||
# } |
||||
#} |
||||
proc ftype {filetype} { |
||||
package require registry |
||||
set resultdict [dict create] |
||||
|
||||
#e.g Python.File |
||||
set shellpath [join [list HKEY_LOCAL_MACHINE SOFTWARE Classes $filetype shell] "\\"] |
||||
if {![catch {registry keys $shellpath *} shellverbs]} { |
||||
foreach verb $shellverbs { |
||||
set commandkey [join [list $shellpath $verb command] "\\"] |
||||
if {![catch {registry get $commandkey ""} cmdstring]} { |
||||
#registry queryies are case insensitive but some are cased differently e.g Open vs open. |
||||
#when using the verb as a key in the output dict, we need to normalize so that it is useful for lookups. We'll use lowercase for that. |
||||
set verb [string tolower $verb] |
||||
set tp [registry type $commandkey ""] |
||||
dict set resultdict $verb [dict create type $tp value $cmdstring scope system] |
||||
} |
||||
} |
||||
} |
||||
|
||||
#allow user-specific verbs to be overridden. |
||||
set shellpath [join [list HKEY_CURRENT_USER Software Classes $filetype shell] "\\"] |
||||
if {![catch {registry keys $shellpath *} shellverbs]} { |
||||
foreach verb $shellverbs { |
||||
set commandkey [join [list $shellpath $verb command] "\\"] |
||||
if {![catch {registry get $commandkey ""} cmdstring]} { |
||||
set verb [string tolower $verb] |
||||
set tp [registry type $commandkey ""] |
||||
dict set resultdict $verb [dict create type $tp value $cmdstring scope user] |
||||
} |
||||
} |
||||
} |
||||
|
||||
return $resultdict |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Secondary API namespace |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
tcl::namespace::eval punk::auto_exec::lib { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
tcl::namespace::path [tcl::namespace::parent] |
||||
} |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
|
||||
|
||||
#tcl::namespace::eval punk::auto_exec::system { |
||||
#} |
||||
|
||||
|
||||
# == === === === === === === === === === === === === === === |
||||
# Sample 'about' function with punk::args documentation |
||||
# == === === === === === === === === === === === === === === |
||||
tcl::namespace::eval punk::auto_exec { |
||||
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||
variable PUNKARGS |
||||
variable PUNKARGS_aliases |
||||
|
||||
lappend PUNKARGS [list { |
||||
@id -id "(package)punk::auto_exec" |
||||
@package -name "punk::auto_exec" -help\ |
||||
"Package |
||||
Description" |
||||
}] |
||||
|
||||
namespace eval argdoc { |
||||
#namespace for custom argument documentation |
||||
proc package_name {} { |
||||
return punk::auto_exec |
||||
} |
||||
proc about_topics {} { |
||||
#info commands results are returned in an arbitrary order (like array keys) |
||||
set topic_funs [info commands [namespace current]::get_topic_*] |
||||
set about_topics [list] |
||||
foreach f $topic_funs { |
||||
set tail [namespace tail $f] |
||||
lappend about_topics [string range $tail [string length get_topic_] end] |
||||
} |
||||
#Adjust this function or 'default_topics' if a different order is required |
||||
return [lsort $about_topics] |
||||
} |
||||
proc default_topics {} {return [list Description *]} |
||||
|
||||
# ------------------------------------------------------------- |
||||
# get_topic_ functions add more to auto-include in about topics |
||||
# ------------------------------------------------------------- |
||||
proc get_topic_Description {} { |
||||
punk::args::lib::tstr [string trim { |
||||
package punk::auto_exec |
||||
description to come.. |
||||
} \n] |
||||
} |
||||
proc get_topic_License {} { |
||||
return "<unspecified>" |
||||
} |
||||
proc get_topic_Version {} { |
||||
return "$::punk::auto_exec::version" |
||||
} |
||||
proc get_topic_Contributors {} { |
||||
set authors {{<julian@precisium.com.au> {Julian Noble}}} |
||||
set contributors "" |
||||
foreach a $authors { |
||||
append contributors $a \n |
||||
} |
||||
if {[string index $contributors end] eq "\n"} { |
||||
set contributors [string range $contributors 0 end-1] |
||||
} |
||||
return $contributors |
||||
} |
||||
proc get_topic_custom-topic {} { |
||||
punk::args::lib::tstr -return string { |
||||
A custom |
||||
topic |
||||
etc |
||||
} |
||||
} |
||||
# ------------------------------------------------------------- |
||||
} |
||||
|
||||
# we re-use the argument definition from punk::args::standard_about and override some items |
||||
set overrides [dict create] |
||||
dict set overrides @id -id "::punk::auto_exec::about" |
||||
dict set overrides @cmd -name "punk::auto_exec::about" |
||||
dict set overrides @cmd -help [string trim [punk::args::lib::tstr { |
||||
About punk::auto_exec |
||||
}] \n] |
||||
dict set overrides topic -choices [list {*}[punk::auto_exec::argdoc::about_topics] *] |
||||
dict set overrides topic -choicerestricted 1 |
||||
dict set overrides topic -default [punk::auto_exec::argdoc::default_topics] ;#if -default is present 'topic' will always appear in parsed 'values' dict |
||||
set newdef [punk::args::resolved_def -antiglobs -package_about_namespace -override $overrides ::punk::args::package::standard_about *] |
||||
lappend PUNKARGS [list $newdef] |
||||
proc about {args} { |
||||
package require punk::args |
||||
#standard_about accepts additional choices for topic - but we need to normalize any abbreviations to full topic name before passing on |
||||
set argd [punk::args::parse $args withid ::punk::auto_exec::about] |
||||
lassign [dict values $argd] _leaders opts values _received |
||||
punk::args::package::standard_about -package_about_namespace ::punk::auto_exec::argdoc {*}$opts {*}[dict get $values topic] |
||||
} |
||||
} |
||||
# end of sample 'about' function |
||||
# == === === === === === === === === === === === === === === |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
# variable PUNKARGS |
||||
# variable PUNKARGS_aliases |
||||
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::auto_exec |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::auto_exec [tcl::namespace::eval punk::auto_exec { |
||||
variable pkg punk::auto_exec |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
||||
|
||||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in new issue