Updated 2008-11-02 13:30:08 by hae ▲

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
 # http://wiki.tcl.tk/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 =========
 # ==================================

Category Tclkit Category Windows