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

#!perl -w

# use strict fails
#Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191.

#
# Documentation at the __END__
#

package File::DosGlob;

our $VERSION = '1.00';
use strict;
use warnings;

sub doglob {
    my $cond = shift;
    my @retval = ();
    #print "doglob: ", join('|', @_), "\n";
  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($_,0,2) = $1 . "./";
	}
	if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) {
	    ($head, $sepchr, $tail) = ($1,$2,$3);
	    #print "div: |$head|$sepchr|$tail|\n";
	    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;
	$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;

	#print "regex: '$pat', head: '$head'\n";
	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;
    }
    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,$cxix) = @_;
    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;
    }

    # Mike Mestnik: made to do abc{1,2,3} == abc1 abc2 abc3.
    #   abc3 will be the original {3} (and drop the {}).
    #   abc1 abc2 will be put in @appendpat.
    # This was just the esiest way, not nearly the best.
    REHASH: {
	my @appendpat = ();
	for (@pat) {
	    # There must be a "," I.E. abc{efg} is not what we want.
	    while ( /^(.*)(?<!\\)\{(.*?)(?<!\\)\,.*?(?<!\\)\}(.*)$/ ) {
		my ($start, $match, $end) = ($1, $2, $3);
		#print "Got: \n\t$start\n\t$match\n\t$end\n";
		my $tmp = "$start$match$end";
		while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) {
		    #print "Striped: $tmp\n";
		    #  these expanshions will be preformed by the original,
		    #  when we call REHASH.
		}
		push @appendpat, ("$tmp");
		s/^\Q$start\E(?<!\\)\{\Q$match\E(?<!\\)\,/$start\{/;
		if ( /^\Q$start\E(?<!\\)\{(?!.*?(?<!\\)\,.*?\Q$end\E$)(.*)(?<!\\)\}\Q$end\E$/ ) {
		    $match = $1;
		    #print "GOT: \n\t$start\n\t$match\n\t$end\n\n";
		    $_ = "$start$match$end";
		}
	    }
	    #print "Sould have "GOT" vs "Got"!\n";
		#FIXME: There should be checking for this.
		#  How or what should be done about failure is beond me.
	}
	if ( $#appendpat != -1
		) {
	    #print "LOOP\n";
	    #FIXME: Max loop, no way! :")
	    for ( @appendpat ) {
	        push @pat, $_;
	    }
	    goto REHASH;
	}
    }
    for ( @pat ) {
	s/\\{/{/g;
	s/\\}/}/g;
	s/\\,/,/g;
    }
    #print join ("\n", @pat). "\n";
 
    # 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;
	}
    }
}

{
    no strict 'refs';

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