[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;

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