File Coverage

blib/lib/FastGlob.pm

Criterion	Covered	Total	%
statement	71	78	91.0
branch	18	28	64.2
condition			n/a
subroutine	6	6	100.0
pod	0	2	0.0
total	95	114	83.3

#!/usr/local/bin/perl
package FastGlob;

require 5.005;

# ABSTRACT: A faster glob() implementation

BEGIN {
    our $VERSION = '1.5'; # VERSION: generated by DZP::OurPkgVersion
}


use Exporter ();

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

use 5.004;
use strict;                # be good

# platform specifics

our $dirsep = '/';
our $rootpat= '\A\Z';
our $curdir = '.';
our $parentdir = '..';
our $hidedotfiles = 1;
our $verbose = 0;

#
# recursively wildcard expand a list of strings
#

sub glob($) {

    my @res;
    my $part;
    my $found1;
    my $out;
    my $bracepat = qr(\{([^\{\}]*)\});

    # deal with {xxx,yyy,zzz}
    @res = ();
    $found1 = 1;
    while ($found1) {
    $found1 = 0;
    for (@_) {
        if ( m{$bracepat} ) {
        foreach $part (split(',',$1)) {
            $out = $_;
            $out =~ s/$bracepat/$part/;
            push(@res, $out);
        }
        $found1 = 1;
        } else {
        push(@res, $_);
        }
    }
    @_ = @res;
        @res = ();
    }


    for (@_) {
    # check for and do  tilde expansion
    if ( /^\~([^${dirsep}]*)/ ) {
        my $usr = $1;
        my $usrdir = ( ($1 eq "") ? getpwuid($<) : getpwnam($usr) )[7];
        if ($usrdir ne "" ) {
                s/^\~\Q$usr\E/$usrdir/;
        push(@res, $_);
        }
    } else {
        push(@res, $_);
        }
    }
    @_ = @res;
    @res = ();

    for (@_) {
    # if there's no wildcards, just return it
        unless (/(^|[^\\])[*?\[\]{}]/) {
        push (@res, $_);
        next;
        }

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

    # handle * and ?
    s/(?
    s/(?

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

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

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

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

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


    if ( @comps == 0 ) {
        # bottom of recursion, just return the path
        chop($dirname);  # always has gratiutous trailing slash
        @res = ($dirname);
    } elsif ($comps[0] eq '') {
        shift(@comps);
    unshift(@res, &recurseglob( "$dir$dirsep",
                    "$dirname$dirsep",
                    @comps ));
    } else {
        $re = '\A' . shift(@comps) . '\Z';

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

        # look for matches, and if you find one, glob the rest of the
        # components. We eval the loop so the regexp gets compiled in,
        # making searches on large directories faster.
        $anymatches = 0;
        print "component re is qr($re)\n" if ($verbose);
        my $regex = qr($re);
    foreach (@names) {
        print "considering |$_|\n" if ($verbose);
        if ( m{$regex} ) {
        if ( $#comps > -1 ) {
            unshift(@res, &recurseglob( "$dir$dirsep$_",
                        "$dirname$_$dirsep",
                        @comps ));
        } else {
            unshift(@res, "$dirname$_" );
        }
        $anymatches = 1;
        }
    }
    }
    return @res;
}

1;

__END__