home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl501m.zip / lib / File / KGlob2RE.pm < prev    next >
Text File  |  1995-03-28  |  8KB  |  237 lines
  1. #!/usr/bin/perl
  2. # KGlob2RE.pm    # Based on glob2re.pl 1.5 1992/12/09 23:31:01 Tye McQueen
  3. # @(#)KGlob2RE.pm    1.2, 95/03/27 22:00:11
  4. # Convert Unix file "glob" patterns to Perl regular expressions.
  5.  
  6. require 5.000;
  7. package File::KGlob2RE;
  8. require Exporter;
  9. @ISA = (Exporter);
  10. @EXPORT = qw( &kglob2re );
  11.  
  12. # The supported features are (where x is a single character and X and Y are
  13. # strings):
  14. #
  15. # .    matches .
  16. # \x    matches x
  17. # [...]    matches a single character falling into the described character class
  18. # ?    matches any single character except /
  19. # *    matches zero or more characters not including /
  20. # %    matches zero or more directories (see technical notes at bottom)
  21. # {X,Y}    matches either pattern X or Y (can list any number of patterns)
  22. #
  23. #Examples:
  24. # %s.*        matches any file whose name starts with "s." in any directory
  25. # %*.o        matches any file whose name ends with ".o" in any directory
  26. # %old/*    matches any file in a directory called "old"
  27. # %new%*    matches any file in a directory called "new" or a subdirectory
  28. #        of a directory called "new"
  29. # /%*        matches any absolute path name
  30. # {*,?*%*}  matches any relative path name (this would be very inefficient
  31. #        except that it is specifically optimized)
  32. # %X  X%*   these are also specifically optimized
  33.  
  34. sub kglob2re {
  35.   local( $glob )= @_;
  36.   local( $re )= "^";
  37.   local( $quote, $bracket, $brace, $slash );
  38.     # Optimize special cases:
  39.     return( "^[^/]?" )
  40.        if  $glob =~ m-\{\?\*/?%/?\*,\*\}-    # {?*/%/*,*}    -> ^[^/]
  41.        ||  $glob =~ m-\{\*,\?\*/?%/?\*\}-;    # {*,?*/%/*}    -> ^[^/]
  42.     for(  split( //, $glob )  ) {   # Go through glob pattern 1 char at a time:
  43.     $slash--   if  $slash;        # Was a / appended to $re last time?
  44.     if(  $quote  ) {        # Was the last character \ ?
  45.         $re .= $_;                # Don't interpret this character
  46.         $quote= 0;                # Don't quote next char too
  47.     } elsif(  '\\' eq $_  ) {    # Is this character a \ ?
  48.         $re .= $_;
  49.         $quote= 1;                # Quote next character
  50.     } elsif(  $bracket  ) {        # Are we still inside a [...] ?
  51.         if(  1 == $bracket  &&  "^" eq $_  ) {
  52.         $bracket= 2;
  53.         } else {
  54.         if(  2 == $bracket  ) {
  55.             if(  "-" eq $_  ) {
  56.             $re .= "-";        # [^-...]    -> [^-/...]
  57.             $_= "/";        # (avoid [^-z] -> [^/-z])
  58.             } else {
  59.             $re .= "/";        # [^...]    -> [^/...]
  60.             }
  61.         }
  62.         $bracket= 3;
  63.         }
  64.         $re .= $_;
  65.         $bracket= 0   if  "]" eq $_;    # Unquoted ] ends a [...]
  66.     } elsif(  "[" eq $_  ) {    # Start a [...]:
  67.         $re .= $_;
  68.         $bracket= 1;
  69.     } elsif(  "?" eq $_  ) {
  70.         $re .= ".";
  71.     } elsif(  "{" eq $_  )    # }    # Start an {X,Y}:
  72.     {            # ^ so % works in vi
  73.         $re .= "(";                # {X,Y} -> (X|Y)
  74.         $brace++;                # Remember how many started
  75.     } elsif(  "," eq $_  ) {    # Inside a {X,Y}, comma -> | ...
  76.         $re .= $brace ? "|" : "\\,";    # else comma -> \, (to be safe)
  77.     }    # {
  78.     elsif(  "}" eq $_  ) {
  79.         if(  $brace  ) {        # Completed an {X,Y}
  80.         $re .= ")";
  81.         $brace--;
  82.         } else {    # { <- so % works in vi
  83.         $re .= "\\}";    # { {
  84.         warn "Unquoted, unmatched `}' will be treated as `\\}'\n";
  85.         }
  86.     } elsif(  /\s/  ) {        # Quote white space to avoid warning
  87.         warn qq-Unquoted white space in file glob pattern: "$glob"\n-;
  88.         $re .= $_;            # else I assume it is an accident
  89.     } elsif(  "*" eq $_  ) {    # * won't match /
  90.         $re .= "[^/]*";            # * -> [^/]*
  91.     } elsif(  "/" eq $_  ) {
  92.         $re .= $_   unless  $slash;        # // -> /  and  %/ -> %
  93.         $slash= 2;                # So we know next time
  94.     } elsif(  "%" eq $_  ) {
  95.         if(  $slash  ) {        # Check this because....
  96.         $re .= "(|.*/)";    # (don't include another leading /)
  97.         } elsif(  "^" eq $re  ) {    # .../%X is different than %X
  98.         $re= "(^|/)";        # %[/]X    -> ^(|.*/)X$ -> (^|/)X$
  99.         } else {
  100.         $re .= "/(|.*/)";    # X[/]%[/]Y         -> ^X/(|.*/)Y$
  101.         }
  102.         $slash= 2;            # Don't include an extra tailing slash
  103.     } elsif(  /\w/  ) {        # Any letter, number, or _ :
  104.         $re .= $_;                # stays the same
  105.     } else {            # Any other symbol, quote it:
  106.         $re .= "\\" . $_;        # Includes ' so m'...' works.
  107.     }
  108.     }
  109.     if(  $quote  ||  $bracket  ||  $brace  ) {
  110.     warn "Unexpected end of file glob pattern: $glob\n";
  111.     return undef;
  112.     }
  113.     if(  $re !~ s-$NOQT/\(\|,\.\*/\)$-\1/-  ) {        # X/%*    -> ^X/
  114.     $re .= '$';
  115.     } elsif(  "" eq $re  ) {    # Since m// means something else:
  116.     $re= "^";                                    # %/*    -> anything
  117.     }
  118.     $re;
  119. }
  120.  
  121. package main;
  122.  
  123. require File::Basename;  import File::Basename qw(basename);
  124.  
  125. if(  &basename( $0 )  eq  &basename( __FILE__ )  ) {
  126.     # Use `find ... -print | KGlob2RE.pm "pattern" [...]' to use as pipe or test
  127. eval <<'EXAMPLE';
  128.     import File::KGlob2RE qw(&kglob2re);
  129.     sub quote {  local($*)= 1;  $_[1] =~ s/^$_[0]//g;  $_[1];  }
  130.     if(  0 == @ARGV  ) {
  131.     die "e( "\t*:\t", <<"    ;" ), "\n"; 
  132.     :    Usage: KGlob2RE.pm [-e] { "pattern" | -f file } [...]
  133.     :    Examples:
  134.     :        find . -print | KGlob2RE.pm "%*.c" | xargs grep -i "boogers"
  135.     :        \\ls | KGlob2RE.pm "*.dat *.idx" | xargs chmod ug=rw,o=r
  136.     :    Note that if only one argument is given and it contains one or
  137.     :    more spaces, then it is split into several patterns because
  138.     :    just using one set of quotes (") for the whole list is usually
  139.     :    much easier.  This splitting is *not* done if two or more
  140.     :    arguments are given.  "-f file" reads patterns, one per line,
  141.     :    from the specified file (trailing spaces, #-comments, and
  142.     :    blank lines in the file are ignored).  Patterns begining with
  143.     :    "!" exclude matching files.  "-e" causes exceptions (files
  144.     :    neither explicitly matched nor excluded) to generate a message
  145.     :    on STDERR noting this.
  146.     ;
  147.     }
  148.     if(  "-e" eq $ARGV[0]  ) {
  149.     $Warn= 1;
  150.     shift( @ARGV );
  151.     }
  152.     if(  1 == @ARGV  &&  index($ARGV[0],' ')  ) {
  153.     @ARGV= split( ' ', $ARGV[0] );
  154.     }
  155.     if(  @ARGV < 2  ) {            # Simpler example using single pattern:
  156.     $re= &kglob2re( $ARGV[0] );
  157.     while(  <STDIN>  ) {        # For each file name read from stdin:
  158.         chop;            # Take off the trailing newline
  159.         $_ .= "/"   if  -d $_  &&  ! m-/$-;    # Put / on end of dir names
  160.         if(  m/$re/o  ) {
  161.         print "$_\n";        # Only print names matching pattern
  162.         } elsif(  $Warn  ) {
  163.         warn "File $_ unmatches by any pattern.\n";
  164.         }
  165.     }
  166.     } else {
  167.     while(  @ARGV  ) {
  168.         $_= shift( @ARGV );
  169.         if(  /^-f/  ) {
  170.         if(  "" eq ( $_= substr($_,2) )  ) {
  171.             @ARGV  ||  die "Required file name missing after -f.\n";
  172.             $_= shift( @ARGV );
  173.         }
  174.         open( PAT, "<$_" )
  175.           ||  die "Can't read patterns from $_: $!\n";
  176.         push(  @pats,  grep( (chop,s=\s*#.*==,length), <PAT> )  );
  177.         close( PAT );
  178.         } else {
  179.         push( @pats, $_ );
  180.         }
  181.     }
  182.     for(  @pats  ) {
  183.         if(  /^!/  ) {
  184.         $if .= "\treturn 0 if m'" . &kglob2re(substr($_,1)) . "'o;\n";
  185.         } else {
  186.         $if .= "\treturn 1 if m'" . &kglob2re($_) . "'o;\n";
  187.         }
  188.     }
  189.     eval "sub matches {\n$if\t-1; }";
  190.     while(  <STDIN>  ) {
  191.         chop;
  192.         $_ .= "/"   if  -d $_  &&  ! m-/$-;
  193.         $re= &matches;
  194.         if(  1 == $re  ) {
  195.         print "$_\n";
  196.         } elsif(  $Warn  &&  -1 == $re  ) {
  197.         warn "File $_ unmatched by any pattern.\n";
  198.         }
  199.     }
  200.     }
  201. EXAMPLE
  202. chop $@;   die $@   if $@;
  203. }
  204.  
  205. #Technical notes:
  206. # 
  207. # Items were listed in order of precedence.  For example:  \[ matches [;  ?, *,
  208. # %, and { have no special meaning within [...];  \x within [...] matches x so
  209. # [\][] matches [ or ];  all, including {X,Y}, can be used within {X,Y}.
  210. #
  211. # % will match / or /.../.  If % is the first character of a pattern, it will
  212. # also match the empty string.  For sanity, /%/, /%, and %/ are equivalent to %
  213. # except that this will not cause % to be considered as the first character in
  214. # a pattern.  So "/%/X" and "/%X" will match "/X" but not "X" (which is good).
  215. #
  216. # Note that {} and % interfere in the following ways:  A % inside {} is never
  217. # considered as being the first character of a pattern, even when it probably
  218. # should be;  If /'s or %'s (but not both) are nested in {} they will not be
  219. # treated as adjacent and so the (possibly redundant) / will not be removed,
  220. # even when it probably should be removed.
  221. #
  222. # Hint:  If you have "/" appended to all directory file names, patterns ending
  223. # in "/" will only match directory names.  A % at the end of a pattern will
  224. # never match unless you do this.
  225. #
  226. # You can use
  227. #    m/$re/[o]
  228. # or
  229. #    eval "m'" . $re . "'"
  230. # But other choices may not work.  For example,
  231. #    eval "m/" . $re . "/"
  232. # won't because I don't bother to quote /'s.  And
  233. #    eval 'm"' . $re . '"'
  234. # risks interpretation of $ in unexpected ways (I think).
  235.  
  236. 1;
  237.