home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #30 / NN_1992_30.iso / spool / comp / lang / perl / 7369 < prev    next >
Encoding:
Text File  |  1992-12-11  |  4.1 KB  |  171 lines
  1. Newsgroups: comp.lang.perl
  2. Path: sparky!uunet!wupost!howland.reston.ans.net!sol.ctr.columbia.edu!eff!news.oc.com!convex!tchrist
  3. From: Tom Christiansen <tchrist@convex.COM>
  4. Subject: Re: Perl-side globbing (was Re: Perl Shell...)
  5. Originator: tchrist@pixel.convex.com
  6. Sender: usenet@news.eng.convex.com (news access account)
  7. Message-ID: <1992Dec11.212055.21505@news.eng.convex.com>
  8. Date: Fri, 11 Dec 1992 21:20:55 GMT
  9. Reply-To: tchrist@convex.COM (Tom Christiansen)
  10. References: <18086@autodesk.COM> <1992Dec10.073900.16503@spillman.uucp>
  11. Nntp-Posting-Host: pixel.convex.com
  12. Organization: Convex Computer Corporation, Colorado Springs, CO
  13. X-Disclaimer: This message was written by a user at CONVEX Computer
  14.               Corp. The opinions expressed are those of the user and
  15.               not necessarily those of CONVEX.
  16. Lines: 153
  17.  
  18. I've always used this...
  19.  
  20. --tom
  21.  
  22. ###############################################################
  23. # glob.pl by Tom Christiansen <tchrist@convex.com>
  24. #
  25. # globbing package for perl that doesn't blow up 
  26. # due to shell arg list expansion limits because it
  27. # uses its own readdir()s.
  28. #
  29. # entry points are:
  30. #    &SHglob for shell expr globbing (like perl's <*>) 
  31. #    &REglob for perl expr globbing
  32. #
  33. # set $glob'debug for trace and debug info
  34. #
  35. # extra features: ~user expansions and {f{u,oo}ba{r,z},gl{arch,ork}}
  36. # (latter for SHglob only -- REglob can use perl's alternation)
  37. ###############################################################
  38.  
  39.  
  40. package glob;
  41.  
  42. sub main'SHglob {
  43.     local($_) = @_;
  44.     local(@retlist) = ();
  45.     local($pre, $alt, $post);
  46.  
  47.     printf "SHglob: globbing $_\n" if $debug;
  48.  
  49.     s/([.+\\])/\\$1/g;
  50.     s/\*/.*/g;
  51.     s/\?/./g;
  52.  
  53.     while ( ($pre, $alt, $post) = /^(.*)\{([^{]*)\}(.*)$/ ) {
  54.         $alt =~ s/,/|/g;
  55.         $_ = "$pre($alt)$post";
  56.     }
  57.     s/\(\|/(\\.|/g;
  58.     s/\|\)/|\\.)/g;
  59.  
  60.     for (split(' ')) {
  61.     push(@retlist, &main'REglob($_));
  62.     } 
  63.  
  64.     sort @retlist;
  65. } 
  66.  
  67. sub main'REglob {
  68.     local($path) = @_;
  69.     local($_);
  70.     local(@retlist) = ();
  71.     local($root,$expr,$pos);
  72.     local($relative) = 0;
  73.     local(@dirs);
  74.     local($haveglobbed);
  75.  
  76.     @dirs = split(/\/+/, $path);
  77.  
  78.     if ($dirs[$[] =~ m!~(.*)!) {
  79.     $dirs[$[] = &homedir($1);
  80.     return @retlist unless $dirs[$[];
  81.     } elsif ($dirs[$[] eq '') {
  82.     $dirs[$[] = '/' unless $dirs[$[] =~ m!^\.{1,2}$!;
  83.     } else {
  84.     unshift(@dirs, '.');
  85.     $relative = 1;
  86.     } 
  87.  
  88.     print "REglob: globbing ", join('/',@dirs), "\n" if $debug;
  89.  
  90.     @retlist = &expand(@dirs);
  91.  
  92.     for (@retlist) {
  93.     s!^\./!! if $relative;
  94.     s!/{2,}!/!g;
  95.     } 
  96.  
  97.     return sort @retlist;
  98. }
  99.  
  100. sub expand {
  101.     local($dir, $thisdir, @rest) = @_;
  102.     local($nextdir);
  103.     local($_);
  104.     local(@retlist) = ();
  105.     local(*DIR);
  106.  
  107.     print "glob'expand: $dir $thisdir @rest\n" if $debug;
  108.  
  109.     unless ($haveglobbed || $thisdir =~ /([^\\]?)[?.*{[+\\]/ && $1 ne '\\') {
  110.     @retlist = ($thisdir);
  111.     } else {
  112.     unless (opendir(DIR,$dir)) {
  113.         warn "glob'expand: can't opendir $dir: $!\n" if $debug;
  114.     } else {
  115.         @retlist = grep(/^$thisdir$/,readdir(DIR));
  116.         @retlist = grep(!/^\./, @retlist) unless $thisdir =~ /\\\./;
  117.         $haveglobbed++;
  118.     } 
  119.     closedir DIR;
  120.     } 
  121.  
  122.     for (@retlist) {
  123.     $_ = $dir . '/' . $_;
  124.     }
  125.  
  126.     if ($nextdir = shift @rest) {
  127.     local(@newlist) = ();
  128.     for (@retlist) {
  129.         push(@newlist,&expand($_,$nextdir,@rest));
  130.     } 
  131.     @retlist = @newlist;
  132.     } 
  133.     for (@retlist) { s#/./#/#g; }
  134.  
  135.     return @retlist;
  136. } 
  137.  
  138. sub homedir {
  139.     local($user) = @_;
  140.     local(@pwent);
  141.     # global %homedir
  142.  
  143.     if (!$user) {
  144.     return $ENV{'HOME'}         if $ENV{'HOME'};
  145.     unless ($user = $ENV{'USER'}) {
  146.         @pwent = getpwnam($>);
  147.         $homedir{$user = $pwent[$[]} = $pwent[$#pwent-1];
  148.     } 
  149.     warn "glob'homedir: who are you, user #$>?" 
  150.         if $debug && !$user;
  151.     } 
  152.     unless (defined $homedir{$user}) {
  153.     if (@pwent = getpwnam($user)) {
  154.         $homedir{$user} = $pwent[$#pwent - 1];
  155.     } else {
  156.         warn "glob'homedir: who is user $user?\n" if $debug;
  157.         #$homedir{$user} = '/';
  158.     }
  159.     }
  160.     $homedir{$user};
  161. } 
  162.  
  163. 1;
  164.  
  165. __END__
  166. -- 
  167.     Tom Christiansen      tchrist@convex.com      convex!tchrist
  168.  
  169.  
  170. There are two ways to write error-free programs.  Only the third one works.
  171.