home *** CD-ROM | disk | FTP | other *** search
/ H4CK3R 5 / hacker05 / 05_HACK_05.ISO / programacao / freewrap / TCLLIBsampleApp.exe / sample / tcllib / tcllib1.0 / fileutil / fileutil.tcl next >
Encoding:
Text File  |  2001-08-17  |  5.9 KB  |  204 lines
  1. # fileutil.tcl --
  2. #
  3. #    Tcl implementations of standard UNIX utilities.
  4. #
  5. # Copyright (c) 1998-2000 by Ajuba Solutions.
  6. #
  7. # See the file "license.terms" for information on usage and redistribution
  8. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  9. # 
  10. # RCS: @(#) $Id: fileutil.tcl,v 1.7 2001/08/02 16:38:06 andreas_kupries Exp $
  11.  
  12. package require Tcl 8
  13. package provide fileutil 1.1
  14.  
  15. namespace eval ::fileutil {
  16.     namespace export *
  17. }
  18.  
  19. # ::fileutil::grep --
  20. #
  21. #    Implementation of grep.  Adapted from the Tcler's Wiki.
  22. #
  23. # Arguments:
  24. #    pattern        pattern to search for.
  25. #    files        list of files to search; if NULL, uses stdin.
  26. #
  27. # Results:
  28. #    results        list of matches
  29.  
  30. proc ::fileutil::grep {pattern {files {}}} {
  31.     set result [list]
  32.     if {[llength $files] == 0} {
  33.     # read from stdin
  34.     set lnum 0
  35.     while {[gets stdin line] >= 0} {
  36.         incr lnum
  37.         if {[regexp -- $pattern $line]} {
  38.         lappend result "${lnum}:${line}"
  39.         }
  40.     }
  41.     } else {
  42.     foreach filename $files {
  43.         set file [open $filename r]
  44.         set lnum 0
  45.         while {[gets $file line] >= 0} {
  46.         incr lnum
  47.         if {[regexp -- $pattern $line]} {
  48.             lappend result "${filename}:${lnum}:${line}"
  49.         }
  50.         }
  51.         close $file
  52.     }
  53.     }
  54.     return $result
  55. }
  56.  
  57. # ::fileutil::find ==
  58. #
  59. # Two different implementations of this command, one for unix with its
  60. # softlinks, the other for the Win* platform. The trouble with
  61. # softlink is that they can generate circles in the directory and/or
  62. # file structure, leading a simple recursion into infinity. So we
  63. # record device/inode information for each file and directory we touch
  64. # to be able to skip it should we happen to visit it again.
  65.  
  66. # Note about the general implementation: The tcl interpreter sets a
  67. # tcl stack limit of 1000 levels to prevent infinite recursions from
  68. # running out of bounds. As this command is implemented recursively it
  69. # will fail for very deeply nested directory structures.
  70.  
  71. if {[string compare unix $tcl_platform(platform)]} {
  72.     # Not a unix platform => Original implementation
  73.     # Note: This may still fail for directories mounted via SAMBA,
  74.     # i.e. coming from a unix server.
  75.  
  76.     # ::fileutil::find --
  77.     #
  78.     #    Implementation of find.  Adapted from the Tcler's Wiki.
  79.     #
  80.     # Arguments:
  81.     #    basedir        directory to start searching from; default is .
  82.     #    filtercmd    command to use to evaluate interest in each file.
  83.     #            If NULL, all files are interesting.
  84.     #
  85.     # Results:
  86.     #    files        a list of interesting files.
  87.  
  88.     proc ::fileutil::find {{basedir .} {filtercmd {}}} {
  89.     set oldwd [pwd]
  90.     cd $basedir
  91.     set cwd [pwd]
  92.     set filenames [glob -nocomplain * .*]
  93.     set files {}
  94.     set filt [string length $filtercmd]
  95.     # If we don't remove . and .. from the file list, we'll get stuck in
  96.     # an infinite loop in an infinite loop in an infinite loop in an inf...
  97.     foreach special [list "." ".."] {
  98.         set index [lsearch -exact $filenames $special]
  99.         set filenames [lreplace $filenames $index $index]
  100.     }
  101.     foreach filename $filenames {
  102.         # Use uplevel to eval the command, not eval, so that variable 
  103.         # substitutions occur in the right context.
  104.         if {!$filt || [uplevel $filtercmd [list $filename]]} {
  105.         lappend files [file join $cwd $filename]
  106.         }
  107.         if {[file isdirectory $filename]} {
  108.         set files [concat $files [find $filename $filtercmd]]
  109.         }
  110.     }
  111.     cd $oldwd
  112.     return $files
  113.     }
  114. } else {
  115.     # Unix, record dev/inode to detect and break circles
  116.  
  117.     # ::fileutil::find --
  118.     #
  119.     #    Implementation of find.  Adapted from the Tcler's Wiki.
  120.     #
  121.     # Arguments:
  122.     #    basedir        directory to start searching from; default is .
  123.     #    filtercmd    command to use to evaluate interest in each file.
  124.     #            If NULL, all files are interesting.
  125.     #
  126.     # Results:
  127.     #    files        a list of interesting files.
  128.  
  129.     proc ::fileutil::find {{basedir .} {filtercmd {}} {nodeVar {}}} {
  130.     if {$nodeVar == {}} {
  131.         # Main call, setup the device/inode structure
  132.         array set inodes {}
  133.     } else {
  134.         # Recursive call, import the device/inode record from the caller.
  135.         upvar $nodeVar inodes
  136.     }
  137.  
  138.     set oldwd [pwd]
  139.     cd $basedir
  140.     set cwd [pwd]
  141.     set filenames [glob -nocomplain * .*]
  142.     set files {}
  143.     set filt [string length $filtercmd]
  144.     # If we don't remove . and .. from the file list, we'll get stuck in
  145.     # an infinite loop in an infinite loop in an infinite loop in an inf...
  146.     foreach special [list "." ".."] {
  147.         set index [lsearch -exact $filenames $special]
  148.         set filenames [lreplace $filenames $index $index]
  149.     }
  150.     foreach filename $filenames {
  151.         # Stat each file/directory get exact information about its identity
  152.         # (device, inode). Non-'stat'able files are either junk (link to
  153.         # non-existing target) or not readable, i.e. inaccessible. In both
  154.         # cases it makes sense to ignore them.
  155.  
  156.         if {[catch {file stat [file join $cwd $filename] stat}]} {
  157.         continue
  158.         }
  159.  
  160.         # No skip over previously recorded files/directories and
  161.         # record the new files/directories.
  162.  
  163.         set key "$stat(dev),$stat(ino)"
  164.         if {[info exists inodes($key)]} {
  165.         continue
  166.         }
  167.         set inodes($key) 1
  168.  
  169.         # Use uplevel to eval the command, not eval, so that variable 
  170.         # substitutions occur in the right context.
  171.         if {!$filt || [uplevel $filtercmd [list $filename]]} {
  172.         lappend files [file join $cwd $filename]
  173.         }
  174.         if {[file isdirectory $filename]} {
  175.         set files [concat $files [find $filename $filtercmd inodes]]
  176.         }
  177.     }
  178.     cd $oldwd
  179.     return $files
  180.     }
  181. }
  182.  
  183. # ::fileutil::cat --
  184. #
  185. #    Tcl implementation of the UNIX "cat" command.  Returns the contents
  186. #    of the specified file.
  187. #
  188. # Arguments:
  189. #    filename    name of the file to read.
  190. #
  191. # Results:
  192. #    data        data read from the file.
  193.  
  194. proc ::fileutil::cat {filename} {
  195.     # Don't bother catching errors, just let them propagate up
  196.     set fd [open $filename r]
  197.     # Use the [file size] command to get the size, which preallocates memory,
  198.     # rather than trying to grow it as the read progresses.
  199.     set data [read $fd [file size $filename]]
  200.     close $fd
  201.     return $data
  202. }
  203.  
  204.