File Coverage

blib/lib/FastGlob.pm

Criterion	Covered	Total	%
statement	100	107	93.4
branch	35	48	72.9
condition	5	6	83.3
subroutine	8	8	100.0
pod	0	2	0.0
total	148	171	86.5

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

require 5.008;

# ABSTRACT: A faster glob() implementation

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


use 5.008;
use strict;
use warnings;

use Exporter ();
use Carp qw(carp);

our @ISA = qw(Exporter);
our @EXPORT = qw(glob);
our @EXPORT_OK = qw(dirsep rootpat curdir parentdir hidedotfiles);

# platform specifics — auto-detect Windows defaults

my $IS_WINDOWS = ( $^O eq 'MSWin32' );

our $dirsep       = $IS_WINDOWS ? '\\' : '/';
our $rootpat      = $IS_WINDOWS ? '[A-Za-z]:' : '\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 = ();
    }

    # skip empty patterns — CORE::glob returns nothing for them
    @_ = grep { defined $_ && $_ ne '' } @_;

    for (@_) {
    # check for and do  tilde expansion
    if ( /^\~([^\Q${dirsep}\E]*)/ ) {
        my $usr = $1;
        my $usrdir;
        if ( $usr eq "" ) {
            # ~ alone: try getpwuid, fall back to $HOME / $USERPROFILE
            $usrdir = eval { (getpwuid($<))[7] };
            if ( !defined $usrdir ) {
                $usrdir = defined $ENV{HOME} ? $ENV{HOME} : $ENV{USERPROFILE};
            }
        } else {
            # ~user: try getpwnam (not available on Windows)
            $usrdir = eval { (getpwnam($usr))[7] };
        }
        if ( defined $usrdir && $usrdir ne "" ) {
                s/^\~\Q$usr\E/$usrdir/;
        }
        # Always keep the entry — if expansion fails, preserve the
        # original pattern unchanged (consistent with CORE::glob)
        push(@res, $_);
    } else {
        push(@res, $_);
        }
    }
    @_ = @res;
    @res = ();

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

    # Split into directory components FIRST, before regex transformation.
    # This prevents regex escape sequences (e.g. \.) from being confused
    # with the directory separator on Windows where $dirsep is \.
    # On Windows, accept both / and \ as path separators in patterns.
    my @comps;
    if ( $IS_WINDOWS ) {
        @comps = split(m{[/\\]});
    } else {
        @comps = split(/\Q$dirsep\E/);
    }

    # Check for root pattern before transforming components
    my $is_rooted = ($comps[0] =~ /($rootpat)/);
    my $root_prefix = $is_rooted ? $1 : undef;

    # Transform each component into a regex
    for my $comp (@comps) {
        if ( $comp =~ /(?
        # Wildcard component: convert glob pattern to regex

        # escape regex metacharacters that are not glob syntax
        $comp =~ s/([+.|(){}\$])/\\$1/g;

        # convert POSIX [!...] negation to regex [^...]
        # Only convert when there are chars between ! and ] (avoid [!] -> [^] which is invalid)
        $comp =~ s/\[!(?=[^\]]+\])/[^/g;

        # handle * and ?
        $comp =~ s/(?
        $comp =~ s/(?

        } else {
        # Literal component: escape regex metacharacters
        $comp = quotemeta($comp);
        }
    }

    # debugging
    print "regexp components: @comps\n" if ($verbose);

    if ( $is_rooted ) {
        shift(@comps);
        push(@res, &recurseglob( "$root_prefix$dirsep", "$root_prefix$dirsep" , @comps ));
    }
    else {
        push(@res, &recurseglob( $curdir, '' , @comps ));
    }
    }
    return sort(@res);
}

sub recurseglob {
    my($dir, $dirname, @comps) = @_;
    my(@res) = ();
    my($re, @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);
    push(@res, &recurseglob( "$dir$dirsep",
                    "$dirname$dirsep",
                    @comps ));
    } else {
        $re = '\A' . shift(@comps) . '\Z';

        # slurp in the directory
        my $dh;
        if (!opendir($dh, $dir)) {
            carp "FastGlob: opendir '$dir' failed: $!" if $verbose;
            return @res;
        }
        @names = readdir($dh);
        closedir($dh);

        # Hide dotfiles at the readdir level (like CORE::glob does)
        # unless the pattern component explicitly starts with a literal dot.
        # After glob-to-regex conversion, an explicit dot becomes \. in the
        # regex; a wildcard like * becomes .* (no backslash before the dot).
        if ( $hidedotfiles && $re !~ /\A\\A\\\./ ) {
            @names = grep { !/\A\./ } @names;
        }

        # 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.
        print "component re is qr($re)\n" if ($verbose);
        my $regex = eval { qr($re) };
        if (!defined $regex) {
            return @res;
        }
    foreach (@names) {
        print "considering |$_|\n" if ($verbose);
        if ( m{$regex} ) {
        if ( $#comps > -1 ) {
            # Only recurse into actual directories — avoids
            # futile opendir() calls on plain files.
            my $subdir = "$dir$dirsep$_";
            if ( -d $subdir ) {
                push(@res, &recurseglob( $subdir,
                            "$dirname$_$dirsep",
                            @comps ));
            }
        } else {
            push(@res, "$dirname$_" );
        }
        }
    }
    }
    return @res;
}

1;

__END__