home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1999 April / macformat-075.iso / Shareware Plus / Applications / Alpha / Tcl / SystemCode / CorePackages / install.tcl < prev    next >
Encoding:
Text File  |  1999-01-31  |  23.4 KB  |  713 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Vince's Additions - an extension package for Alpha
  4.  # 
  5.  #  FILE: "install.tcl"
  6.  #                                    created: 25/7/97 {1:12:02 am} 
  7.  #                                last update: 31/1/1999 {11:27:40 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Copyright (c) 1997-1998  Vince Darley, all rights reserved
  15.  # 
  16.  #  This file contains a pretty complex package installation
  17.  #  procedure, and some more rudimentary code which queries
  18.  #  an ftp site for a list of packages and checks dates etc
  19.  #  to see if there's something new.  The idea being you can
  20.  #  then just select from a menu to download and subsequently
  21.  #  install.
  22.  #  
  23.  # Package installation:
  24.  # 
  25.  #  There is a new install mode 'Inst' which adds the Install menu.
  26.  #  Install mode is trigerred when a file's name ends in 'Install'
  27.  #  or 'INSTALL', or when the first line of the file contains the
  28.  #  letters 'install', provided in this last case, that the file
  29.  #  is not in Alpha's Tcl hierarchy.  This last case is useful so
  30.  #  that a single .tcl file can be a package and be installed by
  31.  #  Alpha using these nice scripts, without the need for a separate
  32.  #  install-script-file.  However once that .tcl file is installed,
  33.  #  if you open it you certainly wouldn't want it opened in Install mode!
  34.  #  
  35.  # Once you've opened a file in install mode:
  36.  # 
  37.  #  You can select 'install this package' from the menu.  (If the file's
  38.  #  first line contains 'auto-install' the menu item is automatically
  39.  #  selected, provided no modifier key is pressed).  In any case, this 
  40.  #  does the following: if there's an install file in the current directory
  41.  #  it is sourced.  An install file is defined as a file at the same
  42.  #  level as the current file whose name matches "*install*.tcl".
  43.  #  If no install file is found, a default (but still rather
  44.  #  sophisticated) installation takes place, by calling the procedure
  45.  #  'install::packageInstallationDialog'.  Any install script in your
  46.  #  *install*.tcl file may wish to use that procedure anyway.  For
  47.  #  instance, the installer for Vince's Additions uses just the
  48.  #  following lines in its installation file:
  49.  #  
  50.  #     install::packageInstallationDialog "Vince's Additions" "\
  51.  # These additions include a number of different packages, designed to \
  52.  # make using Alpha an even more pleasant experience!  They include a \
  53.  # more sophisticated completion and template mechanism, some bibliography \
  54.  # conversion routines, and a general projects/documents organisation scheme." 
  55.  #     
  56.  # In any case, 'install::packageInstallationDialog' does the following:
  57.  # It scans the current directory for files which may need installing.
  58.  # This includes any .tcl file which is not the *install*.tcl script.
  59.  # It also includes the same in any subdirectories of the current 
  60.  # directory.  Intelligent guesses are made as to whether files are 
  61.  # Modes, Menus, Packages, Completions, Extensions, Help files or
  62.  # UserModifications.
  63.  # 
  64.  # Extensions are *+\d.tcl files, these go in tclExtensionsFolder
  65.  # Modes are *Mode.tcl files, or all files in a subdir *Mode*
  66.  # Menus are *Menu.tcl files, or all files in a subdir *Menu*
  67.  # Completions are all files *Completions.tcl
  68.  # Help files end in 'help' or 'tutorial' (any case)
  69.  # UserModifications are any files in a UserModifications subdir.
  70.  # Packages are anything else.
  71.  # 
  72.  # UserModifications are files which a package installs once, but
  73.  # the user is expected to edit afterwards.  Hence if the package
  74.  # is reinstalled, those files are not overwritten.
  75.  # 
  76.  # Clearly if the original install file was in fact a .tcl file on
  77.  # its own (with 'install' in the first line) then we don't search
  78.  # the directory in which it sits.  This is now implemented.
  79.  # 
  80.  # ----------
  81.  # OK, we've got all the files and worked out where they should go.
  82.  # Now we build an installation dialog, from which the user can
  83.  # select 'Easy Install', or 'Custom Install'.  Easy install does
  84.  # the works, custom allows the user to choose amongst all the 
  85.  # available sub-pieces.  A sub-piece is any single item in the
  86.  # install directory: so you can package up blocks of files as a single
  87.  # package by putting them in a sub-dir.
  88.  # 
  89.  # If you hit 'Ok' installation takes place, with optional backup
  90.  # of removed files.
  91.  # 
  92.  # Currently package indices and tcl indices are then rebuilt.  This
  93.  # last thing needs to be a bit more sophisticated...
  94.  # 
  95.  # ----------
  96.  # Caveats:
  97.  # 
  98.  #     Currently not clever enough to install, say, HTML mode in the
  99.  #     way it currently is: here we wish to install all HTML files in
  100.  #     one sub-dir of the Modes dir, but we wish to allow the user to
  101.  #     pick which sub-sets of files will go in that 'HTML and CSS modes'
  102.  #     directory.  So the user could install just HTML files and ignore
  103.  #     the CSS ones.  The solution I propose is to store such items in
  104.  #     separate subfolder of the base HTML subfolder.  Such items would
  105.  #     then be sub-choices of the base 'install HTML mode' choice, and
  106.  #     when installed, would be installed directly into the HTML mode
  107.  #     dir.
  108.  #     
  109.  # I think I need more feedback before embarking on further 
  110.  # modifications to this code.
  111.  #  
  112.  # ###################################################################
  113.  ##
  114.         
  115. namespace eval install {}
  116.  
  117. proc installMenu {} {}
  118.  
  119. set installMenu "Install"
  120. set menu::items(Install) [list \
  121.     "installThisPackage" "(-" "rebuildPackageIndices" "rebuildTclIndices"]
  122.  
  123. menu::buildSome Install
  124.  
  125. proc install::rebuildPackageIndices {} { alpha::rebuildPackageIndices }
  126.  
  127. ## 
  128.  # -------------------------------------------------------------------------
  129.  # 
  130.  # "install::installThisPackage" --
  131.  # 
  132.  #  DO NOT CALL THIS PROCEDURE FROM YOUR *install.tcl INSTALLATION SCRIPT
  133.  #  IT WILL CAUSE INFINITE RECURSION AND CRASH ALPHA.  THIS PROCEDURE IS
  134.  #  DESIGNED TO SOURCE YOUR *install.tcl FILE AUTOMATICALLY IF IT EXISTS.
  135.  #  
  136.  #  Instead call install::packageInstallationDialog 
  137.  #  and install::askRebuildQuit
  138.  # -------------------------------------------------------------------------
  139.  ##
  140. proc install::installThisPackage {} {
  141.     # single-file packages by definition don't have an installer.
  142.     if {[file extension [set name [install::name]]] == ".tcl"} {
  143.     install::packageInstallationDialog "Package"
  144.     } else {        
  145.     set currD [file dirname $name]
  146.     if {[regexp -nocase {auto-install-script} [getText [minPos] [nextLineStart [minPos]]]]} {
  147.         set installer [list $name]
  148.     } else {
  149.         set installer [glob -nocomplain [file join $currD *nstall*.tcl]]
  150.         if {[llength $installer] > 1} {
  151.         alertnote "This package has two installation files.  This is bad; I'll do a standard installaton."
  152.         }
  153.     }
  154.     
  155.     if {[llength $installer] == 1} {
  156.         global installation_dir
  157.         set installation_dir $currD
  158.         # installer is a one-item list, so no need to wrap it
  159.         uplevel \#0 source $installer
  160.         unset installation_dir
  161.     } else {
  162.         install::packageInstallationDialog "Package"
  163.     }
  164.     }
  165.     global install::forcequit
  166.     install::askRebuildQuit ${install::forcequit}
  167. }
  168.  
  169. proc install::sourceUpdatedSystem {} {
  170.     global HOME install::time
  171.     if {![info exists install::time]} { return }
  172.     foreach f [glob -nocomplain [file join ${HOME} Tcl SystemCode *.tcl]] {
  173.     if {[file tail $f] == "AlphaBits.tcl" \
  174.       || [file tail $f] == "globals.tcl"} {continue}
  175.     getFileInfo $f info
  176.     if {$info(modified) > ${install::time}} {
  177.         catch [list uplevel \#0 [list source $f]]
  178.     }
  179.     }
  180. }
  181.  
  182. proc install::askRebuildQuit {{force 0}} {
  183.     alertnote "All indices must now be rebuilt for the installation to work."
  184.     if {![key::optionPressed] \
  185.       || [dialog::yesno "Shall I rebuild the indices?"]} {
  186.     install::sourceUpdatedSystem
  187.     set n [alpha::package names]
  188.     alpha::rebuildPackageIndices
  189.     set new [lremove -l [alpha::package names] $n]
  190.     if {![key::optionPressed] \
  191.       || [dialog::yesno "Shall I rebuild the Tcl indices?"]} {
  192.         rebuildTclIndices
  193.     }
  194.     auto_reset
  195.     if {[llength $new]} {
  196.         if {[dialog::yesno "You just installed the following new packages: $new; do you want to activate them at next startup?"]} {
  197.         global global::features
  198.         eval lappend global::features $new
  199.         }
  200.     }
  201.     }
  202.     if {$force || [dialog::yesno "It is recommended that you quit and restart Alpha.  Quit now?"]} {
  203.     if {$force} {alertnote "Alpha must now quit."}
  204.     if {[win::CurrentTail] == "Installation report"} {
  205.         setWinInfo read-only 0
  206.         setWinInfo dirty 1
  207.     }
  208.     quit
  209.     }
  210. }
  211.  
  212. ## 
  213.  # -------------------------------------------------------------------------
  214.  # 
  215.  # "install::openHook" --
  216.  # 
  217.  #  Used when opening an install file to check for an 'auto-install' line.
  218.  # -------------------------------------------------------------------------
  219.  ##
  220. proc install::openHook {name} {
  221.     if {![getModifiers] && [regexp -nocase {auto-install} [getText [minPos] [nextLineStart [minPos]]]]} {
  222.     moveWin $name 10000 10000
  223.     global install::_name
  224.     set install::_name $name
  225.     catch {install::installThisPackage}
  226.     unset install::_name
  227.     if {![catch {bringToFront $name}]} {
  228.         killWindow
  229.     }
  230.     }
  231. }
  232.  
  233. proc install::name {} {
  234.     global install::_name
  235.     if {[info exists install::_name]} {
  236.     return ${install::_name}
  237.     } else {
  238.     return [win::Current]
  239.     }
  240. }
  241.  
  242. proc install::readAtStartup {w} {
  243.     global alpha::readAtStartup modifiedVars
  244.     lappend alpha::readAtStartup $w
  245.     lappend modifiedVars alpha::readAtStartup
  246. }
  247.  
  248. ## 
  249.  # -------------------------------------------------------------------------
  250.  # 
  251.  # "install::packageInstallationDialog" --
  252.  # 
  253.  #  Optional arguments are as follows:
  254.  #  
  255.  #  -ignore {list of files to ignore}
  256.  #  -remove {list of files to remove from Alpha hierarchy}    
  257.  #  -rebuildquit '0 or 1'  
  258.  #      (prompts the user to rebuild indices and quit; default 1)
  259.  #  -require {Pkg version Pkg version …}
  260.  #      e.g. -require {Alpha 6.52 elecCompletions 7.99}
  261.  #  
  262.  #  and 
  263.  #  
  264.  #  -SystemCode -Modes -Menus
  265.  #  -BugFixes -Completions -Packages
  266.  #  -ExtensionsCode -UserModifications -Tools
  267.  #  
  268.  #  which force the placement of the following list of files.
  269.  # -------------------------------------------------------------------------
  270.  ##
  271. proc install::packageInstallationDialog {{pkgname "Package"} {description ""} args} {
  272.     set win::Current [install::name]
  273.     set currD [file dirname ${win::Current}]
  274.     if {[file extension ${win::Current}] == ".tcl"} {
  275.     # single file to install
  276.     set pkgname [file root [file tail ${win::Current}]]
  277.     set description "I'll install this single-file package, placing\
  278.       it in its correct location in Alpha's code base."
  279.     set rebuild [eval [list install::_packageInstallationDialog $pkgname $description \
  280.       $currD [list [file tail ${win::Current}]]] $args]
  281.     } else {        
  282.     global file::separator
  283.     set toplevels [glob -nocomplain [file join $currD *.tcl]]
  284.     eval lappend toplevels [glob -t TEXT -nocomplain [file join $currD "* *"]]
  285.     set toplevels [lremove -glob $toplevels *\[Ii\]nstall*]
  286.     set toplevels [lremove -glob $toplevels *INSTALL*]
  287.     set subdirs [glob -nocomplain "[file join $currD *]${file::separator}"]
  288.     foreach item $toplevels {
  289.         lappend items [file tail $item]
  290.     }
  291.     if {[file exists [file join $currD Changes]]} {
  292.         lappend items Changes
  293.     }
  294.     foreach dir $subdirs {
  295.         lappend items "[file tail [file dirname $dir]]${file::separator}"
  296.     }
  297.     set subdirs [lremove -glob $subdirs "*Completions${file::separator}"]
  298.     set completions [glob -nocomplain "[file join $currD Completions]${file::separator}"]
  299.     set usermods [glob -nocomplain "[file join $currD UserModifications]${file::separator}"]
  300.     eval [list install::_packageInstallationDialog $pkgname $description \
  301.       $currD $items] $args
  302.     }
  303. }
  304.  
  305. proc install::_packageInstallationDialog {{pkgname "Package"} {description ""} currD items args} {
  306.     global install::time file::separator
  307.     set install::time [now]
  308.     set install_types [list SystemCode CorePackages \
  309.       Modes Menus BugFixes Completions Packages Home \
  310.       ExtensionsCode UserModifications Help QuickStart Tools remove]
  311.     set opts(-ignore) ""
  312.     set opts(-forcequit) 0
  313.     set opts(-require) ""
  314.     foreach type $install_types {
  315.     set opts(-$type) ""
  316.     }
  317.     getOpts [concat provide ignore require rebuildquit forcequit $install_types]
  318.     
  319.     set assigned ""
  320.     foreach type $install_types {
  321.     if {$opts(-$type) != ""} {
  322.         eval lappend assigned $opts(-$type)
  323.         set $type $opts(-$type)
  324.     }
  325.     }
  326.     # check if package requires others:
  327.     array set req $opts(-require)
  328.     foreach pkg [array names req] {
  329.     eval package::reqInstalledVersion [list $pkg] $req($pkg)
  330.     }
  331.     catch {unset req}
  332.     unset opts(-require)
  333.     # check on -provide option
  334.     if {[info exists opts(-provide)]} {
  335.     array set prov $opts(-provide)
  336.     foreach pkg [array names prov] {
  337.         # check currently installed version isn't newer
  338.         if {![catch {alpha::package versions $pkg} v]} {
  339.         switch -- [alpha::package vcompare $v $prov($pkg)] {
  340.             0 {
  341.             alertnote "Package $pkg version $v is already installed.\
  342.               You may wish to cancel the installation."
  343.             }
  344.             1 {
  345.             alertnote "This installer is for $pkg version $prov($pkg)\
  346.               but version $v is already installed. You may wish to\
  347.               cancel the installation."
  348.             }
  349.         }
  350.         }
  351.     }
  352.     catch {unset prov}
  353.     unset opts(-provide)
  354.     }
  355.     # check if package has over-ridden default
  356.     global install::forcequit
  357.     set install::forcequit $opts(-forcequit)
  358.     catch {unset opts(-rebuildquit)}
  359.     unset opts(-forcequit)
  360.     # Now assume packages/modes are sub-dirs, completions are in the
  361.     # Completions dir, and toplevels are obvious from their name.
  362.     # (Mode, Menu, BugFixes or default is in Packages dir)
  363.     
  364.     # Create a dialog:
  365.     if {$description == ""} {
  366.     set description "I'll do a complete installation, placing all modes,\
  367.       menus, completions, help files, tools, extensions and packages in their\
  368.       correct locations.  In\
  369.       addition, any core bug fixes this package contains will be patched into\
  370.       Alpha's core Tcl code."
  371.     }
  372.     set y 80
  373.     set names [list "Easy Install" "Custom Install"]
  374.     lappend dial -n [lindex $names 0]
  375.     eval lappend dial \
  376.       [dialog::text "$description" 15 y 55]
  377.     incr y 10
  378.     eval lappend dial \
  379.       [dialog::checkbox "Backup removed files" 1 20 y]
  380.     eval lappend dial \
  381.       [dialog::checkbox "Show installation log" 1 20 y]
  382.     incr y 22
  383.     eval lappend dial \
  384.       [dialog::text "Click OK to continue with the installation" 15 y]
  385.     if {${install::forcequit}} {
  386.     eval lappend dial \
  387.       [dialog::text "Alpha will quit after this installation." 15 y]
  388.     }  
  389.     set othery [expr {$y +10}]
  390.     lappend dial -n [lindex $names 1]
  391.     set y 60
  392.     eval lappend dial \
  393.       [dialog::checkbox "Backup removed files" 1 20 y]
  394.     eval lappend dial \
  395.       [dialog::checkbox "Show installation log" 1 20 y]
  396.     incr y 5
  397.     foreach item $items {
  398.     if {[lsearch $opts(-ignore) $item] != -1 \
  399.       || [lsearch $assigned $item] != -1} {
  400.         continue
  401.     }
  402.     if {[string match *+*.tcl $item]} { 
  403.         lappend ExtensionsCode $item 
  404.     } elseif {[regexp "SystemCode" $item]} { 
  405.         lappend SystemCode $item 
  406.     } elseif {$item == "Changes" || [string match "Writing *" $item]} { 
  407.         lappend Help $item 
  408.     } elseif {[regexp "(H|h)elp(/|:)?$" $item]} {
  409.         lappend Help $item 
  410.     } elseif {[regexp -nocase "quick *start$" $item]} {
  411.         lappend QuickStart $item 
  412.     } elseif {[regexp "Modes(/|:)?$" $item]} { 
  413.         lappend Modes $item 
  414.     } elseif {[regexp "Menus(/|:)?$" $item]} { 
  415.         lappend Menus $item 
  416.     } elseif {[regexp "Docs(/|:)" $item]} { 
  417.         lappend Home $item 
  418.     } elseif {[regexp "Tools" $item]} { 
  419.         lappend Tools $item 
  420.     } elseif {[regexp -nocase "mode(:|/|\.tcl)?$" $item]} { 
  421.         lappend Modes $item 
  422.     } elseif {[regexp -nocase "menu(:|/|\.tcl)?$" $item]} { 
  423.         lappend Menus $item 
  424.     } elseif {[regexp -nocase "bugfixes" $item]} {
  425.         lappend BugFixes $item
  426.     } elseif {[regexp "Completions" $item]} {
  427.         lappend Completions $item
  428.     } elseif {[regexp "Tools" $item]} {
  429.         lappend Tools $item
  430.     } elseif {[regexp "UserModifications" $item]} {
  431.         lappend UserModifications $item
  432.     } elseif {[regexp "CorePackages" $item]} {
  433.         lappend CorePackages $item
  434.     } else {
  435.         lappend Packages $item
  436.     }
  437.     }
  438.     set x 20
  439.     set continue 0
  440.     foreach items $install_types {
  441.     if {[info exists $items]} {
  442.         if {$continue} {
  443.         set continue 0
  444.         if {$y + 10 > $othery} { set othery [expr {$y +10}] }
  445.         set y 100
  446.         incr x 190
  447.         eval lappend dial [dialog::text "continued…" $x y]
  448.         }
  449.         if {$items != "remove"} {
  450.         set t "Install $items"
  451.         } else {
  452.         set t "Remove obsolete files"
  453.         }
  454.         eval lappend dial [dialog::text $t $x y]
  455.         foreach item [set $items] {
  456.         lappend options [list $items $item]
  457.         regsub "\[/:\]\$" $item " ƒ" item
  458.         eval lappend dial [dialog::checkbox $item 1 [expr {$x + 20}] y]
  459.         if {$y > 360} {
  460.             set continue 1
  461.         }
  462.         }
  463.     }
  464.     }
  465.     incr y 10
  466.     set h [expr {$othery > $y ? $othery : $y}]
  467.     set yb [expr {$h - 70}]
  468.     set w [expr {390 + ($x/2)}]
  469.     set dials [list dialog -w $w -h $h]
  470.     set y 10
  471.     eval lappend dials [dialog::text "$pkgname installation options" 20 y 35]
  472.     eval lappend dials [dialog::button "OK" [expr {$w -80}] yb]
  473.     eval lappend dials [dialog::button "Cancel" [expr {$w -80}] yb]
  474.     set res [eval [concat $dials [list -m [concat [list [lindex $names 0]] $names] 250 10 405 30]  $dial]]
  475.     if {[lindex $res 1]} { error "Cancel" } 
  476.     # cancel was pressed
  477.     set easy_install [expr 1 - [lsearch $names [lindex $res 2]]]
  478.     if {$easy_install} {
  479.     set make_backup [lindex $res 3]
  480.     set make_log [lindex $res 4]
  481.     } else {
  482.     set make_backup [lindex $res 5]
  483.     set make_log [lindex $res 6]
  484.     }
  485.     if {$make_backup} {
  486.     global HOME
  487.     set make_backup [file join $HOME InstallationBackup]
  488.     } else {
  489.     set make_backup ""
  490.     }
  491.     set i 6
  492.     global install::_ignore install::log
  493.     set install::_ignore $opts(-ignore)
  494.     set install::log ""
  495.     foreach o $options {
  496.     incr i
  497.     if {!$easy_install && ![lindex $res $i]} { continue }
  498.     set type [lindex $o 0]
  499.     set name [lindex $o 1]
  500.     message "Installing $type '$name'"
  501.     install::files $type $currD $name $make_backup
  502.     }
  503.     unset install::_ignore
  504.     if {$make_log} {
  505.     install::showLog
  506.     } else {
  507.     unset install::log
  508.     }
  509. }
  510.  
  511. proc install::showLog {{title "Installation report"}} {
  512.     global install::log
  513.     new -g 0 160 640 300 -n $title -info \
  514.       [expr {${install::log} == "" ? \
  515.       "No changes were made.  You must have already installed this package." \
  516.       : "${install::log}End of report."}]
  517.     unset install::log
  518. }
  519.  
  520.  
  521. # Install 'name' from $currD into where it should go    
  522. # If 'name' ends in a colon, it's a directory.  We can just 
  523. # use glob to get a list!
  524. proc install::files {type from name backup} {
  525.     global HOME PREFS tclExtensionsFolder file::separator
  526.     set flist [glob -nocomplain [file join $from $name*]]
  527.     switch -- $type {
  528.     Tools {
  529.         set to [file join ${HOME} Tools]
  530.         foreach f $flist {
  531.         install::file_to $f $to $backup
  532.         }        
  533.     }        
  534.     remove {
  535.         if {![catch {file::standardFind $name} what]} {
  536.         if {[regexp "(/|:)\$" $name]} {
  537.             foreach f [glob -nocomplain ${what}*] {
  538.             file::removeOne $f $backup
  539.             }
  540.             install::log "Removed dir: $name"
  541.             rmdir $what
  542.         } else {
  543.             file::removeOne $what $backup
  544.         }
  545.         }
  546.     }
  547.     SystemCode -
  548.     Modes -
  549.     Menus - 
  550.     Packages {
  551.         set to [file join ${HOME} Tcl ${type}]
  552.         if {[regexp "(.*)(/|:)\$" $name "" first] && $first != $type} {
  553.         install::file_to $name $to
  554.         set to [file join $to [file dirname $name]]
  555.         }
  556.         foreach f $flist {
  557.         install::file_to $f $to $backup
  558.         }        
  559.     }
  560.     CorePackages {
  561.         set to [file join ${HOME} Tcl SystemCode CorePackages]
  562.         if {[regexp "(.*)(/|:)\$" $name "" first] && $first != $type} {
  563.         install::file_to $name $to
  564.         set to [file join $to [file dirname $name]]
  565.         }
  566.         foreach f $flist {
  567.         install::file_to $f $to $backup
  568.         }        
  569.     }
  570.     QuickStart {
  571.         set to [file join ${HOME} QuickStart]
  572.         foreach f $flist {
  573.         install::file_to $f $to $backup
  574.         install::readAtStartup [file join ${HOME} QuickStart [file tail $f]]
  575.         }        
  576.     }
  577.     Home {
  578.         set to "${HOME}"
  579.         if {[regexp "(.*)(/|:)\$" $name "" first] && $first != $type} {
  580.         install::file_to $name $to
  581.         set to [file join $to [file dirname $name]]
  582.         }
  583.         foreach f $flist {
  584.         install::file_to $f $to $backup
  585.         }        
  586.     }
  587.     Help {
  588.         set to [file join ${HOME} Help]
  589.         foreach f $flist {
  590.         install::file_to $f $to $backup
  591.         }        
  592.     }        
  593.     BugFixes {
  594.         foreach f $flist {
  595.         procs::patchOriginalsFromFile $f 0
  596.         install::log "Installed patches from $f"
  597.         }
  598.     }
  599.     Completions {
  600.         set to [file join ${HOME} Tcl Completions]
  601.         foreach f $flist {
  602.         install::file_to $f $to $backup
  603.         }        
  604.     }
  605.     UserModifications {
  606.         set to [file join ${HOME} Tcl UserModifications]
  607.         global install::noreplace
  608.         set install::noreplace 1
  609.         foreach f $flist {
  610.         install::file_to $f $to $backup
  611.         }        
  612.         set install::noreplace 0
  613.     }        
  614.     ExtensionsCode {
  615.         if {![info exists tclExtensionsFolder]} {
  616.         set tclExtensionsFolder $PREFS
  617.         alertnote "This installation contains extension\
  618.           (+.tcl) files.  These require\
  619.           the 'Smarter Source' package, which you do not have\
  620.           installed.  I've put the extension\
  621.           files in your prefs directory, but they will not operate\
  622.           without that package."
  623.         }
  624.         set to "$tclExtensionsFolder"
  625.         foreach f $flist {
  626.         install::file_to $f $to $backup
  627.         }
  628.     }    
  629.     }
  630.     message "File installation complete"
  631. }
  632.  
  633. proc install::log {text} {
  634.     global install::log
  635.     append install::log "${text}\r"
  636. }
  637.  
  638. proc install::file_to {file to {backup ""}} {
  639.     if {[regexp -nocase {(help|tutorial)$} [file tail $file]] \
  640.       || ([file tail $file] == "Changes")} {
  641.     global HOME
  642.     install::_file_to $file [file join $HOME Help] $backup
  643.     } elseif {[regexp {\+[0-9]*.tcl} [file tail $file]]} {
  644.     global tclExtensionsFolder PREFS
  645.     if {![info exists tclExtensionsFolder]} { set tclExtensionsFolder $PREFS }
  646.     install::_file_to $file $tclExtensionsFolder $backup
  647.     } else {
  648.     if {[file isdirectory $file]} {
  649.         set to [file join ${to} [file tail $file]]
  650.         if {![file exists $to]} {mkdir $to}
  651.         foreach f [glob [file join $file *]] {
  652.         install::file_to $f $to $backup
  653.         }
  654.     } else {
  655.         install::_file_to $file $to $backup
  656.     }
  657.     }
  658. }
  659.  
  660. proc install::_file_to {file to {backup ""}} {
  661.     global install::_ignore file::separator
  662.     foreach suffix ${install::_ignore} {
  663.     if {[string match *${file::separator}${suffix} $file] \
  664.       ||  [string match ${suffix} $file]} {
  665.         return
  666.     }
  667.     }
  668.     message "Installing [file tail $file]"
  669.     if {[file::ensureDirExists $to]} {
  670.     install::log "Created dir '$to'"
  671.     }
  672.     if {[regexp "(/|:)\$" $file]} {
  673.     # Install a directory
  674.     if {[file::ensureDirExists [file join ${to} [file tail [file dirname $file]]]]} {
  675.         install::log "Created dir '[file join ${to} [file tail [file dirname $file]]]'"
  676.     }
  677.     return
  678.     }
  679.     set files [glob -nocomplain "${file}*"]
  680.     global install::noreplace
  681.     if {[info exists install::noreplace] && ${install::noreplace}} {
  682.     foreach ff $files {
  683.         foreach suffix ${install::_ignore} {
  684.         if {[string match *${suffix} $file]} { continue }
  685.         }
  686.         set f [file tail $ff]
  687.         if {![file exists [file join $to $f]]} {
  688.         if {[file exists "$ff" ]} {
  689.             cp "$ff" [file join $to $f]
  690.             install::log "copied '[file tail $ff]' to '[file join $to $f]'"
  691.         }
  692.         }
  693.     }
  694.     } else {
  695.     foreach ff $files {
  696.         foreach suffix ${install::_ignore} {
  697.         if {[string match *${suffix} $file]} { continue }
  698.         }
  699.         set f [file tail $ff]
  700.         
  701.         if {[regexp "tclIndexx?" [file tail $f]]} {
  702.         continue
  703.         }
  704.         
  705.         file::replaceSecondIfOlder "$ff" [file join ${to} $f] 0 $backup
  706.     }
  707.     }
  708. }
  709.  
  710.  
  711.  
  712.  
  713.