Arjen Markus Whereas I do not use them myself that much, many people find them useful: file associations under Windows. Or better: file extension associations. The script below uses Tcl's unknown command and an auxiliary command "assoc" to play with them in a Tcl/Tk shell.
(An alternative to the [assoc register] command is shown in Register file types under Windows; it also allows setting print and edit commands, MIME types, and the file type to be shown in the Explorer)
The idea: by typing the name of a file, the shell starts the default command associated with the file's extension. So, rather than typing:
% notepad somefile.txt
you can type:
% somefile.txt
Tcl's auto_execok does so (or does it?) with Windows' own associations, but they are global to the system. With this script you simply limit the assocations to your Tcl (current) environment.
Some notes: it is a quick and dirty implementation, for illustration only, in response to a question on the c.l.t. But it works (and it works on UNIX as well).
Arjen Markus I took the liberty of copying some text from the relevant discussion on c.l.t.: David Gravereaux answered this:
(Available in the winutils extension [L1 ])
# Setup the unknown package handler
package unknown tclPkgUnknown
# Conditionalize for presence of exec.
if {[llength [info commands exec]] == 0} {
# Some machines, such as the Macintosh, do not have exec. Also, on all
# platforms, safe interpreters do not have exec.
set auto_noexec 1
}
set errorCode ""
set errorInfo ""
# Define a log command (which can be overwitten to log errors
# differently, specially when stderr is not available)
if {[llength [info commands tclLog]] == 0} {
proc tclLog {string} {
catch {puts stderr $string}
}
}
# assoc --
# This procedure can be called to associate a command with a file
# extension:
# assoc exists $filename - checks if a filename has some association
# assoc command $filename - return the associated command and file name
# assoc register $ext $command - register the command with the extension
# (%1 will be replaced by the file name)
#
# Arguments:
# subcommand A valid subcommand
# filename A file name or an extension (the latter for "register" only)
# command The associated command (only for register)
#
# Usage:
# assoc register .txt "vi %1" (By the programmer/user)
# assoc command file.txt (By [unknown] - starts "vi file.txt")
#
namespace eval ::AssocCommands {
variable assoc_data {}
namespace export assoc
}
proc ::AssocCommands::assoc {subcommand filename {command {}}} {
variable assoc_data
switch -- $subcommand {
"exists" {
return [expr {[lsearch $assoc_data [file extension $filename]] != -1 }]
}
"register" {
set idx [lsearch $assoc_data $filename]
if { $idx == -1 } {
lappend assoc_data $filename $command
} else {
incr idx
set assoc_data [lreplace $assoc_data $idx $idx $command]
}
puts $assoc_data
return 1
}
"command" {
set idx [lsearch $assoc_data [file extension $filename]]
incr idx
set command [lindex $assoc_data $idx]
if { [string first "%1" $command] == -1 } {
append command " %1"
}
return "[string map [list %1 $filename] $command]"
}
}
}
namespace import ::AssocCommands::*
# unknown --
# This procedure is called when a Tcl command is invoked that doesn't
# exist in the interpreter. It takes the following steps to make the
# command available:
#
# 1. See if the command has the form "namespace inscope ns cmd" and
# if so, concatenate its arguments onto the end and evaluate it.
# 2. See if the autoload facility can locate the command in a
# Tcl script file. If so, load it and execute it.
# 3. If the command has the form of "filename.ext", and an
# association exists, use the associated command.
# 4. If the command was invoked interactively at top-level:
# (a) see if the command exists as an executable UNIX program.
# If so, "exec" the command.
# (b) see if the command requests csh-like history substitution
# in one of the common forms !!, !<number>, or ^old^new. If
# so, emulate csh's history substitution.
# (c) see if the command is a unique abbreviation for another
# command. If so, invoke the command.
#
# Arguments:
# args - A list whose elements are the words of the original
# command, including the command name.
proc unknown args {
global auto_noexec auto_noload env unknown_pending tcl_interactive
global errorCode errorInfo
# If the command word has the form "namespace inscope ns cmd"
# then concatenate its arguments onto the end and evaluate it.
set cmd [lindex $args 0]
if {[regexp "^namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
set arglist [lrange $args 1 end]
set ret [catch {uplevel $cmd $arglist} result]
if {$ret == 0} {
return $result
} else {
return -code $ret -errorcode $errorCode $result
}
}
# Save the values of errorCode and errorInfo variables, since they
# may get modified if caught errors occur below. The variables will
# be restored just before re-executing the missing command.
set savedErrorCode $errorCode
set savedErrorInfo $errorInfo
set name [lindex $args 0]
if {![info exists auto_noload]} {
#
# Make sure we're not trying to load the same proc twice.
#
if {[info exists unknown_pending($name)]} {
return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
}
set unknown_pending($name) pending;
set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]
unset unknown_pending($name);
if {$ret != 0} {
append errorInfo "\n (autoloading \"$name\")"
return -code $ret -errorcode $errorCode -errorinfo $errorInfo $msg
}
if {![array size unknown_pending]} {
unset unknown_pending
}
if {$msg} {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
set code [catch {uplevel 1 $args} msg]
if {$code == 1} {
#
# Strip the last five lines off the error stack (they're
# from the "uplevel" command).
#
set new [split $errorInfo \n]
set new [join [lrange $new 0 [expr {[llength $new] - 6}]] \n]
return -code error -errorcode $errorCode \
-errorinfo $new $msg
} else {
return -code $code $msg
}
}
}
if {([info level] == 1) && [assoc exists $args]} {
return [uplevel exec [assoc command $args]]
}
if {([info level] == 1) && [string equal [info script] ""] \
&& [info exists tcl_interactive] && $tcl_interactive} {
if {![info exists auto_noexec]} {
set new [auto_execok $name]
if {[string compare {} $new]} {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
set redir ""
if {[string equal [info commands console] ""]} {
set redir ">&@stdout <@stdin"
}
return [uplevel exec $redir $new [lrange $args 1 end]]
}
}
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
if {[string equal $name "!!"]} {
set newcmd [history event]
} elseif {[regexp {^!(.+)$} $name dummy event]} {
set newcmd [history event $event]
} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new]} {
set newcmd [history event -1]
catch {regsub -all -- $old $newcmd $new newcmd}
}
if {[info exists newcmd]} {
tclLog $newcmd
history change $newcmd 0
return [uplevel $newcmd]
}
set ret [catch {set cmds [info commands $name*]} msg]
if {[string equal $name "::"]} {
set name ""
}
if {$ret != 0} {
return -code $ret -errorcode $errorCode \
"error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
}
if {[llength $cmds] == 1} {
return [uplevel [lreplace $args 0 0 $cmds]]
}
if {[llength $cmds]} {
if {[string equal $name ""]} {
return -code error "empty command name \"\""
} else {
return -code error \
"ambiguous command name \"$name\": [lsort $cmds]"
}
}
}
return -code error "invalid command name \"$name\""
}