view release on metacpan or  search on metacpan

html/commands/glob/glob.bradapp  view on Meta::CPAN

the same terms as Perl itself.

=head1 AUTHOR

Marc Mengel E<lt>F<mengel@fnal.gov>E<gt>

=head1 REVISIONS

=over 4

=item Brad Appleton E<lt>F<bradapp@enteract.com>E<gt> -- v1.2 March 1999

Modified to use qr// (and some other minor speedups), to explode
subexpressions in curly braces (a la csh -- rather than using just
plain alternation), and made callable as a standalone script.

=back

=cut

use Exporter ();
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

$VERSION = 1.2_05;
@ISA = qw(Exporter);
@EXPORT = qw(&glob);
@EXPORT_OK = qw(dirsep rootpat curdir parentidr hidedotfiles);

# platform specifics

use vars qw($dirsep $rootpat $curdir $parentdir $hidedotfiles $nested);
use vars qw($verbose $matched @errors);

$dirsep = '/';
$rootpat= '\A\Z';
$curdir = '.';
$parentdir = '..';
$hidedotfiles = 1;
$nested = 1;
$verbose = $ENV{'DEBUG_FASTGLOB'} || 0;
$matched = 0;
@errors = ();

#
# recursively wildcard expand a list of strings
#

sub match_glob($) {
    local $_ = shift;
    my $glob_expr = $_;

    $matched = 0;
    @errors  = ();

    # check for and do  tilde expansion
    if ( /^\~([^${dirsep}]*)/ ) {
        my $usr = $1;
        my $usrdir = (length $usr)
                       ? (getpwnam($usr))[7]
                       : (defined $ENV{HOME} ? $ENV{HOME}
                                             : (getpwuid($<))[7]);
        $usrdir && s/^\~\Q$usr\E/$usrdir/ && $usr
            or push @errors, "Unknown user: $usr";
    }

    # If there's no wildcards, just return it
    return $_  unless /(?:^|[^\\])[*?\[\]{}]/;

    # Make the glob into a regexp
    # escape + , and | 
    s/([+.|])/\\$1/g;

    # handle * and ?
    s/(\A|[^\\])(\*)|\?/$1\.$2/g;

    # deal with {xxx,yyy,zzz} -> (?:xxx|yyy|zzz)
    do {
        s/\{([^{}]+)\}/'(?:' . join('|', split(',',$1)) . ')'/ge;
    } while ( $nested and /\{([^{}]+)\}/ );

    # deal with dot files
    if ( $hidedotfiles ) {
        s/(\A|$dirsep)\.\*/$1(?:[^.].*)?/go;
        s/(\A|$dirsep)\./$1\[\^.\]?/go;
    }

    # debugging
    print "regexp is $_\n" if ($verbose);

    # now split it into directory components
    my @comps = split($dirsep);
    my @res = ();

    if ( $comps[0] =~ /($rootpat)/ ) {
        shift(@comps);
        @res = &recurseglob( "$1$dirsep", "$1$dirsep" , @comps );
    }
    else {
        @res = &recurseglob( $curdir, '' , @comps );
    }

    $matched = @res;
    return sort(@res);
}

sub recurseglob($ $ @) {
    my($dir, $dirname, @comps) = @_;
    my(@res) = ();
    my($re, $anyfound, @names);

    if ( @comps == 0 ) {
        # bottom of recursion, just return the path 
        chop($dirname);  # always has gratuitous trailing slash
        @res = ($dirname);
    } else {
        $re = '\A' . shift(@comps) . '\Z';

        # slurp in the directory
        opendir(HANDLE, $dir)  or  return @res;
        @names = readdir(HANDLE);
        closedir(HANDLE);