[p5sagit/p5-mst-13.2.git] / lib / File / DosGlob.pm

#!perl -w

#
# Documentation at the __END__
#

package File::DosGlob;

unless (caller) {
    $| = 1;
    while (@ARGV) {
	#
	# We have to do this one by one for compatibility reasons.
	# If an arg doesn't match anything, we are supposed to return
	# the original arg.  I know, it stinks, eh?
	#
	my $arg = shift;
	my @m = doglob(1,$arg);
	print (@m ? join("\0", sort @m) : $arg);
	print "\0" if @ARGV;
    }
}

sub doglob {
    my $cond = shift;
    my @retval = ();
    #print "doglob: ", join('|', @_), "\n";
  OUTER:
    for my $arg (@_) {
        local $_ = $arg;
	my @matched = ();
	my @globdirs = ();
	my $head = '.';
	my $sepchr = '/';
	next OUTER unless defined $_ and $_ ne '';
	# if arg is within quotes strip em and do no globbing
	if (/^"(.*)"$/) {
	    $_ = $1;
	    if ($cond eq 'd') { push(@retval, $_) if -d $_ }
	    else              { push(@retval, $_) if -e $_ }
	    next OUTER;
	}
	if (m|^(.*)([\\/])([^\\/]*)$|) {
	    my $tail;
	    ($head, $sepchr, $tail) = ($1,$2,$3);
	    #print "div: |$head|$sepchr|$tail|\n";
	    push (@retval, $_), 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]:$/;
	    $_ = $tail;
	}
	#
	# If file component has no wildcards, we can avoid opendir
	unless (/[*?]/) {
	    $head = '' if $head eq '.';
	    $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
	    $head .= $_;
	    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;
	$head = '' if $head eq '.';
	$head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;

	# escape regex metachars but not glob chars
	s:([].+^\-\${}[|]):\\$1:g;
	# and convert DOS-style wildcards to regex
	s/\*/.*/g;
	s/\?/.?/g;

	#print "regex: '$_', head: '$head'\n";
	my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '$|io }';
	warn($@), next OUTER if $@;
      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($_,'\\.') != -1) {
		push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
	    }
	}
	push @retval, @matched if @matched;
    }
    return @retval;
}

#
# this can be used to override CORE::glob in a specific
# package by saying C<use File::DosGlob 'glob';> in that
# namespace.
#

# context (keyed by second cxix arg provided by core)
my %iter;
my %entries;

sub glob {
    my $pat = shift;
    my $cxix = shift;

    # glob without args defaults to $_
    $pat = $_ unless defined $pat;

    # assume global context if not provided one
    $cxix = '_G_' unless defined $cxix;
    $iter{$cxix} = 0 unless exists $iter{$cxix};

    # if we're just beginning, do it all first
    if ($iter{$cxix} == 0) {
	$entries{$cxix} = [doglob(1,$pat)];
    }

    # chuck it all out, quick or slow
    if (wantarray) {
	delete $iter{$cxix};
	return @{delete $entries{$cxix}};
    }
    else {
	if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
	    return shift @{$entries{$cxix}};
	}
	else {
	    # return undef for EOL
	    delete $iter{$cxix};
	    delete $entries{$cxix};
	    return undef;
	}
    }
}

sub import {
    my $pkg = shift;
    my $callpkg = caller(0);
    my $sym = shift;
    *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym}
	if defined($sym) and $sym eq 'glob';
}

1;

__END__

=head1 NAME

File::DosGlob - DOS like globbing and then some

perlglob.bat - a more capable perlglob.exe replacement

=head1 SYNOPSIS

    require 5.004;
    
    # override CORE::glob in current package
    use File::DosGlob 'glob';
    
    @perlfiles = glob  "..\\pe?l/*.p?";
    print <..\\pe?l/*.p?>;
    
    # from the command line (overrides only in main::)
    > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>"
    
    > perlglob ../pe*/*p?

=head1 DESCRIPTION

A module that implements DOS-like globbing with a few enhancements.
This file is also a portable replacement for perlglob.exe.  It
is largely compatible with perlglob.exe (the M$ setargv.obj
version) in all but one respect--it understands wildcards in
directory components.

For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
that it will find something like '..\lib\File/DosGlob.pm' alright).
Note that all path components are case-insensitive, and that
backslashes and forward slashes are both accepted, and preserved.
You may have to double the backslashes if you are putting them in
literally, due to double-quotish parsing of the pattern by perl.

When invoked as a program, it will print null-separated filenames
to standard output.

While one may replace perlglob.exe with this, usage by overriding
CORE::glob via importation should be much more efficient, because
it avoids launching a separate process, and is therefore strongly
recommended.  Note that it is currently possible to override
builtins like glob() only on a per-package basis, not "globally".
Thus, every namespace that wants to override glob() must explicitly
request the override.  See L<perlsub>.

Extending it to csh patterns is left as an exercise to the reader.

=head1 EXPORTS (by request only)

glob()

=head1 BUGS

Should probably be built into the core, and needs to stop
pandering to DOS habits.  Needs a dose of optimizium too.

=head1 AUTHOR

Gurusamy Sarathy <gsar@umich.edu>

=head1 HISTORY

=over 4

=item *

Scalar context, independent iterator context fixes (GSAR 15-SEP-97)

=item *

A few dir-vs-file optimizations result in glob importation being
10 times faster than using perlglob.exe, and using perlglob.bat is
only twice as slow as perlglob.exe (GSAR 28-MAY-97)

=item *

Several cleanups prompted by lack of compatible perlglob.exe
under Borland (GSAR 27-MAY-97)

=item *

Initial version (GSAR 20-FEB-97)

=back

=head1 SEE ALSO

perl

=cut
Commit	Line	Data
08aa1457	1	#!perl -w
	2
	3	#
	4	# Documentation at the __END__
	5	#
	6
	7	package File::DosGlob;
	8
	9	unless (caller) {
	10	$\| = 1;
	11	while (@ARGV) {
	12	#
	13	# We have to do this one by one for compatibility reasons.
	14	# If an arg doesn't match anything, we are supposed to return
	15	# the original arg. I know, it stinks, eh?
	16	#
	17	my $arg = shift;
	18	my @m = doglob(1,$arg);
	19	print (@m ? join("\0", sort @m) : $arg);
	20	print "\0" if @ARGV;
	21	}
	22	}
	23
	24	sub doglob {
	25	my $cond = shift;
	26	my @retval = ();
	27	#print "doglob: ", join('\|', @_), "\n";
	28	OUTER:
	29	for my $arg (@_) {
	30	local $_ = $arg;
	31	my @matched = ();
	32	my @globdirs = ();
	33	my $head = '.';
	34	my $sepchr = '/';
	35	next OUTER unless defined $_ and $_ ne '';
	36	# if arg is within quotes strip em and do no globbing
	37	if (/^"(.*)"$/) {
	38	$_ = $1;
	39	if ($cond eq 'd') { push(@retval, $_) if -d $_ }
	40	else { push(@retval, $_) if -e $_ }
	41	next OUTER;
	42	}
	43	if (m\|^(.)([\\/])([^\\/])$\|) {
	44	my $tail;
	45	($head, $sepchr, $tail) = ($1,$2,$3);
	46	#print "div: \|$head\|$sepchr\|$tail\|\n";
	47	push (@retval, $_), next OUTER if $tail eq '';
	48	if ($head =~ /[*?]/) {
	49	@globdirs = doglob('d', $head);
	50	push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
	51	next OUTER if @globdirs;
	52	}
	53	$head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:$/;
	54	$_ = $tail;
	55	}
	56	#
	57	# If file component has no wildcards, we can avoid opendir
	58	unless (/[*?]/) {
	59	$head = '' if $head eq '.';
	60	$head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
	61	$head .= $_;
	62	if ($cond eq 'd') { push(@retval,$head) if -d $head }
	63	else { push(@retval,$head) if -e $head }
	64	next OUTER;
65	}
66	opendir(D, $head) or next OUTER;
67	my @leaves = readdir D;
68	closedir D;
69	$head = '' if $head eq '.';
70	$head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
71
72	# escape regex metachars but not glob chars
73	s:([].+^\-\${}[\|]):\\$1:g;
74	# and convert DOS-style wildcards to regex
75	s/\/./g;
76	s/\?/.?/g;
77
78	#print "regex: '$_', head: '$head'\n";
79	my $matchsub = eval 'sub { $_[0] =~ m\|^' . $_ . '$\|io }';
80	warn($@), next OUTER if $@;
81	INNER:
82	for my $e (@leaves) {
83	next INNER if $e eq '.' or $e eq '..';
84	next INNER if $cond eq 'd' and ! -d "$head$e";
85	push(@matched, "$head$e"), next INNER if &$matchsub($e);
86	#
87	# [DOS compatibility special case]
88	# Failed, add a trailing dot and try again, but only
89	# if name does not have a dot in it and pattern
90	# has a dot and name is shorter than 9 chars.
91	#
92	if (index($e,'.') == -1 and length($e) < 9
93	and index($_,'\\.') != -1) {
94	push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
95	}
96	}
97	push @retval, @matched if @matched;
98	}
99	return @retval;
100	}
101
102	#
fb73857a	103	# this can be used to override CORE::glob in a specific
	104	# package by saying C<use File::DosGlob 'glob';> in that
	105	# namespace.
08aa1457	106	#
fb73857a	107
	108	# context (keyed by second cxix arg provided by core)
	109	my %iter;
	110	my %entries;
	111
	112	sub glob {
	113	my $pat = shift;
	114	my $cxix = shift;
	115
	116	# glob without args defaults to $_
	117	$pat = $_ unless defined $pat;
	118
	119	# assume global context if not provided one
	120	$cxix = '_G_' unless defined $cxix;
	121	$iter{$cxix} = 0 unless exists $iter{$cxix};
	122
	123	# if we're just beginning, do it all first
	124	if ($iter{$cxix} == 0) {
	125	$entries{$cxix} = [doglob(1,$pat)];
	126	}
	127
	128	# chuck it all out, quick or slow
	129	if (wantarray) {
	130	delete $iter{$cxix};
	131	return @{delete $entries{$cxix}};
	132	}
	133	else {
	134	if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
	135	return shift @{$entries{$cxix}};
	136	}
	137	else {
	138	# return undef for EOL
	139	delete $iter{$cxix};
	140	delete $entries{$cxix};
	141	return undef;
	142	}
	143	}
	144	}
08aa1457	145
	146	sub import {
	147	my $pkg = shift;
	148	my $callpkg = caller(0);
	149	my $sym = shift;
fb73857a	150	*{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym}
fb73857a	151	if defined($sym) and $sym eq 'glob';
08aa1457	152	}
	153
	154	1;
	155
	156	__END__
	157
	158	=head1 NAME
	159
	160	File::DosGlob - DOS like globbing and then some
	161
	162	perlglob.bat - a more capable perlglob.exe replacement
	163
	164	=head1 SYNOPSIS
	165
	166	require 5.004;
fb73857a	167
	168	# override CORE::glob in current package
	169	use File::DosGlob 'glob';
	170
08aa1457	171	@perlfiles = glob "..\\pe?l/*.p?";
	172	print <..\\pe?l/*.p?>;
	173
fb73857a	174	# from the command line (overrides only in main::)
08aa1457	175	> perl -MFile::DosGlob=glob -e "print <../pe/p?>"
	176
	177	> perlglob ../pe/p?
	178
	179	=head1 DESCRIPTION
	180
	181	A module that implements DOS-like globbing with a few enhancements.
	182	This file is also a portable replacement for perlglob.exe. It
	183	is largely compatible with perlglob.exe (the M$ setargv.obj
	184	version) in all but one respect--it understands wildcards in
	185	directory components.
	186
	187	For example, C<<..\\lb\\file/glob.p?>> will work as expected (in
	188	that it will find something like '..\lib\File/DosGlob.pm' alright).
	189	Note that all path components are case-insensitive, and that
	190	backslashes and forward slashes are both accepted, and preserved.
	191	You may have to double the backslashes if you are putting them in
	192	literally, due to double-quotish parsing of the pattern by perl.
	193
	194	When invoked as a program, it will print null-separated filenames
	195	to standard output.
	196
	197	While one may replace perlglob.exe with this, usage by overriding
	198	CORE::glob via importation should be much more efficient, because
	199	it avoids launching a separate process, and is therefore strongly
fb73857a	200	recommended. Note that it is currently possible to override
	201	builtins like glob() only on a per-package basis, not "globally".
	202	Thus, every namespace that wants to override glob() must explicitly
	203	request the override. See L<perlsub>.
08aa1457	204
	205	Extending it to csh patterns is left as an exercise to the reader.
	206
	207	=head1 EXPORTS (by request only)
	208
	209	glob()
	210
	211	=head1 BUGS
	212
	213	Should probably be built into the core, and needs to stop
	214	pandering to DOS habits. Needs a dose of optimizium too.
	215
	216	=head1 AUTHOR
	217
	218	Gurusamy Sarathy <gsar@umich.edu>
	219
	220	=head1 HISTORY
	221
	222	=over 4
	223
	224	=item *
	225
fb73857a	226	Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
	227
	228	=item *
	229
08aa1457	230	A few dir-vs-file optimizations result in glob importation being
	231	10 times faster than using perlglob.exe, and using perlglob.bat is
	232	only twice as slow as perlglob.exe (GSAR 28-MAY-97)
	233
	234	=item *
	235
	236	Several cleanups prompted by lack of compatible perlglob.exe
	237	under Borland (GSAR 27-MAY-97)
	238
	239	=item *
	240
	241	Initial version (GSAR 20-FEB-97)
	242
	243	=back
	244
	245	=head1 SEE ALSO
	246
	247	perl
	248
	249	=cut
	250