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_lib.tcl next >
Encoding:
Text File  |  2001-10-24  |  20.4 KB  |  684 lines
  1. # -*- tcl -*-
  2. # Library to support the ActiveTcl installer scripts.
  3. # Contains the common functionality.
  4.  
  5. set ::AT(NAME)    ActiveTcl
  6. set ::AT(VERSION) 8.3.4.1
  7.  
  8. set ::WELCOME [subst -nocommand -nobackslash {
  9. Welcome to the Installer Wizard for the 
  10.  
  11.     $::AT(NAME) $::AT(VERSION) distribution
  12.  
  13. containing:
  14.     Tcl        8.3.4
  15.     Tk        8.3.4
  16.     Tcllib        1.1
  17.     TclX        8.3
  18.     [incr Tcl]    3.2
  19.     [incr Tk]    3.2
  20.     IWidgets    4.0.0
  21.     TkCon        2.2
  22.     TkTable        2.7
  23.     BWidgets    1.3.1
  24.     TclXML        2.0
  25.     TclDOM        2.0
  26.     TclSOAP        1.6
  27.     Img        1.2.4
  28.     Snack        2.1.3
  29.     TkHTML        2.0
  30.     Expect        5.32 (Unix only)
  31. }]
  32. #    TclHttpd    3.3
  33.  
  34. # Return license text
  35. #
  36. proc license_text {} {
  37.     set fh [open [file join $::SCRIPT_DIR license.terms]]
  38.     set data [read $fh]
  39.     close $fh
  40.     return $data
  41. }
  42.  
  43. # Return overinstall warning
  44. #
  45. proc overinstall_warning {} {
  46.     return "WARNING:
  47. You are about to install $::AT(NAME) $::AT(VERSION) in a directory
  48. containing an installation of $::AT(NAME) v$::AT(InstVersion).
  49.  
  50. Choose 'Next' to install over the existing files.
  51. Choose 'Back' to select a different installation directory."
  52. }
  53.  
  54. # Return message on finish
  55. #
  56. proc parting_message {} {
  57.     # Windows has no parting message
  58.     if {[string equal "windows" $::tcl_platform(platform)]} { return }
  59.  
  60.     if {![info exists ::INSTALL_DIR]} {
  61.     set ::INSTALL_DIR "<installDirectory>"
  62.     }
  63.     return "Please do not forget to extend your PATH and MANPATH variables to
  64. get access to the applications and manpages distributed with $::AT(NAME).
  65.  
  66. For a csh or compatible perform
  67.  
  68.     setenv PATH \"$::INSTALL_DIR/bin:\$PATH\"
  69.  
  70. For a sh or similar perform
  71.  
  72.     PATH=\"$::INSTALL_DIR/bin:\$PATH\"
  73.     export PATH
  74.  
  75. Some shells (bash for example) allow
  76.  
  77.     export PATH=\"$::INSTALL_DIR/bin:\$PATH\"
  78.  
  79. Similar changes are required for MANPATH"
  80. }
  81.  
  82. # df -- Determine available free space for a directory.
  83. #
  84. # Returns value in KB as a double.
  85. #
  86. proc df {{dir .}} {
  87.     # Force the result to be a double, to allow 51 bits of int precision
  88.     # and not error on large disk allocations
  89.     switch $::tcl_platform(os) {
  90.     FreeBSD - Linux - OSF1 - SunOS {
  91.         return [lindex [lindex [split [exec df -k $dir] \n] end] 3].0
  92.     }
  93.     HP-UX {
  94.         return [lindex [lindex [split [exec bdf   $dir] \n] end] 3].0
  95.     }
  96.     {Windows NT} - {Windows 95} {
  97.         set dir [file nativename $dir]
  98.         set res [eval exec [auto_execok dir] [list $dir]]
  99.         set line [lindex [split $res "\n"] end]
  100.         catch {
  101.         if {[regexp -nocase {([0-9,\.]+)\s+(bytes|KB|MB)\s+free} \
  102.             $line -> size type]} {
  103.             set size [string map {, {}} $size]
  104.             switch $type {
  105.             MB - mb { return [expr {$size * 1000.0}] }
  106.             KB - kb { return [expr {double($size)}] }
  107.             BYTES - bytes {
  108.                 if {[string match {*.*} $size]} {
  109.                 return [expr {$size / 1024.0}]
  110.                 } else {
  111.                 # has to be unbraced to allow .0 conversion to
  112.                 # double trick to work (allow 51 bit int prec)
  113.                 return [expr $size.0 / 1024.0]
  114.                 }
  115.             }
  116.             }
  117.         }
  118.         }
  119.         # Some error occured, assume we have at least 100MB
  120.         return 100000.0
  121.     }
  122.     default {error "Unable to get disk free space on $::tcl_platform(os)"}
  123.    }
  124. }
  125.  
  126. # Determine the used space for a directory.
  127. #
  128. proc du {{dir .}} {
  129.     switch -glob $::tcl_platform(os) {
  130.     FreeBSD - Linux - OSF1 - SunOS - HP-UX {
  131.         return [lindex [exec du -sk $dir] 0]
  132.     }
  133.     "Windows*" {
  134.         # Just say we need 25MB
  135.         return 25000
  136.     }
  137.     default {error "Unable get disk usage on $::tcl_platform(os)"}
  138.     }
  139. }
  140.  
  141. # Check if enough space for $src dir exists in $dest dir
  142. # Returns 0 on OK, otherwise space required
  143. #
  144. proc need_space {src dest} {
  145.     set need [du $src]
  146.     set have [df $dest]
  147.     return [expr {($need > $have) ? $need : 0}]
  148. }
  149.  
  150. proc check_installdir {installdir} {
  151.     set ::AT(InstVersion) ""
  152.     set errmsg ""
  153.     if {[string equal {} $installdir]} {
  154.     set installdir [default_installdir]
  155.     set errmsg "Please choose a non-empty directory name."
  156.     return [list $installdir $errmsg]
  157.     }
  158.  
  159.     # Change the directory into an absolute path for better comparison
  160.     # later.
  161.  
  162.     set installdir [file join [pwd] $installdir]
  163.  
  164.     # Check installation dir for existence and correct type.
  165.  
  166.     if {[file exists $installdir] && ![file isdirectory $installdir]} {
  167.     set errmsg "The chosen path \"$installdir\" is not a directory.\
  168.         \nPlease choose a directory."
  169.     return [list $installdir $errmsg]
  170.     } elseif {[string equal $installdir $::SCRIPT_DIR]} {
  171.     set errmsg "You are trying to install ActiveTcl over the directory\
  172.         \ncontaining the distributed files. This is not allowed.\
  173.         \nPlease choose a different directory."
  174.     return [list $installdir $errmsg]
  175.     } elseif {[inside_distribution $installdir]} {
  176.     set errmsg "You are trying to install ActiveTcl inside of the directory\
  177.         \ncontaining the distributed files. This is not allowed.\
  178.         \nPlease choose a different directory."
  179.     return [list $installdir $errmsg]
  180.     } elseif {[file exists $installdir]} {
  181.     # Look for an existing installation in the chosen directory.
  182.     # Issue a warning even if overwriting is allowed.
  183.  
  184.     if {
  185.         [contains_activetcl_installation $installdir] &&
  186.         ![overinstall_allowed]
  187.     } {
  188.         set errmsg "The chosen directory contains a newer installation\
  189.             \nof ActiveTcl ($::AT(InstVersion)).\
  190.             \nPlease choose a different directory."
  191.         return [list $installdir $errmsg]
  192.     }
  193.     }
  194.  
  195.     if {[catch {
  196.     set pwd [pwd]
  197.     if {![file exists $installdir]} { file mkdir $installdir }
  198.     cd $installdir
  199.     set installdir [pwd]
  200.     cd $pwd
  201.     } err]} {
  202.     set errmsg "Invalid directory choice: $err.\
  203.         \nPlease choose another directory."
  204.     } elseif {![file writable $installdir]} {
  205.     set errmsg "Cannot write to directory \"$installdir\".\
  206.         \nPlease choose another directory."
  207.     } elseif {[set need [need_space $::SCRIPT_DIR $installdir]]} {
  208.     # Check of the available space for the chosen directory against
  209.     # our requirements. Instead of using a fixed requirement we
  210.     # query the unpacked archive for its size. 
  211.  
  212.     # The check is conservative as it counts the demos as part of
  213.     # the requirements even if they will be installed in a
  214.     # different location.
  215.     set errmsg "The chosen path \"$installdir\" does not provide\
  216.         \nenough space for the installation of ActiveTcl.\
  217.         \n\nPlease choose a directory with at least ${need}K\
  218.         available space.\n"
  219.     }
  220.  
  221.     return [list $installdir $errmsg]
  222. }
  223.  
  224. proc inside_distribution {installdir} {
  225.     set plen    [llength [file split $::SCRIPT_DIR]]
  226.     set iprefix [eval [list file join] [lrange [file split $installdir] \
  227.         0 [incr plen -1]]]
  228.  
  229.     return [string equal $iprefix $::SCRIPT_DIR]
  230. }
  231.  
  232. proc check_demodir {demodir} {
  233.     set errmsg  ""
  234.     if {$demodir == ""} {
  235.     set demodir [default_demodir $::INSTALL_DIR]
  236.     set errmsg "Please choose a non-empty directory name."
  237.     } elseif {[file exists $demodir] && ![file isdirectory $demodir]} {
  238.     # Check of installation dir for existence and correct type.
  239.     set errmsg "The chosen path \"$demodir\" is not a directory.\
  240.         \nPlease choose a directory."
  241.     } elseif {[catch {
  242.     set pwd [pwd]
  243.     if {![file exists $demodir]} { file mkdir $demodir }
  244.     cd $demodir
  245.     set demodir [pwd]
  246.     cd $pwd
  247.     } err]} {
  248.     set errmsg "Invalid directory choice: $err.\
  249.         \nPlease choose another directory."
  250.     } elseif {![file writable $demodir]} {
  251.     set errmsg "Cannot write to directory \"$demodir\".\
  252.         \nPlease choose another directory."
  253.     } elseif {[set need [need_space [file join $::SCRIPT_DIR demos] $demodir]]} {
  254.     # Check the available space for the chosen directory against
  255.     # our requirements. Instead of using a fixed requirement we
  256.     # query the unpacked archive for its size. 
  257.     set errmsg "The chosen path \"$demodir\" does not provide\
  258.         \nenough space for the installation of demo scripts.\
  259.         \n\nPlease choose a directory with at least ${need}K\
  260.         available space.\n"
  261.     }
  262.  
  263.     return [list $demodir $errmsg]
  264. }
  265.  
  266. proc default_installdir {} {
  267.     if {[string equal "windows" $::tcl_platform(platform)]} {
  268.     return "C:/Tcl"
  269.     } else {
  270.     return "/usr/local/ActiveTcl"
  271.     }
  272. }
  273.  
  274. proc default_demodir {installdir} {
  275.     return [file join $installdir demos]
  276. }
  277.  
  278. proc install_log {msg} {
  279.     if {[info exists ::INSTALL_DIR]} {
  280.     if {![info exists ::INSTALL_LOG]} {
  281.         set ::INSTALL_LOG [open $::INSTALL_DIR/INSTALL.LOG w]
  282.         puts $::INSTALL_LOG "# -*- tcl -*- INSTALL.LOG v1.0\
  283.             \n# DO NOT DELETE THIS FILE.\
  284.             \n# It is needed by the uninstaller to clean up properly.\
  285.             \n# Installed on [clock format [clock seconds]]\n"
  286.         puts $::INSTALL_LOG [list FILECOPY $::INSTALL_DIR/INSTALL.LOG]
  287.     }
  288.     puts $::INSTALL_LOG $msg
  289.     }
  290. }
  291.  
  292. proc install_all {srcdir installdir} {
  293.     # Assumes existence of a [log] command.
  294.  
  295.     if {![file exists $installdir]} {
  296.     log "\tCreating directory $installdir ..."
  297.     file mkdir $installdir
  298.     }
  299.     # Note in the install log that we "made" the directory in either case,
  300.     # so it will try to delete that directory if it is empty.
  301.     install_log [list MKDIR $installdir]
  302.  
  303.     foreach f [glob -nocomplain -directory $srcdir -types {f l} *] {
  304.     log "\t[file join $installdir [file tail $f]] ..."
  305.     if {[catch {
  306.         file copy -force $f $installdir
  307.         install_log [list FILECOPY \
  308.             [file join $installdir [file tail $f]]]
  309.     } err]} { log $err error }
  310.     }
  311.  
  312.     foreach dir [glob -nocomplain -directory $srcdir -type d *] {
  313.     set tail [file tail $dir]
  314.     set inst [file join $installdir $tail]
  315.     install_all $dir $inst
  316.     }
  317. }
  318.  
  319. proc patch_shells {srcdir installdir} {
  320.     ## TODO patch shells
  321.  
  322.     # Copied from make-active.tcl
  323.     set longfakepath __________                                                        ; #  10
  324.     set longfakepath $longfakepath$longfakepath$longfakepath$longfakepath$longfakepath ; #  50
  325.     set longfakepath $longfakepath$longfakepath                                        ; # 100
  326.     set longfakepath $longfakepath$longfakepath$longfakepath$longfakepath              ; # 400
  327.     set longfakepath @$longfakepath@
  328.  
  329.     # Check string sizes before trying to patch.
  330.  
  331.     if {[string length $installdir] > [string length $longfakepath]} {
  332.     log "Can't patch shells and libraries, new path to long"
  333.     return
  334.     }
  335.  
  336.     set files [list]
  337.     lappend files [file join $installdir bin tclsh]
  338.     lappend files [file join $installdir bin wish]
  339.  
  340.     # We installed versioned variants of the shells too, so patch them also
  341.     foreach f [glob -nocomplain [file join $installdir bin tclsh\[0-9\]*]] {
  342.     lappend files $f
  343.     }
  344.     foreach f [glob -nocomplain [file join $installdir bin wish\[0-9\]*]] {
  345.     lappend files $f
  346.     }
  347.  
  348.     foreach f $files {
  349.     log "*  $f ..."
  350.     patch_file $f $longfakepath [file join $installdir lib]
  351.     }
  352.  
  353.     set files [list]
  354.     foreach f [glob [file join $installdir lib libtcl\[0-9\]*.so]] {
  355.     lappend files $f
  356.     }
  357.  
  358.     foreach f $files {
  359.     log "*  $f ..."
  360.     patch_file $f $longfakepath \
  361.         [file join $installdir lib tcl8.3] \
  362.         [file join $installdir lib]
  363.     }
  364.  
  365.     set files [list]
  366.     foreach f [glob [file join $installdir lib libtk\[0-9\]*.so]] {
  367.     lappend files $f
  368.     }
  369.  
  370.     foreach f $files {
  371.     log "*  $f ..."
  372.     patch_file $f $longfakepath \
  373.         [file join $installdir lib]
  374.     }
  375.     return
  376. }
  377.  
  378. proc patch_file {file key value {valb {}}} {
  379.     if {[string length $value] > [string length $key]} {
  380.     log "Can't patch \"$file\", value too long"
  381.     return
  382.     }
  383.     if {$valb != {}} {
  384.     if {[string length $valb] > [string length $key]} {
  385.         log "Can't patch \"$file\", second value too long"
  386.         return
  387.     }
  388.     }
  389.  
  390.     # Extend the value so that it is as long as the key, use the
  391.     # remainder of the key to do so. This is in preparation of the
  392.     # in memory patching of all places containing the key.
  393.  
  394.     set  off [string length $value]
  395.     incr off
  396.     set value $value\000[string range $key $off end]
  397.  
  398.     if {$valb != {}} {
  399.     set  off [string length $valb]
  400.     incr off
  401.     set valb $valb\000[string range $key $off end]
  402.     }
  403.  
  404.     # Assert the equality of the lengths ...
  405.     # Easier to do so here than to try and look and compare original
  406.     # and patched binaries!
  407.  
  408.     if {[string length $key] != [string length $value]} {
  409.     error "Extending the patch value went wrong !!"
  410.     }
  411.     if {$valb != {}} {
  412.     if {[string length $key] != [string length $valb]} {
  413.         error "Extending the 2nd patch value went wrong !!"
  414.     }
  415.     }
  416.  
  417.     # Patch inplace ... (and make sure that we can!)
  418.     # Read everything into memory, patch it, seek to beginning of file
  419.     # and write the modifications back.
  420.  
  421.     file attributes $file -permissions u+w
  422.  
  423.     set fh [open $file r+]
  424.     fconfigure $fh -encoding binary -translation binary
  425.  
  426.     if {$valb == {}} {
  427.     # No second value. Map everything in one go.
  428.     set data [string map [list $key $value] [read $fh]]
  429.     } else {
  430.     set data [read $fh]
  431.     set loc  [string first $key $data]
  432.  
  433.     if {$loc >= 0} {
  434.         set locb [expr {$loc + [string length $key]}]
  435.         incr loc -1
  436.         set data [string range $data 0 $loc]$value[string range $data $locb end]
  437.     }
  438.  
  439.     # Now map the second value
  440.     set data [string map [list $key $valb] $data]
  441.     }
  442.  
  443.     seek $fh 0 start
  444.     puts -nonewline $fh $data
  445.     close $fh
  446.  
  447.     file attributes $file -permissions og-w
  448.     return
  449. }
  450.  
  451. proc set_key {key value data} {
  452.     # make sure to log when we set a key
  453.     registry set $key $value $data
  454.     install_log [list REGKEY $key $value $data]
  455. }
  456.  
  457. proc patch_registry {installdir {group @@}} {
  458.     if {$group == "@@"} {
  459.     set group "ActiveState $::AT(NAME) $::AT(VERSION)"
  460.     }
  461.  
  462.     ## patch registry and create shortcuts
  463.  
  464.     ## Extending the registry
  465.  
  466.     package require registry
  467.     package require dde
  468.  
  469.     ## Create the file association
  470.  
  471.     set assoc ActiveTclScript
  472.     set ndir [file native $installdir]
  473.     set bindir $ndir\\bin
  474.     set doc  "$ndir\\doc\\ActiveTclHelp.chm"
  475.  
  476.     if {[catch {
  477.     log "\tAdding recognition of .tcl and .tbc scripts ..."
  478.     set write [file native [auto_execok write]]
  479.     if {$write == ""} {
  480.         set write notepad
  481.     }
  482.     foreach {key valueName data} [list \
  483.         .tcl            {} $assoc \
  484.         .tbc            {} $assoc \
  485.         $assoc            {} "ActiveTcl Script" \
  486.         $assoc\\DefaultIcon    {} "$bindir\\tk83.dll,0" \
  487.         $assoc\\shell\\edit    {} &Edit \
  488.         $assoc\\shell\\edit\\command {} "\"$write\" \"%1\"" \
  489.         $assoc\\shell\\open\\command {} "\"$bindir\\wish83.exe\" \"%1\" %*" \
  490.         ] {
  491.         set_key HKEY_CLASSES_ROOT\\$key $valueName $data
  492.     }
  493.     } err]} {
  494.     log "ERROR: $err" error
  495.     }
  496.  
  497.     ## Create the path information
  498.  
  499.     set key {HKEY_LOCAL_MACHINE\SOFTWARE\ActiveState\ActiveTcl}
  500.     if {[catch {
  501.     set_key $key "CurrentVersion" "$::AT(VERSION)"
  502.     set_key "$key\\$::AT(VERSION)" {} $ndir
  503.     set_key "$key\\$::AT(VERSION)\\Help" {} $doc
  504.     } err]} { log "ERROR: $err" error }
  505.  
  506.     ## Create the standard information used by Komodo to look for interpreters.
  507.  
  508.     set key {HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\tclsh.exe}
  509.     if {[catch {
  510.     set_key $key {}   "$bindir\\tclsh83.exe"
  511.     set_key $key Path "$bindir"
  512.     } err]} { log "ERROR: $err" error }
  513.  
  514.     set regPath {HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\Environment}
  515.     if {[string equal "Windows 95" $::tcl_platform(os)]} {
  516.     # Windows 95/98/ME needs path added to AUTOEXEC.BAT
  517.     log "NOTE: If you wish to have tclsh and wish in your"
  518.     log "path, you must add \"$bindir\" to the PATH environment variable"
  519.     log "in C:\\AUTOEXEC.BAT (takes effect upon restart)."
  520.     } else {
  521.     if {[catch {
  522.         log "\tAdding \"$bindir\" to your executable path ..."
  523.         set curPath [registry get $regPath Path]
  524.         if {![regexp -nocase "***=$bindir;" $curPath]} {
  525.         registry set $regPath Path "$bindir;$curPath" expand_sz
  526.         } else {
  527.         log "\t\t(\"$bindir\" already in your path)"
  528.         }
  529.     } err]} { log "ERROR: $err" error }
  530.     }
  531.     if {[catch {
  532.     log "\tAdding \".tcl\" to your pathext ..."
  533.     set curPath [registry get $regPath PATHEXT]
  534.     if {![string match -nocase "*;.tcl*" $curPath]} {
  535.         registry set $regPath PATHEXT "$curPath;.tcl" sz
  536.     } else {
  537.         log "\t\t(\".tcl\" already in your pathext)"
  538.     }
  539.     } err]} {
  540.     if {[string compare "Windows 95" $::tcl_platform(os)]} {
  541.         # Only complain on Win2K/NT
  542.         log "ERROR: $err" error
  543.     }
  544.     }
  545.  
  546.     ## Create the uninstall information
  547.  
  548.     set key "HKEY_LOCAL_MACHINE\\SOFTWARE\\Microsoft\\Windows\\CurrentVersion\\Uninstall\\ActiveTcl $::AT(VERSION)"
  549.     if {[catch {
  550.     set_key $key "DisplayName" "$::AT(NAME) $::AT(VERSION)"
  551.     set_key $key "Publisher" "ActiveState Corporation"
  552.     set_key $key "DisplayVersion" "$::AT(VERSION)"
  553.     set_key $key "HelpLink" "http://www.ActiveState.com/"
  554.     set_key $key "URLInfoAbout" \
  555.         "http://aspn.activestate.com/ASPN/Downloads/ActiveTcl/More"
  556.     set_key $key "URLUpdateInfo" \
  557.         "http://aspn.activestate.com/ASPN/Downloads/ActiveTcl/"
  558.     set uninst "\"$bindir\\wish83.exe\" \"$installdir/uninstall.tcl\""
  559.     set_key $key "UninstallString" $uninst
  560.     } err]} { log "ERROR: $err" error }
  561.  
  562.     ## Creating the shortcuts
  563.  
  564.     if {[catch {
  565.     log "\tCreating program group \"$group\" ..."
  566.     #catch {dde execute progman progman "\[DeleteGroup($group)\]"}
  567.     dde execute progman progman "\[CreateGroup($group)\]"
  568.     install_log [list PROGGROUP $group]
  569.     set demodir [file native $::DEMO_DIR]
  570.     foreach {exe name} [list \
  571.         \"$ndir\\bin\\wish83.exe\"        Wish83 \
  572.         \"$ndir\\bin\\tclsh83.exe\"        Tclsh83 \
  573.         \"$ndir\\bin\\tkcon.tcl\"        tkcon \
  574.         \"$doc\"                "ActiveTcl Help" \
  575.         \"$ndir\\README.txt\"            Readme \
  576.         \"$demodir\"                "Demos - All" \
  577.         \"$demodir\\Tk\\widget.tcl\"        "Demos - Tk" \
  578.         \"$demodir\\BWidgets\\demo.tcl\"    "Demos - BWidget" \
  579.         \"$demodir\\Iwidgets\\catalog.tcl\"    "Demos - IWidgets" \
  580.         "\"$ndir\\bin\\wish83.exe\" \"$ndir\\uninstall.tcl\"" \
  581.         "Uninstall $::AT(NAME) $::AT(VERSION)" \
  582.         ] {
  583.         dde execute progman progman "\[AddItem($exe,$name)\]"
  584.     }
  585.     } err]} { log "ERROR: $err" error }
  586.  
  587.     return
  588. }
  589.  
  590. proc do_finish {srcdir installdir} {
  591.     ## finish installation
  592.     ##
  593.     ## Windows: Registry ...
  594.     ## Unix:    Patch tclsh, wish for installed location.
  595.  
  596.     log "Finishing the installation"
  597.  
  598.     switch -glob -- $::tcl_platform(platform) {
  599.     unix    {
  600.         log "Patching the shells and libraries for the new location ..."
  601.         patch_shells $srcdir $installdir
  602.     }
  603.     win*    {
  604.         log "Extending the registry ..."
  605.         patch_registry $installdir
  606.     }
  607.     default {error "Unknown platform $tcl_platform(platform)"}
  608.     }
  609.  
  610.     log "Done"
  611.     return
  612. }
  613.  
  614. proc do_install_modules {srcdir installdir demodir} {
  615.     log "Installing ActiveTcl ..."
  616.  
  617.     install_all $srcdir $installdir
  618.  
  619.     if {[catch {
  620.     file delete [file join $installdir install.tk]
  621.     file delete [file join $installdir install.tcl]
  622.     file delete [file join $installdir install_lib.tcl]
  623.     file delete [file join $installdir install.bat]
  624.     file delete [file join $installdir install.sh]
  625.     } err]} { log $err }
  626.  
  627.     # Step II: Install the demos ...
  628.     # Do nothing if they are already in the right place.
  629.  
  630.     if {[string compare [file join $installdir demos] $demodir] != 0} {
  631.     # Copy over, then delete from place in installation
  632.  
  633.     log "Moving demos to chosen location ..."
  634.  
  635.     install_all [file join $installdir demos] $demodir
  636.     file delete -force -- [file join $installdir demos]
  637.     }
  638.  
  639.     log "Done ..."
  640.     return
  641. }
  642.  
  643. proc contains_activetcl_installation {dir} {
  644.     set ::AT(InstVersion) ""
  645.     set files [list \
  646.         [file join $dir README*] \
  647.         [file join $dir bin tclsh*] \
  648.         [file join $dir bin wish*] \
  649.         [file join $dir bin tkcon*] \
  650.         ]
  651.     if {[llength [eval glob -nocomplain $files]] == 0} {
  652.     # None of our regular files seem to be there.
  653.     return 0
  654.     }
  655.  
  656.     # Several key files were found.
  657.     # Now check the contents of the README.
  658.  
  659.     set readme [file join $dir README]
  660.     if {[string equal "windows" $::tcl_platform(platform)]} {
  661.     append readme ".txt"
  662.     }
  663.     if {[catch {open $readme} fh]} {
  664.     # Couldn't open the README file...
  665.     return 0
  666.     }
  667.     set readme [read $fh]
  668.     close $fh
  669.     # Return 0 if we didn't match, otherwise 1
  670.     return [regexp {ActiveTcl\S*\s*(\d+\.\d+\.\d+\.\d+)} $readme \
  671.         -> ::AT(InstVersion)]
  672. }
  673.  
  674.  
  675. proc overinstall_allowed {} {
  676.     # Are we allowed to overwrite the installation in the selected
  677.     # installation directory?
  678.     #
  679.     # The logic is simple - if we satisfy the current version, which
  680.     # means we are a >= version, then allow overinstallation
  681.  
  682.     return [package vsatisfies [package provide ActiveTcl] $::AT(InstVersion)]
  683. }
  684.