home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1999 April / macformat-075.iso / Shareware Plus / Applications / Alpha / Tcl / SystemCode / CorePackages / fileManipulation.tcl < prev    next >
Encoding:
Text File  |  1999-01-31  |  25.6 KB  |  867 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Vince's Additions --- an extension package for Alpha
  4.  # 
  5.  #  FILE: "fileManipulation.tcl"
  6.  #                                    created: 24/2/98 {1:57:08 pm} 
  7.  #                                last update: 31/1/1999 {11:26:57 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.  # Mostly Copyright (c) 1998  Vince Darley
  15.  # 
  16.  # See the file "license.terms" for information on usage and redistribution
  17.  # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  18.  # ###################################################################
  19.  ##
  20.  
  21. # extension declaration
  22. alpha::extension fileManipulation 1.02 {
  23. } maintainer {
  24.     {Vince Darley} <darley@fas.harvard.edu> <http://www.fas.harvard.edu/~darley/>
  25. } 
  26.  
  27. namespace eval file {}
  28.  
  29. proc file::showInFinder {{f {}}} {
  30.     if {$f == ""} {set f [win::Current]}
  31.     if {![file exists "$f"]} {
  32.     message "ERROR: FILE NOT FOUND: \"$f\""
  33.     return
  34.     }
  35.     switchTo Finder
  36.     AEBuild Finder misc mvis "----" [makeAlis $f]
  37. }
  38.  
  39. proc file::tryToOpen {{fname ""}} {
  40.     if {$fname == ""} {set fname [getSelect]}
  41.     set f [file join [file dirname [win::Current]] $fname]
  42.     if {[file exists $f]} {
  43.     file::openQuietly $f
  44.     } else {
  45.     alertnote "Sorry, I couldn't find that file.  You could install\
  46.       Vince's Additions which includes better include-path handling."
  47.     }
  48. }
  49.  
  50. proc file::ensureDirExists {dir} {
  51.     if {![file exists $dir]} {
  52.     if {$dir == ""} {
  53.         error "Can't create the folder because the disk doesn't exist."
  54.     }
  55.     file::ensureDirExists [file dirname $dir]
  56.     file mkdir $dir
  57.     return 1
  58.     }
  59.     return 0
  60. }
  61.  
  62. proc file::openAny {file} {
  63.     getFileInfo $file a
  64.     if {![info exists a(type)] || ($a(type) == "TEXT")} {
  65.     edit $file
  66.     return
  67.     } else {
  68.     sendOpenEvent -noreply Finder "${file}"
  69.     }
  70. }
  71.  
  72. proc file::renameTo {} {
  73.     set c [win::Current]
  74.     if {![file exists $c]} { alertnote "Not a file window!" ; return }
  75.     set new [prompt "New name for file:" [file tail $c]]
  76.     if {[file exists [set to [file join [file dirname $c] $new]]]} {
  77.     alertnote "Already exists!"
  78.     return
  79.     }
  80.     killWindow
  81.     file rename $c $to
  82.     edit $to
  83. }
  84.  
  85. proc file::standardFind {f} {
  86.     global HOME auto_path PREFS tclExtensionsFolder file::separator
  87.     set dirs $auto_path
  88.     lappend dirs [file join $HOME Tcl Completions] $PREFS \
  89.       [file join $HOME Help] [file join $HOME Tools]
  90.     if {[info exists tclExtensionsFolder]} { lappend dirs $tclExtensionsFolder }
  91.     foreach dir $dirs {
  92.     if {[file exists [file join ${dir} ${f}]]} {
  93.         return [file join ${dir} ${f}]
  94.     }
  95.     }
  96.     if {[regexp ${file::separator} $f]} {
  97.     foreach dir $dirs {
  98.         if {[file exists [file join [file dirname $dir] $f]]} {
  99.         return [file join [file dirname $dir] $f]
  100.         }
  101.     }
  102.     }
  103.     error "Not found"    
  104. }
  105.  
  106. ## 
  107.  # -------------------------------------------------------------------------
  108.  # 
  109.  # "file::hyperOpen" --
  110.  # 
  111.  #  Called by embedded hyperlinks; we look through an installation
  112.  #  directory (and subdirs) if it is known, then the prefs directory, 
  113.  #  then all of the auto_path.  If the file is of type TEXT, we open
  114.  #  it, else we ask the finder to open it.
  115.  # -------------------------------------------------------------------------
  116.  ##
  117. proc file::hyperOpen { name } {
  118.     global PREFS tclExtensionsFolder auto_path file::separator
  119.     set currD [list [file dirname [win::Current]]]
  120.     set dirs [glob -nocomplain "[file join $currD *]${file::separator}"]
  121.     foreach d $dirs {
  122.     lappend currD [string trimright $d ${file::separator}]
  123.     }
  124.     lappend currD $PREFS 
  125.     if {[info exists tclExtensionsFolder]} { lappend currD $tclExtensionsFolder }
  126.     foreach d [concat $currD $auto_path] {
  127.     if {[file exists [file join $d $name]]} {
  128.         file::openAny [file join $d $name]
  129.         return
  130.     }
  131.     }
  132.     beep
  133.     message "Sorry, couldn't find $name"
  134. }
  135. ## 
  136.  # -------------------------------------------------------------------------
  137.  # 
  138.  # "file::hyperHelpOpen" --
  139.  # 
  140.  #  Called by embedded hyperlinks; we look through an installation
  141.  #  directory (and subdirs) if it is known, then the prefs directory, 
  142.  #  then all of the auto_path.
  143.  # -------------------------------------------------------------------------
  144.  ##
  145. proc file::hyperHelpOpen { name } {
  146.     global HOME auto_path file::separator
  147.     set currD [list [file dirname [win::Current]]]
  148.     set dirs [glob -nocomplain "[file join $currD *]${file::separator}"]
  149.     foreach d $dirs {
  150.     lappend currD [string trimright $d ${file::separator}]
  151.     }
  152.     lappend currD $HOME:Help
  153.     foreach d [concat $currD $auto_path] {
  154.     set ns [glob -nocomplain [file join $d ${name}*]]
  155.     foreach n $ns {
  156.         if {[regexp -nocase "help" [file tail $n]]} {
  157.         edit $n
  158.         return
  159.         }
  160.     }
  161.     }
  162.     beep
  163.     message "Sorry, couldn't find a help file for $name"
  164. }
  165.  
  166. ## 
  167.  # -------------------------------------------------------------------------
  168.  # 
  169.  # "file::jumpToCode" --
  170.  # 
  171.  #  It creates a hyperlink to a specific string in a code file, without
  172.  #  requiring a mark to be defined there. It was handy for identifying places 
  173.  #  in other packages that potentially collide with my key-bindings.
  174.  #  
  175.  #  Author: Jon Guyer.
  176.  # -------------------------------------------------------------------------
  177.  ##
  178. proc file::jumpToCode {text file code} {
  179.     set hyper {edit -c }
  180.     append hyper $file
  181.     append hyper { ; set pos [search -f 1 -r 1 "}
  182.     append hyper $code
  183.     append hyper {"] ; select [lindex $pos 0] [lindex $pos 1]}
  184.     file::searchAndHyperise $text $hyper 0 3
  185. }
  186.  
  187.  
  188. proc file::sameModifiedDate {a b} {
  189.     getFileInfo $a infoa
  190.     getFileInfo $b infob
  191.     # bigger = newer
  192.     set ma $infoa(modified)
  193.     set mb $infob(modified)
  194.     return [expr {$ma == $mb ? 1 : 0}]
  195. }
  196.  
  197. proc file::secondIsOlder {a b} {
  198.     getFileInfo [stripNameCount $a] infoa
  199.     getFileInfo [stripNameCount $b] infob
  200.     # bigger = newer
  201.     set ma $infoa(modified)
  202.     set mb $infob(modified)
  203.     return [expr {$ma > $mb ? 1 : 0}]
  204. }
  205.  
  206. proc file::replaceSecondIfOlder {a b {complain 1} {backup ""}} {
  207.     if {![file exists $a]} { error "First does not exist!" }
  208.     if {[file exists $b]} {
  209.     if {[file::secondIsOlder $a $b]} {
  210.         file::remove [file dirname $b] [list [file tail $b]] $backup
  211.         file copy $a $b
  212.         install::log "Copied [file tail $a] to $b"
  213.         return 1
  214.     } elseif {[file::secondIsOlder $b $a]} {
  215.         install::log "The pre-existing [file tail $a] is newer than the one which was to be installed."
  216.     }
  217.     } elseif {$complain} { 
  218.     error "Second does not exist!"
  219.     } else {
  220.     file copy $a $b
  221.     install::log "Copied [file tail $a] to $b"
  222.     } 
  223.     return 0
  224. }
  225.  
  226. proc file::removeCheckingWins {f} {
  227.     install::log "Removed $f"
  228.     if {[set i [lsearch -regexp [winNames -f] "^[quote::Regfind $f]( <\d+>)?$"]] != -1} {
  229.     bringToFront [lindex [winNames -f] $i]
  230.     killWindow
  231.     file delete $f
  232.     return 1
  233.     }
  234.     file delete $f
  235.     return 0
  236. }
  237.  
  238. proc file::remove {to files {backup ""}} {
  239.     foreach f $files {
  240.     if {[file exists [file join $to $f]]} {
  241.         file::removeOne [file join $to $f] $backup
  242.     }
  243.     }
  244. }
  245.  
  246. proc file::removeOne {f {backup ""}} {
  247.     set ff [file tail $f]
  248.     message "Removing old '$ff'"
  249.     if {${backup} != ""} {
  250.     if {![file exists $backup]} { file mkdir $backup }
  251.     set i ""
  252.     while {[file exists [file join $backup $ff$i]]} {
  253.         if {$i == ""} { set i 0}
  254.         incr i
  255.     }
  256.     file copy $f [file join ${backup} $ff$i]
  257.     }
  258.     file::removeCheckingWins $f
  259. }
  260.  
  261. proc file::getSig {f} {
  262.     if {[catch {getFileInfo $f arr}]} { return "" }
  263.     return $arr(creator)
  264. }
  265.  
  266.  
  267. ## 
  268.  # ----------------------------------------------------------------------
  269.  #     
  270.  #    "file::searchAndHyperise"    --
  271.  #    
  272.  #     Scans through an entire file for a    particular string or
  273.  #     regexp, and attaches a    hyperlink of the specified form
  274.  #     (regsub'ed    if desired)    to the original    string.
  275.  #            
  276.  #    Side effects:
  277.  #     Many hyperlinks will be embedded in your file
  278.  #    
  279.  #    Arguments:
  280.  #     Look for 'text', replace with 'link', doing both with a regexp
  281.  #     if signified (regexp = 1), using colour 'col', and offsetting
  282.  #     the link start and end by 'startoff' and 'endoff' respectively.
  283.  #     This last bit is so you can search for a large pattern, but only
  284.  #     embed a link in a smaller part of it.
  285.  #     
  286.  #    Examples: 
  287.  #     see 'proc install::hyperiseUrls'
  288.  # ----------------------------------------------------------------------
  289.  ##
  290. proc file::searchAndHyperise { text link {regexp 0} {col 3} {startoff 0} {endoff 0}} {
  291.     set pos [minPos]
  292.     catch {
  293.     while 1 {
  294.         set inds [search -s -f 1 -r $regexp -- $text $pos]
  295.         set from [lindex $inds 0]
  296.         set to [lindex $inds 1]
  297.         set realfrom $from
  298.         set realto $to
  299.         set realfrom [pos::math $realfrom + $startoff]
  300.         set realto [pos::math $realto + $endoff]
  301.         text::color $realfrom $realto $col
  302.         if {$link != ""} {
  303.         if {$regexp} {
  304.             regsub $text [getText $from $to] "$link" llink
  305.         } else {
  306.             set llink $link
  307.         }
  308.         text::hyper $realfrom $realto $llink
  309.         }
  310.         set pos $to
  311.     }    
  312.     }
  313.     refresh
  314. }
  315. proc file::multiSearchAndHyperise {args} {
  316.     while 1 {
  317.     set text [lindex $args 0]
  318.     set link [lindex $args 1]
  319.     set args [lrange $args 2 end]
  320.     if {$text == ""} {return}
  321.     file::searchAndHyperise $text $link
  322.     }
  323. }
  324.  
  325. ## 
  326.  # -------------------------------------------------------------------------
  327.  # 
  328.  # "file::findAllInstances" --
  329.  # 
  330.  #  Returns all instances of a given pattern in a file.  This is a regexp
  331.  #  search, and the pattern must match all the way to the end of the 
  332.  #  file.  Here is an example usage:
  333.  #  
  334.  #      set pat2 {^.*\\(usepackage|RequirePackage)\{([^\}]+)\}(.*)$}
  335.  #      set subpkgs [file::findAllInstances $filename $pat2 1]
  336.  #  
  337.  #  Notice the pattern ends in '(.*)$', this is important.
  338.  #  Notice that since there is one extra '()' pair in the regexp,
  339.  #  we give '1' as the last argument.
  340.  #  
  341.  #  WARNING:  Calling this procedure incorrectly can easily result
  342.  #  in an infinite loop.  This will tend to crash Alpha and is hard
  343.  #  to debug using trace-dumps, because Alpha will tend to crash
  344.  #  whilst tracing too!  To debug, modify the 'while' loop so that it
  345.  #  also increments a counter, and stops after a few iterations.
  346.  # -------------------------------------------------------------------------
  347.  ##
  348. proc file::findAllInstances {filename searchString {extrabrackets 0}} {
  349.     # Get the text of the file to be searched:
  350.     if {[lsearch [winNames -f] $filename] >= 0} {
  351.     set fileText [getText -w $filename [minPos] [maxPos -w $filename]]
  352.     } elseif {[file exists $filename]} {
  353.     set fd [open $filename]
  354.     set fileText [read $fd]
  355.     close $fd
  356.     } else {
  357.     return ""
  358.     }
  359.     # Search the text for the search string:
  360.     while {[string length $fileText]} {
  361.     set dmy [lrange "d d d d d d" 0 $extrabrackets]
  362.     if {[eval regexp [list $searchString] [list $fileText] $dmy match fileText]} {
  363.         lappend matches $match
  364.     } else {
  365.         break
  366.     }
  367.     }
  368.     if {[info exists matches]} {
  369.     return $matches
  370.     } else {
  371.     return ""
  372.     }
  373. }
  374.  
  375. ## 
  376.  # -------------------------------------------------------------------------
  377.  #     
  378.  #    "file::getModeForFile" --
  379.  #    
  380.  #     This is an    adaptation of Tom Pollard's    emacs mode setting facility.
  381.  #     I call    it from    activateHook, which    means it takes effect before
  382.  #     the window    yet    exists,    so you don't get a double redraw.
  383.  #     Here are Tom's    comments from the original:
  384.  #       
  385.  #       # Emacs-style mode selection    using first    nonblank line of file
  386.  #       #
  387.  #       # Checks    for    interpreter    line "#!/dir/subdir/command    ...", or
  388.  #       # explicit major    mode election "-*-Mode:    vars ...-*-".
  389.  #       #
  390.  #       # "command" or "Mode" is    compared (case-insensitively) to Alpha mode
  391.  #       # names and first matching mode is used for the file.
  392.  #       #
  393.  #       # Author:   Tom Pollard    <pollard@chem.columbia.edu>
  394.  #       # Modified: 9/11/95
  395.  #    
  396.  #    Note: this proc actually opens the file for reading.  It _must_ close
  397.  #    the file before exiting.  If you modify this proc, make sure that
  398.  #    happens!
  399.  #    
  400.  #  To Do: I currently use 'file exists' to catch activation of non-file 
  401.  #           windows such as '*tcl shell*'. There may be a better way.
  402.  #
  403.  # --Version--Author------------------Changes-------------------------------  
  404.  #      1.0      <darley@fas.harvard.edu> first modification from Tom Pollard's
  405.  #    1.1     <darley@fas.harvard.edu> copes with a common Tcl/Tk exec trick.
  406.  #    1.2     <darley@fas.harvard.edu> can map creators if desired.
  407.  # -------------------------------------------------------------------------
  408.  ##
  409. if {[info tclversion] < 8.0} {
  410. proc file::getModeForFile {name} {
  411.     # if it doesn't exist as a file it's probably a funny window, so return
  412.     if {![file exists "$name"]} { 
  413.     if {[string first "* Trace" $name] == "0" } {
  414.         zoom
  415.         toggleScrollbar
  416.         return Tcl
  417.     }
  418.     return
  419.     }
  420.     global modeCreator
  421.     if {[info exists modeCreator([set sig [getFileSig $name]])]} {
  422.     return $modeCreator($sig)
  423.     }
  424.     if {[catch [list open "$name" r] fid]} { return }
  425.     # find first non-empty line. Return if we fail
  426.     for { set line "" } { [string trim $line] == "" } {} {
  427.     if { [gets $fid line] == -1} { close $fid ; return }
  428.     }
  429.     if {[regexp -nocase {^[^\n\r]*[-# \(]install($|[- \)])} $line]} {
  430.     global HOME
  431.     if {![string match [file join ${HOME} Tcl *] $name]} {
  432.         if {[catch {file readlink [file join ${HOME} Tcl]} link] || ![string match [file join $link *] $name]} {
  433.         close $fid
  434.         return "Inst"
  435.         }
  436.     }
  437.     }
  438.     if {[regexp {^#![     ]*([^     \n\r]+)} $line dmy mtch] } {
  439.     if {[regexp {([^/]+)$} $mtch majorMode]} { 
  440.         # remove trailing version number
  441.         set majorMode [string trimright $majorMode "01234567890."]
  442.         if {$majorMode == "sh"} {
  443.         # need to check if we're using a common unix trick
  444.         if {[gets $fid ll] != -1} {
  445.             while {[string index [string trimleft $ll] 0] == "#"} {
  446.             if {[gets $fid ll] == -1} { close $fid ; return }
  447.             } 
  448.         } else {
  449.             if {[regexp {[\n\r][ \t]*[^#][^\r\n]*[\r\n]} $line ll]} {
  450.             set ll [string trimleft $ll]
  451.             } else {
  452.             set ll ""
  453.             }
  454.         }
  455.         if {[regexp {^exec +([^ ]+) } $ll dummy ll]} {
  456.             regexp {([^/]+)$} [string trimright $ll "01234567890."] majorMode
  457.         }
  458.         }        
  459.     } else {
  460.         close $fid
  461.         return 
  462.     }
  463.     } elseif {[regexp {\-\*\- *(Mode:)? *([^     :;]+).*\-\*\-} $line "" "" majorMode]} {
  464.     # do nothing
  465.     } else {
  466.     close $fid
  467.     return
  468.     }
  469.     close $fid
  470.     
  471.     global unixMode
  472.     set majorMode [string tolower $majorMode]
  473.     if {[info exists unixMode($majorMode)]} {
  474.     return $unixMode($majorMode)
  475.     } else {
  476.     global mode::features
  477.     set m [array names mode::features]
  478.     if {[set i [lsearch [string tolower $m] $majorMode]] != -1} {
  479.         return [lindex $m $i]
  480.     }
  481.     }
  482.     return 
  483. }
  484. } else {
  485.     proc file::getModeForFile {name} {
  486.     # if it doesn't exist as a file it's probably a funny window, so return
  487.     if {![file exists "$name"]} { 
  488.         if {[string first "* Trace" $name] == "0" } {
  489.         zoom
  490.         toggleScrollbar
  491.         return Tcl
  492.         }
  493.         return
  494.     }
  495.     global modeCreator
  496.     if {[info exists modeCreator([set sig [getFileSig $name]])]} {
  497.         return $modeCreator($sig)
  498.     }
  499.     if {[catch [list ::open "$name" r] fid]} { return }
  500.     # find first non-empty line. Return if we fail
  501.     for { set line "" } { [string trim $line] == "" } {} {
  502.         if { [gets $fid line] == -1} { ::close $fid ; return }
  503.     }
  504.     if {[regexp -nocase {^[^\n\r]*[-# \(]install($|[- \)])} $line]} {
  505.         global HOME
  506.         if {![string match [file join ${HOME} Tcl *] $name]} {
  507.         if {[catch {file readlink [file join ${HOME} Tcl]} link] || ![string match [file join $link *] $name]} {
  508.             ::close $fid
  509.             return "Inst"
  510.         }
  511.         }
  512.     }
  513.     if {[regexp {^#![    ]*([^    \n\r]+)} $line dmy mtch] } {
  514.         if {[regexp {([^/]+)$} $mtch majorMode]} { 
  515.         # remove trailing version number
  516.         set majorMode [string trimright $majorMode "01234567890."]
  517.         if {$majorMode == "sh"} {
  518.             # need to check if we're using a common unix trick
  519.             if {[gets $fid ll] != -1} {
  520.             while {[string index [string trimleft $ll] 0] == "#"} {
  521.                 if {[gets $fid ll] == -1} { ::close $fid ; return }
  522.             } 
  523.             } else {
  524.             if {[regexp {[\n\r][ \t]*[^#][^\r\n]*[\r\n]} $line ll]} {
  525.                 set ll [string trimleft $ll]
  526.             } else {
  527.                 set ll ""
  528.             }
  529.             }
  530.             if {[regexp {^exec +([^ ]+) } $ll dummy ll]} {
  531.             regexp {([^/]+)$} [string trimright $ll "01234567890."] majorMode
  532.             }
  533.         }        
  534.         } else {
  535.         ::close $fid
  536.         return 
  537.         }
  538.     } elseif {[regexp {\-\*\- *(Mode:)? *([^    :;]+).*\-\*\-} $line "" "" majorMode]} {
  539.         # do nothing
  540.     } else {
  541.         ::close $fid
  542.         return
  543.     }
  544.     ::close $fid
  545.     
  546.     global unixMode
  547.     set majorMode [string tolower $majorMode]
  548.     if {[info exists unixMode($majorMode)]} {
  549.         return $unixMode($majorMode)
  550.     } else {
  551.         global mode::features
  552.         set m [array names mode::features]
  553.         if {[set i [lsearch [string tolower $m] $majorMode]] != -1} {
  554.         return [lindex $m $i]
  555.         }
  556.     }
  557.     return 
  558.     }
  559. }
  560.     
  561. # These are mappings required by the above proc.  If you need to extend this 
  562. # list to include a mode you are writting, place a statement like the following 
  563. # in your alpha::mode body
  564. set unixMode(matlab) {MATL}
  565.  
  566. ## 
  567.  # -------------------------------------------------------------------------
  568.  # 
  569.  # "file::whichModeForWin" --
  570.  # 
  571.  #  Copes with trailing '<2>', .orig, copy, '~',...
  572.  # -------------------------------------------------------------------------
  573.  ##
  574. proc file::whichModeForWin {name} {
  575.     regexp {(.*) <[0-9]+>$} $name dmy name
  576.     if {[set m [file::getModeForFile $name]] != ""} { return $m }
  577.     global ModeSuffixes
  578.     set nm [file tail $name]    
  579.     regsub {( copy|~[0-9]*|.orig)+$} $nm "" nm
  580.     case $nm in $ModeSuffixes
  581.     return $winMode
  582. }
  583.  
  584. # Below:
  585. #        Expanded version of old 'DblClickAux.tcl'
  586. # 
  587. # Authors: Tom Pollard <pollard@chem.columbia.edu>
  588. #      Tom Scavo   <trscavo@syr.edu>
  589. #      Vince Darley <darley@fas.harvard.edu>
  590. # 
  591. #  modified by  rev reason
  592. #  -------- --- --- -----------
  593. #  9/97     VMD 1.0 reorganised for new alpha distribution.
  594. # ###################################################################
  595. ##
  596.  
  597. #############################################################################
  598. # Take any valid Macintosh filespec as input, and return the
  599. # corresponding absolute filespec.  Filenames without an explicit
  600. # folder are resolved relative to the folder of the current document.
  601. #
  602. proc file::absolutePath {filename} {
  603.     set    name [file tail    $filename]
  604.     set    subdir [file dirname $filename]
  605.     if { [string length $subdir] > 0 && [string index $subdir 0] != ":" } {
  606.     set dir ""
  607.     } else {
  608.     set dir [file dirname [lindex [winNames    -f] 0]]
  609.     }
  610.     return [file join $dir$subdir $name]
  611. }
  612.  
  613. #############################################################################
  614. # Open the file specified by the full pathname "$filename"
  615. # If it's already open, just switch to it without any fuss.
  616. #
  617. proc file::openQuietly {filename} {
  618.     edit -c -w $filename
  619. }
  620.  
  621. if {[info tclversion] < 8.0} {
  622. #############################################################################
  623. # Searches $filename for the given pattern $searchString.  If the 
  624. # search is successful, returns the matched string; otherwise returns
  625. # the empty string.  If the flag 'indices' is true and the search is
  626. # successful, returns a list of two pos giving the indices of the
  627. # found string; otherwise returns the list '-1 -1'.
  628. #
  629. proc file::searchFor {filename searchString {indices 0}} {
  630.     # Get the text of the file to be searched:
  631.     if {[lsearch [winNames -f] $filename] >= 0} {
  632.     set fileText [getText -w $filename [minPos] [maxPos -w $filename]]
  633.     } elseif {[file exists $filename]} {
  634.     set fd [open $filename]
  635.     set fileText [read $fd]
  636.     close $fd
  637.     } else {
  638.     if { $indices } {
  639.         return [list -1 -1]
  640.     } else {
  641.         return ""
  642.     }
  643.     }
  644.     # Search the text for the search string:
  645.     if { $indices } {
  646.     if {[regexp -indices $searchString $fileText mtch]} {
  647.         # Fixes an apparent bug in 'regexp':
  648.         return [list [lindex $mtch 0] [expr {[lindex $mtch 1] + 1}]]
  649.     } else {        
  650.         return [list -1 -1]
  651.     }
  652.     } else {
  653.     if {[regexp $searchString $fileText mtch]} {
  654.         return $mtch
  655.     } else {        
  656.         return ""
  657.     }
  658.     }
  659. }
  660.  
  661. #############################################################################
  662. #  Read and return the complete contents of the specified file.
  663. #
  664. proc file::readAll {fileName} {
  665.     if {[file exists $fileName] && [file readable $fileName]} {
  666.     set fileid [open $fileName "r"]
  667.     set contents [read $fileid]
  668.     close $fileid
  669.     return $contents
  670.     } else {
  671.     error "No readable file found"
  672.     }
  673. }
  674.  
  675.  
  676. #############################################################################
  677. #  Save $text in $filename.  If $text is null, create an empty file.
  678. #  Overwrite if {$overwrite} is true or the file does not exist; 
  679. #  otherwise, prompt the user.
  680. #
  681. proc file::writeAll {filename {text {}} {overwrite 0}} {
  682.     if { $overwrite || ![file exists $filename] } {
  683.     message "Saving $filename…"
  684.     set fd [open $filename "w"]
  685.     puts $fd $text
  686.     close $fd
  687.     } else {
  688.     if {[dialog::yesno "File $filename exists!  Overwrite?"]} {
  689.         file::writeAll $filename $text 1
  690.     } else {
  691.         message "No file written"
  692.     }
  693.     }
  694. }
  695. } else {
  696.     #############################################################################
  697.     # Searches $filename for the given pattern $searchString.  If the 
  698.     # search is successful, returns the matched string; otherwise returns
  699.     # the empty string.  If the flag 'indices' is true and the search is
  700.     # successful, returns a list of two pos giving the indices of the
  701.     # found string; otherwise returns the list '-1 -1'.
  702.     #
  703.     proc file::searchFor {filename searchString {indices 0}} {
  704.     # Get the text of the file to be searched:
  705.     if {[lsearch [winNames -f] $filename] >= 0} {
  706.         set fileText [getText -w $filename [minPos] [maxPos -w $filename]]
  707.     } elseif {[file exists $filename]} {
  708.         set fd [::open $filename]
  709.         set fileText [::read $fd]
  710.         ::close $fd
  711.     } else {
  712.         if { $indices } {
  713.         return [list -1 -1]
  714.         } else {
  715.         return ""
  716.         }
  717.     }
  718.     # Search the text for the search string:
  719.     if { $indices } {
  720.         if {[regexp -indices $searchString $fileText mtch]} {
  721.         # Fixes an apparent bug in 'regexp':
  722.         return [list [pos::math [minPos] + [lindex $mtch 0]] \
  723.           [pos::math [minPos] + [expr {[lindex $mtch 1] + 1}]]]
  724.         } else {        
  725.         return [list -1 -1]
  726.         }
  727.     } else {
  728.         if {[regexp $searchString $fileText mtch]} {
  729.         return $mtch
  730.         } else {        
  731.         return ""
  732.         }
  733.     }
  734.     }
  735.     
  736. #############################################################################
  737.     #  Read and return the complete contents of the specified file.
  738.     #
  739.     proc file::readAll {fileName} {
  740.     if {[file exists $fileName] && [file readable $fileName]} {
  741.         set fileid [::open $fileName "r"]
  742.         set contents [::read $fileid]
  743.         ::close $fileid
  744.         return $contents
  745.     } else {
  746.         error "No readable file found"
  747.     }
  748.     }
  749.     
  750.  
  751.     #############################################################################
  752.     #  Save $text in $filename.  If $text is null, create an empty file.
  753.     #  Overwrite if {$overwrite} is true or the file does not exist; 
  754.     #  otherwise, prompt the user.
  755.     #
  756.     proc file::writeAll {filename {text {}} {overwrite 0}} {
  757.     if { $overwrite || ![file exists $filename] } {
  758.         message "Saving $filename…"
  759.         set fd [::open $filename "w"]
  760.         puts $fd $text
  761.         ::close $fd
  762.     } else {
  763.         if {[dialog::yesno "File $filename exists!  Overwrite?"]} {
  764.         file::writeAll $filename $text 1
  765.         } else {
  766.         message "No file written"
  767.         }
  768.     }
  769.     }
  770. }
  771.     
  772.  
  773. #############################################################################
  774. #  Highlight (select) a particular line in the designated file, opening the
  775. #  file if necessary.  Returns the full name of the buffer containing the
  776. #  opened file.  If provided, a message is displayed on the status line.
  777. #
  778. proc file::gotoLine {fname line {mesg {}}} {
  779.     if {[lsearch [winNames -f] "*$fname"] >= 0} {
  780.     bringToFront $fname
  781.     } elseif {[lsearch [winNames] "*$fname"] >= 0} {
  782.     bringToFront $fname
  783.     } elseif {[file exists $fname]} {
  784.     edit $fname
  785.     catch {shrinkWindow 2}
  786.     } else {
  787.     alertnote "File \" $fname \" not found."
  788.     return
  789.     }
  790.     set pos [rowColToPos $line 0]
  791.     select [lineStart $pos] [nextLineStart $pos]
  792.     if {[string length $mesg]} { message $mesg }
  793.     return [win::Current]
  794. }
  795.  
  796. #############################################################################
  797. # Return a list of all subfolders found within $folder,
  798. # down to some maximum recursion depth.  The top-level
  799. # folder is not included in the returned list.
  800. #
  801. proc file::hierarchy {folder {depth 3}} {
  802.     set folders {}
  803.     if {$depth > 0} {
  804.     global file::separator
  805.     incr depth -1
  806.     if {[string length [file tail $folder]] > 0} {
  807.         set folder "$folder${file::separator}"
  808.     }
  809.     foreach m [glob -nocomplain  $folder\*] {
  810.         if {[file isdirectory $m]} {
  811.         set folders [concat $folders [list $m]]
  812.         set folders [concat $folders [file::hierarchy ${m}${file::separator} $depth]]
  813.         }
  814.     }
  815.     }
  816.     return $folders
  817. }
  818.  
  819. proc file::touch {f {depth 3}} {
  820.     if {[file isfile $f]} {
  821.     setFileInfo $f modified [now]
  822.     return
  823.     }
  824.     if {$depth == 0} {return}
  825.     foreach ff [glob [file join $f *]] {
  826.     file::touch $ff [expr {$depth -1}]
  827.     }
  828. }
  829.  
  830. proc file::revertThese {args} {
  831.     foreach f $args {
  832.     foreach w [winNames -f] {
  833.         set ww $w
  834.         regsub { <[0-9]+>$} $w {} w
  835.         if {$f == $w} {
  836.         bringToFront $ww
  837.         revert
  838.         }
  839.     }
  840.     }
  841. }
  842.  
  843. ## 
  844.  # -------------------------------------------------------------------------
  845.  # 
  846.  # "file::completeFromDir" --
  847.  # 
  848.  #  Here's a good example:
  849.  # 
  850.  #    set filename [prompt::statusLineComplete "Open which header" \
  851.  #       [list file::completeFromDir $universalHeadersFolder] \
  852.  #        -nocache -tryuppercase]
  853.  #  
  854.  #  Returns the list of files in '$dir' which start with '$f'.
  855.  # -------------------------------------------------------------------------
  856.  ##
  857. proc file::completeFromDir {dir f} {
  858.     set old [pwd]
  859.     cd $dir
  860.     set res [glob -nocomplain ${f}*]
  861.     cd $old
  862.     return $res
  863. }
  864.  
  865.  
  866.  
  867.