home *** CD-ROM | disk | FTP | other *** search
/ PC World 2002 May / PCWorld_2002-05_cd.bin / Software / TemaCD / activetcltk / ActiveTcl8.3.4.1-8.win32-ix86.exe / ActiveTcl8.3.4.1-win32-ix86 / uninstall.tcl < prev   
Encoding:
Text File  |  2001-10-22  |  11.2 KB  |  381 lines
  1. # -*- tcl -*-
  2. # Uninstallation script for ActiveTcl
  3. # ----------------------------------------------
  4. #
  5. # Copyright 2001, ActiveState Corp.
  6. # All Rights Reserved.
  7.  
  8. #
  9. # This should be run using the ActiveTcl wish version that we will be
  10. # uninstalling
  11. #
  12.  
  13. # This can be used with 8.3.3.3+
  14.  
  15. package require ActiveTcl 8.3.3.3
  16. package require Tk
  17. package require BWidget
  18.  
  19. option add *Button.highlightthickness 1
  20. option add *Scrollbar.highlightthickness 1
  21. option add *Text.highlightthickness 1
  22. option add *Label.highlightthickness 0
  23. option add *Label.borderWidth 0
  24.  
  25. set ::WELCOME "Uninstaller for ActiveTcl $::activestate::config(release).
  26.  
  27. Select 'Next' to begin uninstalling.
  28. "
  29.  
  30. # ----------------------------------------------
  31.  
  32. proc main {} {
  33.     wm protocol . WM_DELETE_WINDOW exit
  34.     wm title . "ActiveTcl $::activestate::config(release) Uninstaller"
  35.  
  36.     # Read the logo and create an image from it.
  37.  
  38.     set logo [image create photo -file \
  39.         [file join $::tk_library images ActiveTclSplash.gif]]
  40.  
  41.     set left [frame .left]
  42.     set ::BASE [PagesManager .right]
  43.     set sep  [frame .sep -height 2 -bd 2 -relief sunken]
  44.     set ::BTNS [frame .btns]
  45.  
  46.     label $left.logo -image $logo
  47.     pack  $left.logo -expand 1 -fill both
  48.  
  49.     grid $left $::BASE -sticky news
  50.     grid $sep -columnspan 2 -sticky ew
  51.     grid $::BTNS -columnspan 2 -sticky ew
  52.     grid columnconfig $::BTNS 0 -weight 1
  53.     grid columnconfig . 1 -weight 1
  54.     grid rowconfigure . 0 -weight 1
  55.  
  56.     set ::CANCEL [button $::BTNS.cncl -text "Cancel" -command { cancel }]
  57.     set ::NEXT   [button $::BTNS.next -text "Next >" -command {set ::WAIT 1}]
  58.  
  59.     grid $::NEXT $::CANCEL -sticky e -padx 4 -pady 8
  60.  
  61.     # Note: The procedures open and manipulate the user interface.
  62.     # They use [vwait] to enter the eventloop where needed so that
  63.     # sequencing control is not taken from [main].
  64.  
  65.     uninstall $::BASE
  66.  
  67.     exit 0
  68. }
  69.  
  70. # ----------------------------------------------
  71.  
  72. proc uninstall {pages} {
  73.     set pname uninstall
  74.     set page [$pages getframe $pname]
  75.     set firsttime 0
  76.     if {![winfo exists $page]} {
  77.     set firsttime 1
  78.     set page [$pages add $pname]
  79.     grid [ScrolledWindow $page.s -auto both] -sticky news -padx 4 -pady 4
  80.     set tw [text $page.s.t -width 20 -height 8]
  81.     $page.s setwidget $tw
  82.  
  83.     grid columnconfigure $page 0 -weight 1
  84.     grid rowconfigure $page 0 -weight 1
  85.  
  86.     $tw insert 1.0 $::WELCOME
  87.     $tw configure -state disabled
  88.     $tw tag configure error -background #CC4444
  89.  
  90.     # Accept focus even when disabled
  91.     bind $tw <1>        { focus %W }
  92.     bind $tw <Key-Return>    { next }
  93.     }
  94.     $pages raise $pname
  95.     set ::LOGWIN $page.s.t
  96.  
  97.     set res [wait_next]
  98.     if {$res < 0} { return $res }
  99.  
  100.     # At this point, there is only cancel
  101.     $::NEXT configure -state disabled
  102.  
  103.     # Uninstall stuff
  104.     do_uninstall_modules
  105.  
  106.     # This only allows exit
  107.     if {[string equal "windows" $::tcl_platform(platform)]} {
  108.     wait_next 0 "Finish"
  109.     } else {
  110.     wait_next 0 "Exit"
  111.     }
  112. }
  113.  
  114. # ----------------------------------------------
  115. # WAIT ROUTINES
  116. # ----------------------------------------------
  117.  
  118. proc next {} { $::NEXT invoke }
  119. proc cancel {} { exit 0 }
  120.  
  121. proc wait_next {{next 1} {cancel "Cancel"}} {
  122.     if {$next} { grid $::NEXT } else { grid remove $::NEXT }
  123.     $::NEXT configure -state normal -command [list set ::WAIT $next]
  124.     $::CANCEL configure -text $cancel -state normal -command cancel
  125.  
  126.     vwait ::WAIT
  127.     return $::WAIT
  128. }
  129.  
  130. # ----------------------------------------------
  131. # LOGGING ROUTINE
  132. # ----------------------------------------------
  133.  
  134. proc log {msg {type ok}} {
  135.     if {[string length $msg]} {
  136.     $::LOGWIN configure -state normal
  137.     $::LOGWIN insert end "$msg\n" $type
  138.     $::LOGWIN see end
  139.     $::LOGWIN configure -state disabled
  140.     update
  141.     }
  142. }
  143.  
  144. proc do_uninstall_modules {} {
  145.     log "\nUninstalling ActiveTcl $::activestate::config(release) ..."
  146.     log "Reading in INSTALL.LOG ..."
  147.  
  148.     set data ""
  149.     set ver $::activestate::config(release)
  150.     set isCurrentVersion 0
  151.     if {[string equal "windows" $::tcl_platform(platform)]} {
  152.     package require registry
  153.     package require dde
  154.     set key {HKEY_LOCAL_MACHINE\SOFTWARE\ActiveState\ActiveTcl}
  155.     if {[catch {registry get "$key\\$ver" ""} verdir]} {
  156.         log "Inconsistent uninstall state.\nABORTING UNINSTALL."
  157.     }
  158.     if {[catch {
  159.         set fh [open $verdir/INSTALL.LOG]
  160.         set data [read $fh]
  161.         close $fh
  162.     } err]} {
  163.         log "ERROR: $err" error
  164.     }
  165.     if {![catch {registry get $key "CurrentVersion"} curver] \
  166.         && [string equal $curver $ver]} {
  167.         set isCurrentVersion 1
  168.     } else {
  169.         # Only when we are the current version do we want
  170.         # to delete all the added keys
  171.         log "Deleting registry key $key\\$ver"
  172.         if {[catch {
  173.         registry delete "$key\\$ver"
  174.         } err]} {
  175.         log "ERROR: $err" error
  176.         }
  177.     }
  178.     log "Deleting registry key HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Uninstall\\ActiveTcl $ver"
  179.     if {[catch {
  180.         registry delete "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Uninstall\\ActiveTcl $ver"
  181.     } err]} {
  182.         log "ERROR: $err" error
  183.     }
  184.     if {[string equal "Windows NT" $::tcl_platform(os)]} {
  185.         set regPath {HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Environment}
  186.         set bindir $verdir\\bin
  187.         log "Removing \"$bindir\" from your executable path ..."
  188.         if {[catch {
  189.         set curPath [registry get $regPath Path]
  190.         registry set $regPath Path [string map -nocase \
  191.             [list "$bindir;" {}] $curPath] expand_sz
  192.         } err]} { log "ERROR: $err" error }
  193.     }
  194.     # We don't remove the .tcl in PATHEXT
  195.     } else {
  196.     if {[catch {
  197.         set fh [open [file dirname [file dirname \
  198.             [info nameofexec]]]/INSTALL.LOG]
  199.         set data [read $fh]
  200.         close $fh
  201.     } err]} {
  202.         log "ERROR: $err" error
  203.     }
  204.     }
  205.  
  206.     set dirs ""
  207.     set files ""
  208.     foreach line [split $data \n] {
  209.     if {$line == "" || [string match "#*" $line]} { continue }
  210.     switch -exact [lindex $line 0] {
  211.         MKDIR    {
  212.         set dir [lindex $line 1]
  213.         if {[file isdirectory $dir]} { lappend dirs $dir }
  214.         }
  215.         FILECOPY    {
  216.         set file [lindex $line 1]
  217.         if {[file exists $file]} { lappend files $file }
  218.         }
  219.         REGKEY    {
  220.         foreach {cmd skey value data} $line { break }
  221.         if {$isCurrentVersion} {
  222.             log "Deleting registry key $skey $value"
  223.             # We don't worry about errors here - we only
  224.             # care the the reg key is gone.
  225.             catch {registry delete $skey $value}
  226.         }
  227.         }
  228.         PROGGROUP    {
  229.         set group [lindex $line 1]
  230.         log "Deleting Program Group $group"
  231.         if {[catch {
  232.             dde execute progman progman "\[DeleteGroup($group)\]"
  233.         } err]} {
  234.             log "dde returned: $err"
  235.         }
  236.         }
  237.         default {
  238.         log "Unknown LOG instruction \"$line\""
  239.         }
  240.     }
  241.     }
  242.     if {[string equal "windows" $::tcl_platform(platform)] && \
  243.         ([llength $files] || [llength $dirs])} {
  244.     if {[info exists ::env(TEMP)]} {
  245.         set uninst [file join $::env(TEMP) at-unins.bat]
  246.     } elseif {[info exists ::env(TMP)]} {
  247.         set uninst [file join $::env(TMP) at-unins.bat]
  248.     } else {
  249.         set uninst "C:/at-unins.bat"
  250.     }
  251.     if {[catch {open $uninst w} fid]} {
  252.         log "ERROR: Unable to create bat file to remove files" error
  253.     } else {
  254.         # A little hacky, but on Windows, since we can't delete
  255.         # Ourselves, we wait on the "Finish" to launch a batch file
  256.         # which does the file and directory removal
  257.         rename exit real_exit
  258.         set cmd [concat [auto_execok start] " \"$uninst\""]
  259.         proc exit args "exec $cmd & ; uplevel 1 real_exit \$args"
  260.         puts $fid "@ECHO OFF"
  261.         puts $fid "REM This script removes the installation files"
  262.         puts $fid "REM for ActiveTcl $ver.  It can be deleted after run.\n"
  263.         puts $fid "REM Make sure we are not in the install directory."
  264.         puts $fid "CD C:\\"
  265.         if {[string equal "Windows NT" $::tcl_platform(os)]} {
  266.         # NT/2K batch scripting is a bit more enhanced
  267.         # All the extras aren't really necessary, but my purist
  268.         # scripting heart likes this better.
  269.         puts $fid "ECHO Press Return to remove all files installed\
  270.             with ActiveTcl $ver ..."
  271.         puts $fid "PAUSE > NUL"
  272.  
  273.         # Files removed in a for loop
  274.         puts $fid "FOR %%Z IN ("
  275.         foreach file [lsort -unique -decreasing $files] {
  276.             set file [file nativename \
  277.                 [file attributes $file -shortname]]
  278.             puts $fid "    $file"
  279.         }
  280.         puts $fid ") DO ("
  281.         puts $fid "    IF EXIST %%Z ("
  282.         puts $fid "        ECHO Removing file \"%%Z\""
  283.         puts $fid "        DEL /F \"%%Z\""
  284.         puts $fid "    )"
  285.         puts $fid ")"
  286.  
  287.         # Dirs removed in a for loop
  288.         puts $fid "REM Check to see that the directory is empty first"
  289.         puts $fid "FOR %%Z IN ("
  290.         # The lsort -decr sorts them in depth-first order
  291.         foreach dir [lsort -unique -decreasing $dirs] {
  292.             set dir [file nativename [file attributes $dir -shortname]]
  293.             puts $fid "    $dir"
  294.         }
  295.         puts $fid ") DO ("
  296.         puts $fid "    IF EXIST %%Z\\nul ("
  297.         puts $fid "        DIR %%Z | FIND \" 0 bytes\" > NUL"
  298.         puts $fid "        IF NOT ERRORLEVEL==1 ("
  299.         puts $fid "            ECHO Removing directory \"%%Z\""
  300.         puts $fid "            RMDIR %%Z"
  301.         puts $fid "        )"
  302.         puts $fid "    )"
  303.         puts $fid ")"
  304.  
  305.         # All done now
  306.         puts $fid "ECHO Done.  Press Return to exit ..."
  307.         puts $fid "PAUSE > NUL"
  308.         } else {
  309.         # Due to bug 232731, we can only delay on Win9*, not PAUSE
  310.         puts $fid "ECHO Removing all files installed\
  311.             with ActiveTcl $ver ..."
  312.         puts $fid "TYPE NUL | CHOICE.COM /N /CY /TY,3 >NUL"
  313.  
  314.         # This is more brute force, but Win9* batch scripting stinks.
  315.         foreach file [lsort -unique -decreasing $files] {
  316.             set file [file nativename \
  317.                 [file attributes $file -shortname]]
  318.             puts $fid "ECHO Removing \"$file\""
  319.             puts $fid "IF EXIST $file DEL $file"
  320.         }
  321.  
  322.         # The lsort -decr sorts them in depth-first order
  323.         foreach dir [lsort -unique -decreasing $dirs] {
  324.             set dir [file nativename [file attributes $dir -shortname]]
  325.             puts $fid "ECHO Removing \"$dir\""
  326.             puts $fid "IF EXIST $dir\\nul\
  327.                 DIR $dir | FIND \" 0 bytes\" > NUL"
  328.             puts $fid "IF NOT ERRORLEVEL==1 RMDIR $dir"
  329.         }
  330.  
  331.         # All done now
  332.         puts $fid "ECHO Done.  Exiting ..."
  333.         puts $fid "TYPE NUL | CHOICE.COM /N /CY /TY,2 >NUL"
  334.         }
  335.  
  336.         puts $fid "EXIT"
  337.         close $fid
  338.     }
  339.  
  340.     log ""
  341.     log "All other Tcl/Tk applications must be closed before finishing ..."
  342.     log "Press Finish to uninstall associated files ..."
  343.     } else {
  344.     foreach file $files {
  345.         log "Removing file $file"
  346.         if {[catch {file delete -force $file} err]} {
  347.         log "ERROR: $err" error
  348.         }
  349.     }
  350.  
  351.     # The lsort -decr sorts them in depth-first order
  352.     foreach dir [lsort -unique -decreasing $dirs] {
  353.         if {[llength [glob -nocomplain $dir/*]] == 0} {
  354.         log "Removing empty directory $dir"
  355.         if {[catch {file delete -force $dir} err]} {
  356.             log "ERROR: $err" error
  357.         }
  358.         } else {
  359.         log "Leaving non-empty directory $dir"
  360.         }
  361.     }
  362.  
  363.     log "Done ..."
  364.     }
  365.  
  366.     return
  367. }
  368.  
  369. # ----------------------------------------------
  370. # ----------------------------------------------
  371.  
  372. set ::SCRIPT_DIR [file dirname [info script]]
  373. set here [pwd] ; cd $::SCRIPT_DIR ; set ::SCRIPT_DIR [pwd] ; cd $here
  374.  
  375. if {[catch {
  376.     main
  377. } err]} {
  378.     catch {bgerror $err}
  379. }
  380. exit
  381.