home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / c / cops_104.zip / cops_104 / perl / glob.pl < prev    next >
Perl Script  |  1992-03-10  |  3KB  |  143 lines
  1. #
  2. #  This does shell or perl globbing without resorting
  3. # to the shell -- we were having problems with the shell blowing
  4. # up with extra long pathnames and lots of file names.  set $glob'debug 
  5. # for trace information.
  6. #
  7. # tom christiansen <tchrist@convex.com>
  8.  
  9. package glob;
  10.  
  11. sub main'glob { 
  12.     local($expr) = @_;
  13.     local(@files);
  14.  
  15.     $? = 0;
  16.     open(SAVERR, ">&STDERR"); close(STDERR);  # suppress args too long
  17.     @files = <${expr}>;
  18.     if ($?) {
  19.     print SAVERR "shell glob blew up on $expr\n" if $debug;
  20.     @files = &SHglob($expr);
  21.     }
  22.     open (STDERR, ">&SAVERR");
  23.     # if (@files == 1 && $files[0] eq $expr) { @files = ''; } # sh foo
  24.     @files;
  25. }
  26.  
  27. sub main'SHglob {
  28.     local($expr) = @_;
  29.     local(@retlist) = ();
  30.     local($dir);
  31.  
  32.     print "SHglob: globbing $expr\n" if $debug;
  33.  
  34.     $expr =~ s/([.{+\\])/\\$1/g;
  35.     $expr =~ s/\*/.*/g;
  36.     $expr =~ s/\?/./g;
  37.  
  38.     for $dir (split(' ',$expr)) {
  39.     push(@retlist, &main'REglob($dir));
  40.     } 
  41.  
  42.     return sort @retlist;
  43. } 
  44.  
  45. sub main'REglob {
  46.     local($path) = @_;
  47.     local($_);
  48.     local(@retlist) = ();
  49.     local($root,$expr,$pos);
  50.     local($relative) = 0;
  51.     local(@dirs);
  52.     local($user);
  53.  
  54.     $haveglobbed = 0;
  55.  
  56.     @dirs = split(/\/+/, $path);
  57.  
  58.     if ($dirs[$[] =~ m!~(.*)!) {
  59.     $dirs[$[] = &homedir($1);
  60.     return @retlist unless $dirs[$[];
  61.     } elsif ($dirs[$[] eq '') {
  62.     $dirs[$[] = '/' unless $dirs[$[] =~ m!^\.{1,2}$!;
  63.     } else {
  64.     unshift(@dirs, '.');
  65.     $relative = 1;
  66.     } 
  67.  
  68.     printf "REglob: globbing %s\n", join('/',@dirs) if $debug;
  69.  
  70.     @retlist = &expand(@dirs);
  71.  
  72.     for (@retlist) {
  73.     if ($relative) {
  74.         s!^\./!!o;
  75.     }
  76.     s!/{2,}!/!g;
  77.     } 
  78.  
  79.     return sort @retlist;
  80. }
  81.  
  82. sub expand {
  83.     local($dir, $thisdir, @rest) = @_;
  84.     local($nextdir);
  85.     local($_);
  86.     local(@retlist) = ();
  87.     local(*DIR);
  88.  
  89.     unless ($haveglobbed || $thisdir =~ /([^\\]?)[?.*{[+\\]/ && $1 ne '\\') {
  90.     @retlist = ($thisdir);
  91.     } else {
  92.     unless (opendir(DIR,$dir)) {
  93.         warn "glob: can't opendir $dir: $!\n" if $debug;
  94.     } else {
  95.         @retlist = grep(/^$thisdir$/,readdir(DIR));
  96.         @retlist = grep(!/^\./, @retlist) unless $thisdir =~ /^\\\./;
  97.         $haveglobbed++;
  98.     } 
  99.     closedir DIR;
  100.     } 
  101.  
  102.     for (@retlist) {
  103.     $_ = $dir . '/' . $_;
  104.     }
  105.  
  106.     if ($nextdir = shift @rest) {
  107.     local(@newlist) = ();
  108.     for (@retlist) {
  109.         push(@newlist,&expand($_,$nextdir,@rest));
  110.     } 
  111.     @retlist = @newlist;
  112.     } 
  113.  
  114.     return @retlist;
  115. } 
  116.  
  117. sub homedir {
  118.     local($user) = @_;
  119.     local(@pwent);
  120.     # global %homedir
  121.  
  122.     if (!$user) {
  123.     return $ENV{'HOME'}         if $ENV{'HOME'};
  124.     ($user = $ENV{'USER'})      || 
  125.         ($user = getlogin)         || 
  126.         (($user) = getpwnam($>));
  127.     warn "glob'homedir: who are you, user #$>?\n" unless $user;
  128.     return '/';
  129.     } 
  130.     unless (defined $homedir{$user}) {
  131.     if (@pwent = getpwnam($user)) {
  132.         $homedir{$user} = $pwent[$#pwent - 1];
  133.     } else {
  134.         warn "glob'homedir: who are you, user #$>?\n" unless $user;
  135.         $homedir{$user} = '/';
  136.     }
  137.     }
  138.     return $homedir{$user};
  139. } 
  140.  
  141.  
  142. 1;
  143.