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 / install.tcl < prev    next >
Encoding:
Text File  |  2001-10-24  |  14.3 KB  |  501 lines
  1. # -*- tcl -*-
  2. # Main installation script for ActiveTcl
  3. # --------------------------------------
  4. #
  5. # Copyright 2001, ActiveState Corp.
  6. # All Rights Reserved.
  7.  
  8. package require ActiveTcl 8.3.3.3
  9. package require Tk
  10. package require BWidget
  11.  
  12. option add *Button.highlightthickness 1
  13. option add *Scrollbar.highlightthickness 1
  14. option add *Text.highlightthickness 1
  15. option add *Label.highlightthickness 0
  16. option add *Label.borderWidth 0
  17.  
  18. proc main {} {
  19.     wm protocol . WM_DELETE_WINDOW cancel
  20.     wm title . "$::AT(NAME) $::AT(VERSION) Installer"
  21.  
  22.     # Read the logo and create an image from it.
  23.  
  24.     set logo [image create photo -file \
  25.         [file join $::tk_library images ActiveTclSplash.gif]]
  26.  
  27.     set left [frame .left]
  28.     set ::BASE [PagesManager .right]
  29.     set sep  [frame .sep -height 2 -bd 2 -relief sunken]
  30.     set ::BTNS [frame .btns]
  31.  
  32.     label $left.logo -image $logo
  33.     pack  $left.logo -expand 1 -fill both
  34.  
  35.     grid $left $::BASE -sticky news
  36.     grid $sep -columnspan 2 -sticky ew
  37.     grid $::BTNS -columnspan 2 -sticky ew
  38.     grid columnconfig $::BTNS 0 -weight 1
  39.     grid columnconfig . 1 -weight 1
  40.     grid rowconfigure . 0 -weight 1
  41.  
  42.     set ::CANCEL [button $::BTNS.cncl -text "Cancel" -command { cancel }]
  43.     set ::NEXT   [button $::BTNS.next -text "Next >" -command {set ::WAIT 1}]
  44.     set ::BACK   [button $::BTNS.back -text "< Back" -command {set ::WAIT -1}]
  45.  
  46.     grid $::BACK $::NEXT $::CANCEL -sticky e -padx 4 -pady 8
  47.     #grid remove $::BACK
  48.  
  49.     # By default, invoke the Next button on <Return>
  50.     bind . <Key-Return> { next }
  51.  
  52.     # Magic debug console invocation
  53.     bind . <Triple-3> { catch {console show} }
  54.  
  55.     # Initial license acceptance parameter
  56.     set ::ACCEPT 0
  57.     # Default install directory
  58.     set ::INSTALL_DIR [default_installdir]
  59.     # Default install error message
  60.     set ::ERRMSG ""
  61.  
  62.     # Note: The procedures open and manipulate the user interface.
  63.     # They use [vwait] to enter the eventloop where needed so that
  64.     # sequencing control is not taken from [main].
  65.  
  66.     set state 1
  67.     while {$state} {
  68.     switch -exact $state {
  69.         1 { incr state [intro $::BASE] }
  70.         2 { incr state [license $::BASE] }
  71.         3 { incr state [check_previous_install $::BASE] }
  72.         4 { incr state [get_installdir $::BASE] }
  73.         5 { incr state [overinstall $::BASE] }
  74.         6 { incr state [get_demodir $::BASE] }
  75.         7 { incr state [install_ready $::BASE] }
  76.         8 { exit 0 }
  77.         default {
  78.         return -code error "Unknow run state \"$state\""
  79.         }
  80.     }
  81.     }
  82. }
  83.  
  84. # ----------------------------------------------
  85.  
  86. proc intro {pages} {
  87.     set pname intro
  88.     set page [$pages getframe $pname]
  89.     if {![winfo exists $page]} {
  90.     set page [$pages add $pname]
  91.     label $page.msg -anchor nw -justify left -width 70 -text $::WELCOME
  92.     grid $page.msg -sticky new -padx 8 -pady 4
  93.     grid rowconfigure $page 0 -weight 1
  94.     grid columnconfigure $page 0 -weight 1
  95.     }
  96.     $pages raise $pname
  97.  
  98.     # Return value to move to next state, no BACK button for this one
  99.     return [wait_next 0]
  100. }
  101.  
  102. proc license_ok {} {
  103.     $::NEXT configure -state [expr {$::ACCEPT ? "normal" : "disabled"}]
  104. }
  105.  
  106. proc license {pages} {
  107.     set pname license
  108.     set page [$pages getframe $pname]
  109.     if {![winfo exists $page]} {
  110.     set page [$pages add $pname]
  111.     grid [ScrolledWindow $page.s -auto both] -sticky news -padx 4 -pady 4
  112.     set tw [text $page.s.t -width 20 -height 8]
  113.     $page.s setwidget $tw
  114.  
  115.     radiobutton $page.ok -variable ::ACCEPT -value 1 -anchor w \
  116.         -command license_ok \
  117.         -text "I accept the terms in the License Agreement"
  118.     radiobutton $page.no -variable ::ACCEPT -value 0 -anchor w \
  119.         -command license_ok \
  120.         -text "I do not accept the terms in the License Agreement"
  121.     grid $page.ok -stick we
  122.     grid $page.no -stick we
  123.  
  124.     grid columnconfigure $page 0 -weight 1
  125.     grid rowconfigure $page 0 -weight 1
  126.  
  127.     $tw insert end [license_text]
  128.     $tw configure -state disabled
  129.  
  130.     # Accept focus even when disabled
  131.     bind $tw <1>        { focus %W }
  132.     bind $tw <Key-Return>    { next }
  133.     }
  134.     after idle license_ok
  135.     $pages raise $pname
  136.  
  137.     # Return value to move to next state
  138.     return [wait_next]
  139. }
  140.  
  141. # ----------------------------------------------
  142. # INSTALLATION CHECK ROUTINES
  143. # ----------------------------------------------
  144.  
  145. proc check_previous_install {pages} {
  146.     # The purpose of this is to verify how we will interact with
  147.     # previous installations.  At this point, it only helps uninstall
  148.     # ActiveTcl 8.3.3.2 since that had no uninstaller.
  149.  
  150.     if {![string equal "windows" $::tcl_platform(platform)]} { return 1 }
  151.  
  152.     package require registry
  153.  
  154.     set msg ""
  155.     set key {HKEY_LOCAL_MACHINE\SOFTWARE\ActiveState\ActiveTcl}
  156.     if {![catch {registry get $key "CurrentVersion"} ver]} {
  157.     if {[catch {registry get "$key\\$ver" ""} verdir]} {
  158.         set msg "Previously installed version \"$ver\"\
  159.             partially uninstalled."
  160.     } elseif {[string match "8.3.3.2" $ver]} {
  161.         set msg "You are currently using a previous install\
  162.             of ActiveTcl $ver.\
  163.             \n\t(installed in $verdir)\
  164.             \n\nDo you want to uninstall this before continuing?"
  165.  
  166.         button $::BTNS.unst -text "Uninstall 8.3.3.2" \
  167.             -command [subst {
  168.         uninstall-8.3.3.2 [list [file join $verdir]]
  169.         # We restart this screen to start the process over.
  170.         destroy $::BTNS.unst
  171.         # The value one means continue after finishing uninstall
  172.         set ::WAIT 1
  173.         }
  174.         ]
  175.         grid $::BTNS.unst -row 0
  176.     } elseif {
  177.         ([regexp -all {\.} $ver] == 3) &&
  178.         [package vsatisfies $ver 8.3.3.2]
  179.     } {
  180.         # It is of type M.m.p.build and is >= 8.3.3.2
  181.         #
  182.         set msg "You are currently using a previous install\
  183.             of ActiveTcl $ver.\
  184.             \n\t(installed in $verdir)\
  185.             \n\It is recommended that you uninstall this before\
  186.             continuing."
  187.     } else {
  188.         set msg "Unrecognized installed ActiveTcl version \"$ver\"."
  189.     }
  190.     }
  191.  
  192.     if {[string length $msg]} {
  193.     set page [$pages getframe cinst]
  194.     if {![winfo exists $page]} {
  195.         set page [$pages add cinst]
  196.         label $page.msg -anchor nw -justify left -width 70
  197.         grid $page.msg -sticky new -padx 8 -pady 4
  198.         grid rowconfigure $page 0 -weight 1
  199.         grid columnconfig $page 0 -weight 1
  200.     }
  201.     $page.msg configure -text $msg
  202.     $pages raise cinst
  203.  
  204.     set res [wait_next]
  205.     catch {destroy $::BTNS.unst}
  206.     return $res
  207.     }
  208.  
  209.     return 1
  210. }
  211.  
  212. # ----------------------------------------------
  213.  
  214. proc browse_dir {e} {
  215.     set dir [tk_chooseDirectory]
  216.     if {[string length $dir]} {
  217.     $e delete 0 end
  218.     $e insert end $dir
  219.     }
  220. }
  221.  
  222. proc install_ok {dir} {
  223.     $::NEXT configure -state [expr {($dir == "")?"disabled":"normal"}]
  224.     return 1
  225. }
  226.  
  227. proc get_installdir {pages} {
  228.     set pname query
  229.     set page [$pages getframe $pname]
  230.     if {![winfo exists $page]} {
  231.     set page [$pages add $pname]
  232.     label $page.msg -anchor nw -justify left -width 70 \
  233.         -text "Please specify the installation directory."
  234.     label $page.errmsg -anchor nw -justify left -fg red
  235.     grid $page.msg -columnspan 2 -sticky new -padx 4 -pady 4
  236.     grid $page.errmsg -columnspan 2 -sticky new -padx 8
  237.  
  238.     entry  $page.ent -width 40 -validate key -vcmd { install_ok %P }
  239.     button $page.browse -image [Bitmap::get open] \
  240.         -command [list browse_dir $page.ent]
  241.     grid $page.ent $page.browse -sticky news
  242.  
  243.     grid rowconfigure $page 0 -weight 1
  244.     grid columnconfig $page 0 -weight 1
  245.  
  246.     bind $page.ent <Key-Return> { next }
  247.     }
  248.     $pages raise $pname
  249.     focus $page.ent
  250.  
  251.     $page.ent delete 0 end
  252.     $page.ent insert end $::INSTALL_DIR
  253.     after idle [list $page.ent validate]
  254.  
  255.     if {[string length $::ERRMSG]} {
  256.     $page.errmsg configure -text $::ERRMSG
  257.     }
  258.  
  259.     # -2 means skip over check_previous_install when going back
  260.     set res [wait_next -2]
  261.     set ::INSTALL_DIR [$page.ent get]
  262.     if {$res < 0} { return $res }
  263.  
  264.     foreach {::INSTALL_DIR ::ERRMSG} [check_installdir $::INSTALL_DIR] {break}
  265.     if {[string length $::ERRMSG]} {
  266.     # Something wrong with dir, do this again
  267.     return 0
  268.     } elseif {[string length $::AT(InstVersion)]} {
  269.     # That we are here means that overinstallation was/is allowed.
  270.     # Moved to next step (overinstall check).
  271.     set ::ERRMSG ""
  272.     return 1
  273.     } else {
  274.     # Skip the overinstall check
  275.     set ::ERRMSG ""
  276.     return 2
  277.     }
  278. }
  279.  
  280. # ----------------------------------------------
  281.  
  282. proc overinstall {pages} {
  283.     set page [$pages getframe overinstall]
  284.     if {![winfo exists $page]} {
  285.     set page [$pages add overinstall]
  286.     label $page.msg -anchor nw -justify left -width 70 \
  287.         -text [overinstall_warning]
  288.     grid $page.msg -sticky new -padx 8 -pady 4
  289.     grid rowconfigure $page 0 -weight 1
  290.     grid columnconfig $page 0 -weight 1
  291.     }
  292.     $pages raise overinstall
  293.  
  294.     return [wait_next]
  295. }
  296.  
  297. # ----------------------------------------------
  298.  
  299. proc get_demodir {pages} {
  300.     set pname demos
  301.     set page [$pages getframe $pname]
  302.     if {![winfo exists $page]} {
  303.     set page [$pages add $pname]
  304.     label $page.msg -anchor nw -justify left -width 70 \
  305.         -text "Please specify the demos directory."
  306.     label $page.errmsg -anchor nw -justify left -fg red
  307.     grid $page.msg -columnspan 2 -sticky new -padx 4 -pady 4
  308.     grid $page.errmsg -columnspan 2 -sticky new -padx 8
  309.  
  310.     entry  $page.ent -width 40 -validate key -vcmd { install_ok %P }
  311.     button $page.browse -image [Bitmap::get open] \
  312.         -command [list browse_dir $page.ent]
  313.     grid $page.ent $page.browse -sticky news
  314.  
  315.     grid rowconfigure $page 0 -weight 1
  316.     grid columnconfig $page 0 -weight 1
  317.  
  318.     bind $page.ent <Key-Return> { next }
  319.     }
  320.     $pages raise $pname
  321.     focus $page.ent
  322.  
  323.     $page.ent delete 0 end
  324.     $page.ent insert end [default_demodir $::INSTALL_DIR]
  325.     after idle [list $page.ent validate]
  326.  
  327.     if {[string length $::ERRMSG]} {
  328.     $page.errmsg configure -text $::ERRMSG
  329.     }
  330.  
  331.     # -2 means skip over overinstall warning when going back
  332.     set res [wait_next -2]
  333.     set ::DEMO_DIR [$page.ent get]
  334.     if {$res < 0} { return $res }
  335.  
  336.     foreach {::DEMO_DIR ::ERRMSG} [check_demodir $::DEMO_DIR] {break}
  337.     if {[string length $::ERRMSG]} {
  338.     # Something wrong with dir, do this again
  339.     return 0
  340.     } else {
  341.     return 1
  342.     }
  343. }
  344.  
  345. # ----------------------------------------------
  346.  
  347. proc install_ready {pages} {
  348.     set pname ready
  349.     set page [$pages getframe $pname]
  350.     set firsttime 0
  351.     if {![winfo exists $page]} {
  352.     set firsttime 1
  353.     set page [$pages add $pname]
  354.     grid [ScrolledWindow $page.s -auto both] -sticky news -padx 4 -pady 4
  355.     set tw [text $page.s.t -width 20 -height 8]
  356.     $page.s setwidget $tw
  357.  
  358.     grid columnconfigure $page 0 -weight 1
  359.     grid rowconfigure $page 0 -weight 1
  360.  
  361.     $tw insert 1.0 "Press 'Next' to begin installation\n" "" \
  362.         "     Installation Directory:\t$::INSTALL_DIR\n" "" \
  363.         "     Demos Directory:\t$::DEMO_DIR\n\n"
  364.     $tw configure -state disabled
  365.     $tw tag configure error -background #CC4444
  366.  
  367.     # Accept focus even when disabled
  368.     bind $tw <1>        { focus %W }
  369.     bind $tw <Key-Return>    { next }
  370.     }
  371.     after idle license_ok
  372.     $pages raise $pname
  373.     set ::LOGWIN $page.s.t
  374.  
  375.     set res [wait_next]
  376.     if {$res < 0} { return $res }
  377.  
  378.     # At this point, there is no going back
  379.     grid remove $::BACK $::NEXT
  380.  
  381.     # Install all the files
  382.     do_install_modules $::SCRIPT_DIR $::INSTALL_DIR $::DEMO_DIR
  383.     # Patch files or add registry stuff
  384.     do_finish $::SCRIPT_DIR $::INSTALL_DIR
  385.  
  386.     log "\n[parting_message]"
  387.  
  388.     # This only allows exit
  389.     wait_next 0 0 "Exit"
  390. }
  391.  
  392. # ----------------------------------------------
  393. # LOGGING ROUTINE
  394. # ----------------------------------------------
  395.  
  396. proc log {msg {type ok}} {
  397.     if {[string length $msg]} {
  398.     $::LOGWIN configure -state normal
  399.     $::LOGWIN insert end "$msg\n" $type
  400.     $::LOGWIN see end
  401.     $::LOGWIN configure -state disabled
  402.     update
  403.     }
  404. }
  405.  
  406. # ----------------------------------------------
  407. # WAIT ROUTINES
  408. # ----------------------------------------------
  409.  
  410. proc next {} { $::NEXT invoke }
  411. proc cancel {} { exit 0 }
  412.  
  413. proc wait_next {{back -1} {next 1} {cancel "Cancel"}} {
  414.     if {$back} { grid $::BACK } else { grid remove $::BACK }
  415.     if {$next} { grid $::NEXT } else { grid remove $::NEXT }
  416.     $::BACK configure -state normal -command [list set ::WAIT $back]
  417.     $::NEXT configure -state normal -command [list set ::WAIT $next]
  418.     $::CANCEL configure -text $cancel -state normal -command cancel
  419.  
  420.     vwait ::WAIT
  421.     return $::WAIT
  422. }
  423.  
  424. # ----------------------------------------------
  425. # SPECIAL UNINSTALLER FOR 8.3.3.2
  426. # ----------------------------------------------
  427.  
  428. proc uninstall-8.3.3.2 {dir} {
  429.     # This version came without an INSTALL.LOG
  430.     # Just be a little brutal in getting rid of it
  431.     foreach file [list \
  432.         $dir/bin/itcl32.dll \
  433.         $dir/bin/itk32.dll \
  434.         $dir/bin/tcl83.dll \
  435.         $dir/bin/tclpip83.dll \
  436.         $dir/bin/tclsh83.exe \
  437.         $dir/bin/tclx83.dll \
  438.         $dir/bin/tk83.dll \
  439.         $dir/bin/tkcon.tcl \
  440.         $dir/bin/tkx83.dll \
  441.         $dir/bin/wish83.exe \
  442.         $dir/doc/ActiveTclHelp.chm \
  443.         $dir/include \
  444.         $dir/lib/bwidget1.3.0 \
  445.         $dir/lib/dde1.1 \
  446.         $dir/lib/itcl3.2 \
  447.         $dir/lib/itk3.2 \
  448.         $dir/lib/iwidgets \
  449.         $dir/lib/iwidgets3.0.2 \
  450.         $dir/lib/reg1.0 \
  451.         $dir/lib/tcl8.3 \
  452.         $dir/lib/tcllib1.0 \
  453.         $dir/lib/tclX8.3 \
  454.         $dir/lib/tk8.3 \
  455.         $dir/lib/Tktable2.7 \
  456.         $dir/lib/tkX8.3 \
  457.         $dir/license.terms \
  458.         $dir/README.txt \
  459.         ] {
  460.     file delete -force $file
  461.     }
  462.     catch {eval file delete -force [glob -nocomplain $dir/lib/*.{sh,lib}]}
  463.     foreach subdir {bin doc include lib} {
  464.     if {[llength [glob -nocomplain $dir/$subdir/*]] == 0} {
  465.         file delete -force $dir/$subdir
  466.     }
  467.     }
  468.     if {[llength [glob -nocomplain $dir/*]] == 0} {
  469.     file delete -force $dir
  470.     }
  471.     package require registry
  472.     catch {
  473.     registry delete \
  474.         {HKEY_LOCAL_MACHINE\SOFTWARE\ActiveState\ActiveTcl} \
  475.         "CurrentVersion"
  476.     }
  477.     catch {
  478.     registry delete \
  479.         {HKEY_LOCAL_MACHINE\SOFTWARE\ActiveState\ActiveTcl\8.3.3.2}
  480.     }
  481.     catch {
  482.     package require dde
  483.     dde execute progman progman {[DeleteGroup(ActiveState ActiveTcl)]}
  484.     }
  485. }
  486.  
  487. # ----------------------------------------------
  488. # GO TO IT
  489. # ----------------------------------------------
  490.  
  491. set ::SCRIPT_DIR [file dirname [info script]]
  492. set here [pwd] ; cd $::SCRIPT_DIR ; set ::SCRIPT_DIR [pwd] ; cd $here
  493.  
  494. if {[catch {
  495.     source [file join $SCRIPT_DIR install_lib.tcl]
  496.     main
  497. } err]} {
  498.     catch {bgerror $err}
  499. }
  500. exit
  501.