#!perl -w
#
# Documentation at the __END__
#
package File::DosGlob;
our $VERSION = '1.12';
use strict;
use warnings;
require XSLoader;
XSLoader::load();
sub doglob {
my $cond = shift;
my @retval = ();
my $fix_drive_relative_paths;
OUTER:
for my $pat (@_) {
my @matched = ();
my @globdirs = ();
my $head = '.';
my $sepchr = '/';
my $tail;
next OUTER unless defined $pat and $pat ne '';
# if arg is within quotes strip em and do no globbing
if ($pat =~ /^"(.*)"\z/s) {
$pat = $1;
if ($cond eq 'd') { push(@retval, $pat) if -d $pat }
else { push(@retval, $pat) if -e $pat }
next OUTER;
}
# wildcards with a drive prefix such as h:*.pm must be changed
# to h:./*.pm to expand correctly
if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) {
substr($pat,0,2) = $1 . "./";
$fix_drive_relative_paths = 1;
}
if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) {
($head, $sepchr, $tail) = ($1,$2,$3);
push (@retval, $pat), next OUTER if $tail eq '';
if ($head =~ /[*?]/) {
@globdirs = doglob('d', $head);
push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
next OUTER if @globdirs;
}
$head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s;
$pat = $tail;
}
#
# If file component has no wildcards, we can avoid opendir
unless ($pat =~ /[*?]/) {
$head = '' if $head eq '.';
$head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
$head .= $pat;
if ($cond eq 'd') { push(@retval,$head) if -d $head }
else { push(@retval,$head) if -e $head }
next OUTER;
}
opendir(D, $head) or next OUTER;
my @leaves = readdir D;
closedir D;
# VMS-format filespecs, especially if they contain extended characters,
# are unlikely to match patterns correctly, so Unixify them.
if ($^O eq 'VMS') {
require VMS::Filespec;
@leaves = map {$_ =~ s/\.$//; VMS::Filespec::unixify($_)} @leaves;
}
$head = '' if $head eq '.';
$head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
# escape regex metachars but not glob chars
$pat =~ s:([].+^\-\${}()[|]):\\$1:g;
# and convert DOS-style wildcards to regex
$pat =~ s/\*/.*/g;
$pat =~ s/\?/.?/g;
my $matchsub = sub { $_[0] =~ m|^$pat\z|is };
INNER:
for my $e (@leaves) {
next INNER if $e eq '.' or $e eq '..';
next INNER if $cond eq 'd' and ! -d "$head$e";
push(@matched, "$head$e"), next INNER if &$matchsub($e);
#
# [DOS compatibility special case]
# Failed, add a trailing dot and try again, but only
# if name does not have a dot in it *and* pattern
# has a dot *and* name is shorter than 9 chars.
#
if (index($e,'.') == -1 and length($e) < 9
and index($pat,'\\.') != -1) {
push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
}
}
push @retval, @matched if @matched;
}
if ($fix_drive_relative_paths) {
s|^([A-Za-z]:)\./|$1| for @retval;
}
return @retval;
}
#
# this can be used to override CORE::glob in a specific
# package by saying C