home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl501m.zip / lib / File / KGlob.pm < prev    next >
Text File  |  1995-03-28  |  11KB  |  292 lines
  1. #!/usr/bin/perl
  2. # KGlob.pm    # Based on: glob.pl 1.1 1992/12/08 17:55:21 Tye McQueen
  3. # @(#)KGlob.pm    1.2, 95/03/27 21:57:41
  4. # Expand a Unix file glob (wildcard) into a list of matching file names.
  5.  
  6. require 5.001;
  7. package File::KGlob;
  8.  
  9. require Exporter;
  10. @ISA = (Exporter);
  11. @EXPORT_OK = qw( &glob &kglob &pglob &fglob &unbrac );
  12.  
  13. require File::KGlob2RE;
  14.  
  15. # &glob( "pat" [, ...] ) - Expands Unix file glob(s) into the list of
  16. # matching Unix files.  The following contructs are supported:
  17. #   \x        matches x
  18. #   [abc]    matches the single character "a", "b", or "c"
  19. #   [a-c]    same as above
  20. #   [^a-c]    matches any single character but "a", "b", "c", "/", or "\0"
  21. #   ?        matches any single character except "/" and "\0"
  22. #   *        matches zero or more characters not including "/" and "\0"
  23. #   {X,Y,Z}    matches one of the patterns X, Y, or Z
  24.  
  25. %GlobContext= ();
  26.  
  27. sub glob {
  28.   my( $pkg, $file, $line )= caller;
  29.     if(  ! $GlobContext{$file,$line}  ) {
  30.       my( @list )= &kglob( @_ );
  31.     @list= sort( @list )   if  $Sort;
  32.     $GlobContext{$file,$line}= \@list;
  33.     }
  34.     if(  wantarray  ) {
  35.       my( @return )= @{$GlobContext{$file,$line}};
  36.     delete $GlobContext{$file,$line};
  37.     @return;
  38.     } else {
  39.       my( $return )= shift( @{$GlobContext{$file,$line}} );
  40.     delete $GlobContext{$file,$line}   if ! defined($return);
  41.     $return;
  42.     }
  43. }
  44.  
  45. # &kglob() always returns an array of matches; the complexity of the
  46. # algorythm would require a great deal of saved context to allow each
  47. # match to be returned separately like is possible with &fglob().
  48. #   The array of values is not necessarilly sorted (that is easy enough
  49. # to do if you want it so we won't waste the time to do it in case you
  50. # don't want to).
  51. #   kglob may suprise you in the following ways:
  52. #    - {a,b} expands to ("a","b") even if files "a" and/or "b" do not exist
  53. #    - [^a-z] is supported (any character except a through z, /, and \0)
  54. #    - a leading dot (.) in any component of the path must be matched
  55. #      explicitly (with a dot, not with [^a-z], nor [.x], etc.)
  56. #    - {.,x}* matches .* (as well as x*)
  57. #    - setting $File::KGlob::Safe to a true value prevents "." and ".."
  58. #      in any component of the path from matching except exactly (by the
  59. #      pattern "." or "..")
  60. #    - \x is supported (expands to just "x")
  61. #    - % is not support (just matches "%") but File::KGlob2RE supports it
  62. #    - ~user and ~/ are supported as is ~{user1,user2} etc.
  63.  
  64. sub kglob {
  65.   my( @alts, @return, $user, $home );
  66.     foreach(  @_  ) {
  67.     # If unquoted "{" in string, generate all possible combinations: #}
  68.     @alts=  m#(^|[^\\])(\\\\)*\{#  ?  &unbrac( $_ )  :  ( $_ );     #}
  69.     foreach(  @alts  ) {
  70.         if(  m#^~([^/]+)#  ) {    # Expand ~user to user's home directory:
  71.         $user= $1 || getlogin();    # ~/ means "my" home directory
  72.         $home= $1 ? ( (getpwnam($1))[7] || "~$user" )
  73.               : ( (getpwuid($<))[7] || $ENV{'HOME'} || "/" );
  74.         s##$home#;
  75.         # Replace "~user" with user's home directory (unless no such
  76.         # user, then leave as is), unless is "~/" and getlogin()
  77.         # failed, then try by current UID then $HOME then "/".
  78.         }
  79.         if(  m#(^|[^\\])(\\\\)*[\[\?\*]#  ) {   # Some kind of wildcard:
  80.         push( @return, &pglob($_) );        # Find matching files.
  81.         } else {            # Just a string, perhaps with \-quoting:
  82.         s/\\(.)/\1/g;        # Remove the \'s used for quoting.
  83.         push( @return, $_ );
  84.         }
  85.     }
  86.     }
  87.     @return;
  88. }
  89.  
  90. # &unbrac( $str ) - Expands a string containing "{a,b}" constructs.  Returns
  91. # an array of strings.  "\" may be used to quote "{", ",", or "}" to suppress
  92. # its special meaning (the "\"s are left in the returned strings).
  93. #   This is a more efficient method than &glob() to expand these contructs
  94. # where no file wildcards are involved.
  95.  
  96. sub unbrac {
  97.   local( $glob )= @_;
  98.   local( $pos, $bef, @bef, $temp, $mid, @mid, $aft, @aft, @return );
  99.     $pos= rindex($glob,"{");    # Find the last "{"                #}}
  100.     while(  0 <= $pos  ) {    # Until there are no more "{"s to find:        #}
  101.     $bef= substr( $glob, 0, $pos );        # Part before "{"        #}
  102.     $temp= substr( $glob, 1 + $pos );    # Part after "{"        #}
  103.     if(  $bef =~ m#(^|[^\\])(\\\\)*$#  ) {    # The "{" is unquoted:        #}{
  104.         $pos= index( $temp, "}" );        #{ Find the next nearest "}"
  105.         while(  0 <= $pos  ) {        #{ Until we run out of "}"s:
  106.         $mid= substr( $temp, 0, $pos );    # Part between "{" and "}"  #{
  107.         $aft= substr( $temp, 1 + $pos );    # Part after "}"
  108.         if(  $mid =~ m#(^|[^\\])(\\\\)*$#  ) {    #{ The "}" is unquoted:
  109.             $mid =~ s/((^|[^\\])(\\\\))*,/\1\0/g; # Most unquoted ","s
  110.             $mid =~ s/((^|[^\\])(\\\\))*,/\1\0/g; # Remaining ones
  111.             return &mcat( $bef, $aft, split(/\0/,$mid) );    # Done!
  112.         }    # &mcat builds all of the resulting strings.
  113.         }        # &mcat also "unbrac"s $bef and $aft.
  114.         if(  $Debug  ) {
  115.         die "Unclosed `{' in pattern string: `",        #}
  116.           $bef, "' . `{' . `", $aft, "'\n";            #}
  117.         }
  118.     }
  119.     $pos= rindex( $glob, "{", $pos - 1 );                #}
  120.     }
  121.     ( $glob );    # No unquoted "{"s to be expanded            #}
  122. }
  123.  
  124. # &File::KGlob::mcat( $bef, $aft, @mids ) - Used by &unbrac to make the code
  125. # easier to follow.  Builds all of the strings  $bef . $mids[$i] . $aft  and
  126. # then calls &unbrac on each of them.
  127.  
  128. sub mcat {
  129.   local( $bef, $aft, @mid )= @_;
  130.   local( @bef, @aft, $one, $two, $three, @return );
  131.     foreach(  @mid  ) {
  132.     push(  @return,  &unbrac( $bef . $_ . $aft )  );
  133.     }
  134.     @return;
  135. }
  136.  
  137. # &pglob( $glob ) - Expand a Unix file glob except for "{a,b}" constructs.
  138. # The name is short for "Path GLOB".
  139.  
  140. sub pglob {
  141.   local( $glob )= @_;
  142.   local( @dirs )= split( m-/+-, $glob, 9999 );    # (so trailing / isn't ignored)
  143.   local( @paths, @build, $dir, $file, $path );
  144.     for(  0 .. @dirs-2  ) {    # Tack "/" to all but last component so fglob
  145.     $dirs[$_] .= "/";    # only returns directories for middle parts
  146.     }
  147.     pop( @dirs )   if  "" eq $dirs[@dirs-1]; # In case $glob had a trailing /
  148.     if(  "/" eq $dirs[0]  ) {
  149.     $path= "/";
  150.     shift( @dirs );
  151.     } else {
  152.     $path= "";
  153.     }
  154.     @paths= grep(  $_= $path . $_,  &fglob( shift(@dirs), $path )  );
  155.     foreach $dir (  @dirs  ) {
  156.     @build= ();
  157.     foreach $path ( @paths ) {
  158.         foreach $file (  &fglob( $dir, $path )  ) {
  159.         push( @build, "$path/$file" );
  160.         }
  161.     }
  162.     return ()   unless  @build;
  163.     @paths= @build
  164.     }
  165.     @paths;
  166. }
  167.  
  168. # &fglob( $glob [, $dir] ) - Expands a file wildcard, $glob, (a glob with
  169. # no /'s, ie. no directories) into the list of matching Unix files found
  170. # in the directory $dir (or "." if $dir not specified).
  171. #   In an array context, simply returns the list of matching files (not
  172. # necessarilly sorted).  It returns the empty list if no matches or if
  173. # $dir can't be read (if $dir can't be read, $! will have the reason).
  174. #BUG: There is no way to tell between zero matches vs. an error!
  175. #   In a scalar context, returns a context string (or undef if can't
  176. # access the directory) that is used in subsequent calls to get each
  177. # matching file one at a time (again, not necessarilly in sorted order).
  178. # For example:
  179. #    $context= &fglob( "*.dat" );
  180. #    die "Can't read current directory: $!\n"   unless  defined($context);
  181. #    while(  $_= &fglob( $context )  ) {
  182. #        if(  ! &do_something( $_ )  ) {
  183. #        &fglob( $context, 1 );
  184. #        last;
  185. #        }
  186. #    }
  187. # Note that you may use `&fglob($context,1)' to close the directory if
  188. # you don't want to get *all* of the matching files ("1" can be anything
  189. # but undef).  Also, calling fglob with a context string in an array
  190. # context returns all of the *remaining* matching files.
  191. #   fglob may suprise you in the following ways:
  192. #    - / is not supported (nothing will match) except as last character
  193. #      of $glob, in which case only directory names are returned (without
  194. #      trailing /s)
  195. #    - {a,b} will only return ("a","b") if the files "a" and "b" exist
  196. #    - [^a-z] is supported (any character except a through z, /, and \0)
  197. #    - \x is supported (expands to just "x" -- called "quoting")
  198. #    - If no unquoted wildcards ("?", "[", "*", or "{") appear in $glob,
  199. #      just returns $glob minus the \-quoting and trailing / (if any)
  200. #      even if no such file exists.
  201. #    - Files whose name begin with "." are not matched unless the first
  202. #      char of $glob is "." (neither "[^a-z]*" nor "[.x]*" match ".xyz").
  203. #    - {.,x}* matches x* but not .* (a bug, but difficult to solve)
  204. #    - If $File::KGlob::Safe is set to a true value, . and .. are not
  205. #      matched by any pattern (except "." and ".." themselves).
  206.  
  207. $Safe= 0;    # Whether to exclude "." and ".." from all matches.
  208. $Sort= 1;    # Whether &glob() sorts the returned list.
  209. $NextHndl= "File::KGlob::DIR0001";
  210.  
  211. sub fglob {    # Expland a file-only glob (no /'s in the pattern)
  212.   local( $glob, $dir )= @_;
  213.   local( $re, $hndl, $nodots, $onlydirs, $match, @matches );
  214.     if(  "\0" eq substr($glob,0,1)  ) {      # A context from a previous call:
  215.     ( $hndl, $glob, $nodots, $onlydirs, $re )=
  216.       split( substr($glob,1), "\0" );
  217.     if(  defined($dir)  ) {        # &fglob($context,0) means:
  218.         closedir( $hndl );        # prematurely end the search
  219.         return wantarray ? () : undef;
  220.     }
  221.     $dir= $glog;
  222.     } elsif(  $glob !~ m/[\[\?\*\{\\]/  ) {    # Contains no special chars: #}
  223.     chop $glob   if  "/" eq substr($glob,-1,1);
  224.     return( $glob );
  225.     } else {
  226.     $hndl= $NextHndl;
  227.     $NextHndl++   unless  wantarray;
  228.     $nodots= "." ne substr($glob,0,1);    # Skip all .*'s unless explicit
  229.     chop $glob   if  $onlydirs= "/" eq substr($glob,-1,1);
  230.     # File::KGlob2RE uses "%" for "any subdir(s)" but we don't so...
  231.     $glob =~ s#((^|[^\\])(\\\\)*)\%#\1\\%#g;    # quote any unquoted "%"s.
  232.     $re= &File::KGlob2RE::kglob2re( $glob );    # Change glob to regexp.
  233.     $dir= "."   if  "" eq $dir;
  234.     if(  ! opendir( $hndl, $dir )  ) {
  235.         return wantarray ? () : undef;
  236.     }
  237.     if(  ! wantarray  ) {
  238.         return "\0$hndl\0$dir\0$nodots\0$onlydirs\0$re";
  239.     }
  240.     }
  241.     while(  $_= readdir( $hndl )  ) {
  242.     if(  m/$re/  ) {
  243.         if(  $nodots  &&  "." eq substr($_,0,1)    # 1-Don't match .*
  244.          ||  $Safe  &&  ( "." eq $_ || ".." eq $_ )    # 2-Don't match . or ..
  245.          ||  $onlydirs  &&  ! -d "$dir/$_"  ) {    # 3-Only match dirs
  246.         next;    # 1-except explicitly (.*), 3-when $glob ends with /
  247.         }        # 2-except exactly (. or ..) (when $Safe set)
  248.         return $_   unless  wantarray;
  249.         push( @matches, $_ );
  250.     }
  251.     }
  252.     closedir( $hndl );
  253.     wantarray ? @matches : undef;
  254. }
  255.  
  256. package main;
  257.  
  258. require File::Basename;  import File::Basename qw(basename);
  259.  
  260. if(  &basename( $0 )  eq  &basename( __FILE__ )  ) {
  261.     # `KGlob.pm "pattern" [...]' to list matching files, one per line.
  262. eval <<'EXAMPLE';
  263.     import File::KGlob qw(&glob);
  264.     sub quote {  local($*)= 1;  $_[1] =~ s/^$_[0]//g;  $_[1];  }
  265.     if(  0 == @ARGV  ) {
  266.     die "e( "\t*:\t", <<"    ;" ), "\n"; 
  267.     :    Usage: KGlob.pm "pattern" [...]
  268.     :    Examples:
  269.     :        KGlob.pm "*.c" | xargs grep boogers
  270.     :        KGlob.pm "*.dat *.idx" | xargs chmod ug=rw,o=r
  271.     :    Note that if only one argument is given and it contains one or
  272.     :    more spaces, then it is split into several patterns because
  273.     :    just using one set of quotes (") for the whole list is usually
  274.     :    much easier.  This splitting is *not* done if two or more
  275.     :    arguments are given.
  276.     ;
  277.     }
  278.     if(  1 == @ARGV  &&  index($ARGV[0],' ')  ) {
  279.     @ARGV= split( ' ', $ARGV[0] );
  280.     }
  281.     foreach(  @ARGV  ) {
  282.     @matches{ &glob($_) }= ();
  283.     }
  284.     foreach(  sort keys %matches  ) {
  285.     print "$_\n";
  286.     }
  287. EXAMPLE
  288. chop $@;   die $@   if $@;
  289. }
  290.  
  291. 1;
  292.