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

#!perl -w

#
# Documentation at the __END__
#

package File::DosGlob;

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;
    my @pat;

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

    # extract patterns
    if ($pat =~ /\s/) {
	require Text::ParseWords;
	@pat = Text::ParseWords::parse_line('\s+',0,$pat);
    }
    else {
	push @pat, $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;
    return unless @_;
    my $sym = shift;
    my $callpkg = ($sym =~ s/^GLOBAL_// ? 'CORE::GLOBAL' : caller(0));
    *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
}

1;

__END__

=head1 NAME

File::DosGlob - DOS like globbing and then some

=head1 SYNOPSIS

    require 5.004;
    
    # override CORE::glob in current package
    use File::DosGlob 'glob';
    
    # override CORE::glob in ALL packages (use with extreme caution!)
    use File::DosGlob 'GLOBAL_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?>"

=head1 DESCRIPTION

A module that implements DOS-like globbing with a few enhancements.
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.

Spaces in the argument delimit distinct patterns, so
C<glob('*.exe *.dll')> globs all filenames that end in C<.exe>
or C<.dll>.  If you want to put in literal spaces in the glob
pattern, you can escape them with either double quotes, or backslashes.
e.g. C<glob('c:/"Program Files"/*/*.dll')>, or
C<glob('c:/Program\ Files/*/*.dll')>.  The argument is tokenized using
C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details
of the quoting rules used.

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@activestate.com>

=head1 HISTORY

=over 4

=item *

Support for globally overriding glob() (GSAR 3-JUN-98)

=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

perlglob.bat

Text::ParseWords

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