Source for Windows SDX Shell Fix
package provide app-wsf 1.01
# Windows Shell Fix - WSF
# Modifys Windows Shell command's filenames to remove
# the path and then call sdx.
#
# ====================================
#
# See 'Windows SDX Shell Fix" on the TCL'ers Wiki at
# https://wiki.tcl-lang.org/9073
#
# sdx fails with Windows Shell Commands since the sdx.kit
# doesn't like the "\"s that the Windows Shell Uses
# c:\folder1\folder 2\sub folder\filename.ext
#
# It turns out that since windows will set the current directory
# to the folder in which the file was right clicked
# All that really needs to be done is to strip off the path
# of the last parameter.
#
# Windows Shell Fix does this and then calls the SDX program.
# So the scheme for Actions for a .KIT "File Type" is
# Action Command
# -----------------------------------------------------
# List "<path>tclkit-win32.upx.exe" wsp.kit lsk {%1}
# UnWrap "<path>tclkit-win32.upx.exe" wsp.kit unwrap {%1}
# Wrap "<path>tclkit-win32.upx.exe" wsp.kit wrap {%1}
# Update "<path>tclkit-win32.upx.exe" wsp.kit update {%1}
#
# where <path> looks something like "D:\@umark\dl\Starkit\"
#
# wsf:
# -receives the parameters
# -adjusts the last one which has the <path>filename.ext
# so that it just has filename.ext
# -calls sdx passing the parameters
# -provides an Exit button to Avoid the Orhan Process problem
#
# It also checks to make sure:
# -it's running under Windows
# -the last parameter is a filespec
# -the file exists (gives error if not)
# -that sdx.kit is in the same folder as wsf.kit
#
# ====================================
# By The ZipGuy email: zipguy@nonags dot com
# website: http://www.zipguy.net
#
# This is released to the public Domain as is with no warranty.
# Use this code completely at your own risk.
#
####################################################
# Change Log
#+-----------------------------------------------------------------------------+
#|Version Notes
#+-----+----------+------------------------------------------------------------+
#+Ver |MM/DD/YYYY| Description
#+-----+----------+------------------------------------------------------------+
#+1.00 |06/06/2003| Zipguy - First version Released
#+-----+----------+------------------------------------------------------------+
#+1.01 |06/07/2003| Zipguy - Small code cleanup and change leftover old name
#+ | | 'fsp' to 'wsf' in some comments and messages
#+ | | procified to display exit window and exit messages for
#+ | | errors... added exit messages to errors
#+ | | Exit after 5 minutes in case they just close the console
#+-----+----------+------------------------------------------------------------+
#+ | |
#+-----+----------+------------------------------------------------------------+
#
# ==================================
# ========= Procs Start ============
proc dbgputs { out } {
# ===========================================================
# dbgputs - displays passed messages prefixed "WSF: "
# if $debugmsgs is set to 1.
# ===========================================================
global debugmsgs
if { $debugmsgs } {
puts "WSF: $out"
} ;# END-IF
} ;# END-PROC
proc showvar { a {c ""} } {
# ===========================================================
# showvar - Displays a variables Contents - uses dbgputs
# Optional text can follow as second parameter
# (default is blank)
# ===========================================================
upvar $a b
dbgputs "Variable $a is :\[$b\] $c"
} ;# END-PROC
proc plist { a } {
# ===========================================================
# Displays a variables Contents - uses dbgputs
# ===========================================================
upvar $a b
dbgputs "List $a Contains [llength $b] Item(s):"
dbgputs "=============================="
set i 0
foreach c $b {
dbgputs "Item $i=\[$c\]"
incr i
} ;# END-FOR
dbgputs "=============================="
} ;# END-PROC
proc exit_window { } {
# ===========================================================
# provide an easy way to exit application
# ===========================================================
button .exit -text Exit -command exit
eval pack [winfo children .] -side bottom -fill both -expand 1
} ;# END-PROC
proc remap_exit_window { } {
# ===========================================================
# Remap window . by deiconifying it to recover from sdx since
# sdx does "window withdraw ."
# ===========================================================
after 500 wm deiconify .
} ;# END-PROC
proc exit_msg { } {
# ===========================================================
# exit_msg - Display exit message. Used after Error
# ===========================================================
puts "
DO NOT just close this Window,
Click the 'Exit' button
(OR Type 'exit' in this Window, and hit Enter)"
exit_window
} ;# END-PROC
proc fix_last_arg { } {
# ===========================================================
# fix_last_arg - Retrieves last arg, changing "\"s to "/"s.
# Does Validation edits on that parameter.
# Makes sure sdx.kit is in same folder as wsf.
# Calls SDX if evertying is ok.
# Provides Exit Button in Window "." for after
# sdx exits. Window users may just close
# console creating Zombie interpreter.
# ===========================================================
global argv argc argerr
# get the last parameter replacing back slashes with slashes
set lastparm [string map {\\ /} [lindex $argv end] ]
if { [string length $lastparm] < 4 } {
puts "WSF: Error - Last Parameter is Too short! $lastparm"
exit_msg
return
} ;# END-IF
# Trim Leading and Trailing brackets { } (if any)
# This may no longer be necessary
set lastparm [string trim $lastparm "\{\}"]
# Does lastparm begin with "x:/" like a windows filespec?
if {[string range $lastparm 1 2] != ":/"} {
puts "\
WSF: Error - second and third charcters of the last parameter:
$lastparm
^^
|| <--- Should be :/ and they aren't
:/
Make sure you enclosed the %1 in quotes \"%1\" in the 'Command'
for 'Action': \[[lindex $argv end-1]\]"
exit_msg
return
} ;# END-IF
# Get the proper long name (Shell may uppercase everything)
set lastparm [file attribute [file tail $lastparm] -longname]
if { [file exists $lastparm] } {
# Replace the Last Parameter with $lastparm
set argv [lreplace $argv end end $lastparm]
# Get full path and Name of sdx.kit - Should be in same Folder!
set sdx [file join [file dirname $starkit::topdir] sdx.kit]
# Is SDX there?
if { [file exists $sdx] } {
# Yes - all set so get ready to run sdx -
# Create window with "Exit" button to stop script
exit_window
puts "WSF: Done....Calling sdx.kit with args: \[$argv\]
- - - - - - - - - - - - - - - - - - - - - - - "
source $sdx
# Give sdx Exit Message
puts "\
DO NOT just close this Window.
After sdx finishes, Click the 'Exit' button
(OR Type 'exit' in this Window, and hit Enter)"
remap_exit_window
return
} else {
# No - Give Error message
puts "WSF: Error sdx.kit should be in the same folder as wsf.kit
WSF: wsf.kit is in folder [file dirname $starkit::topdir]"
exit_msg
return
} ;# END-IF
} else {
puts "WSF: File $lastparm Not Found! Exiting."
exit_msg
return
} ;# END-IF
} ;# END-PROC
# ==========Procs end ==============
# ==================================
# ==================================
# ======== Main Code Start =========
package require Tk
# 0-No messages 1-Messages
set debugmsgs 1
# Display the Console
catch {console show}
# Display the received arguments on the console in a formatted style
plist argv
# are we on windows?
if {[string compare $tcl_platform(platform) "windows"] } {
# Nope give error
puts "WSF: Error Not running on Windows. WSF is for Windows.
WSF: Platform is \[$tcl_platform(platform)\]."
exit_msg
} else {
fix_last_arg
# Exit after 5 minutes in case they just close the console
after 300000 exit
} ;# END-IF
# End of wsf.tcl code
# ======== Main Code Start =========
# ==================================