diff options
author | Norbert Preining <preining@logic.at> | 2010-05-12 16:51:27 +0000 |
---|---|---|
committer | Norbert Preining <preining@logic.at> | 2010-05-12 16:51:27 +0000 |
commit | b645030efc22e13c2498a1522083634ab91b2de1 (patch) | |
tree | c75c7a71998200d419af56eb755dac2f5115b585 /Master/tlpkg/tlperl/lib/File/DosGlob.pm | |
parent | 44ccd4efc5352f9eb1099ba357708e7b5ff03b83 (diff) |
move tlperl to tlperl.old
git-svn-id: svn://tug.org/texlive/trunk@18209 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/File/DosGlob.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/File/DosGlob.pm | 571 |
1 files changed, 0 insertions, 571 deletions
diff --git a/Master/tlpkg/tlperl/lib/File/DosGlob.pm b/Master/tlpkg/tlperl/lib/File/DosGlob.pm deleted file mode 100644 index a1c27d5c32a..00000000000 --- a/Master/tlpkg/tlperl/lib/File/DosGlob.pm +++ /dev/null @@ -1,571 +0,0 @@ -#!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; -} - - -# -# Do DOS-like globbing on Mac OS -# -sub doglob_Mac { - my $cond = shift; - my @retval = (); - - #print "doglob_Mac: ", join('|', @_), "\n"; - OUTER: - for my $arg (@_) { - local $_ = $arg; - my @matched = (); - my @globdirs = (); - my $head = ':'; - my $not_esc_head = $head; - my $sepchr = ':'; - next OUTER unless defined $_ and $_ ne ''; - # if arg is within quotes strip em and do no globbing - if (/^"(.*)"\z/s) { - $_ = $1; - # $_ may contain escaped metachars '\*', '\?' and '\' - my $not_esc_arg = $_; - $not_esc_arg =~ s/\\([*?\\])/$1/g; - if ($cond eq 'd') { push(@retval, $not_esc_arg) if -d $not_esc_arg } - else { push(@retval, $not_esc_arg) if -e $not_esc_arg } - next OUTER; - } - - if (m|^(.*?)(:+)([^:]*)\z|s) { # note: $1 is not greedy - my $tail; - ($head, $sepchr, $tail) = ($1,$2,$3); - #print "div: |$head|$sepchr|$tail|\n"; - push (@retval, $_), next OUTER if $tail eq ''; - # - # $head may contain escaped metachars '\*' and '\?' - - my $tmp_head = $head; - # if a '*' or '?' is preceded by an odd count of '\', temporary delete - # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as - # wildcards - $tmp_head =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg; - - if ($tmp_head =~ /[*?]/) { # if there are wildcards ... - @globdirs = doglob_Mac('d', $head); - push(@retval, doglob_Mac($cond, map {"$_$sepchr$tail"} @globdirs)), - next OUTER if @globdirs; - } - - $head .= $sepchr; - $not_esc_head = $head; - # unescape $head for file operations - $not_esc_head =~ s/\\([*?\\])/$1/g; - $_ = $tail; - } - # - # If file component has no wildcards, we can avoid opendir - - my $tmp_tail = $_; - # if a '*' or '?' is preceded by an odd count of '\', temporary delete - # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as - # wildcards - $tmp_tail =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg; - - unless ($tmp_tail =~ /[*?]/) { # if there are wildcards ... - $not_esc_head = $head = '' if $head eq ':'; - my $not_esc_tail = $_; - # unescape $head and $tail for file operations - $not_esc_tail =~ s/\\([*?\\])/$1/g; - $head .= $_; - $not_esc_head .= $not_esc_tail; - if ($cond eq 'd') { push(@retval,$head) if -d $not_esc_head } - else { push(@retval,$head) if -e $not_esc_head } - next OUTER; - } - #print "opendir($not_esc_head)\n"; - opendir(D, $not_esc_head) or next OUTER; - my @leaves = readdir D; - closedir D; - - # escape regex metachars but not '\' and glob chars '*', '?' - $_ =~ s:([].+^\-\${}[|]):\\$1:g; - # and convert DOS-style wildcards to regex, - # but only if they are not escaped - $_ =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg; - - #print "regex: '$_', head: '$head', unescaped head: '$not_esc_head'\n"; - my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }'; - 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 "$not_esc_head$e"; - - if (&$matchsub($e)) { - my $leave = (($not_esc_head eq ':') && (-f "$not_esc_head$e")) ? - "$e" : "$not_esc_head$e"; - # - # On Mac OS, the two glob metachars '*' and '?' and the escape - # char '\' are valid characters for file and directory names. - # We have to escape and treat them specially. - $leave =~ s|([*?\\])|\\$1|g; - push(@matched, $leave); - next INNER; - } - } - push @retval, @matched if @matched; - } - return @retval; -} - -# -# _expand_volume() will only be used on Mac OS (Classic): -# Takes an array of original patterns as argument and returns an array of -# possibly modified patterns. Each original pattern is processed like -# that: -# + If there's a volume name in the pattern, we push a separate pattern -# for each mounted volume that matches (with '*', '?' and '\' escaped). -# + If there's no volume name in the original pattern, it is pushed -# unchanged. -# Note that the returned array of patterns may be empty. -# -sub _expand_volume { - - require MacPerl; # to be verbose - - my @pat = @_; - my @new_pat = (); - my @FSSpec_Vols = MacPerl::Volumes(); - my @mounted_volumes = (); - - foreach my $spec_vol (@FSSpec_Vols) { - # push all mounted volumes into array - push @mounted_volumes, MacPerl::MakePath($spec_vol); - } - #print "mounted volumes: |@mounted_volumes|\n"; - - while (@pat) { - my $pat = shift @pat; - if ($pat =~ /^([^:]+:)(.*)\z/) { # match a volume name? - my $vol_pat = $1; - my $tail = $2; - # - # escape regex metachars but not '\' and glob chars '*', '?' - $vol_pat =~ s:([].+^\-\${}[|]):\\$1:g; - # and convert DOS-style wildcards to regex, - # but only if they are not escaped - $vol_pat =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg; - #print "volume regex: '$vol_pat' \n"; - - foreach my $volume (@mounted_volumes) { - if ($volume =~ m|^$vol_pat\z|ios) { - # - # On Mac OS, the two glob metachars '*' and '?' and the - # escape char '\' are valid characters for volume names. - # We have to escape and treat them specially. - $volume =~ s|([*?\\])|\\$1|g; - push @new_pat, $volume . $tail; - } - } - } else { # no volume name in pattern, push original pattern - push @new_pat, $pat; - } - } - return @new_pat; -} - - -# -# _preprocess_pattern() will only be used on Mac OS (Classic): -# Resolves any updirs in the pattern. Removes a single trailing colon -# from the pattern, unless it's a volume name pattern like "*HD:" -# -sub _preprocess_pattern { - my @pat = @_; - - foreach my $p (@pat) { - my $proceed; - # resolve any updirs, e.g. "*HD:t?p::a*" -> "*HD:a*" - do { - $proceed = ($p =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/); - } while ($proceed); - # remove a single trailing colon, e.g. ":*:" -> ":*" - $p =~ s/:([^:]+):\z/:$1/; - } - return @pat; -} - - -# -# _un_escape() will only be used on Mac OS (Classic): -# Unescapes a list of arguments which may contain escaped -# metachars '*', '?' and '\'. -# -sub _un_escape { - foreach (@_) { - s/\\([*?\\])/$1/g; - } - return @_; -} - -# -# 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) { - if ($^O eq 'MacOS') { - # first, take care of updirs and trailing colons - @pat = _preprocess_pattern(@pat); - # expand volume names - @pat = _expand_volume(@pat); - $entries{$cxix} = (@pat) ? [_un_escape( doglob_Mac(1,@pat) )] : [()]; - } else { - $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 NOTES - -=over 4 - -=item * - -Mac OS (Classic) users should note a few differences. The specification -of pathnames in glob patterns adheres to the usual Mac OS conventions: -The path separator is a colon ':', not a slash '/' or backslash '\'. A -full path always begins with a volume name. A relative pathname on Mac -OS must always begin with a ':', except when specifying a file or -directory name in the current working directory, where the leading colon -is optional. If specifying a volume name only, a trailing ':' is -required. Due to these rules, a glob like E<lt>*:E<gt> will find all -mounted volumes, while a glob like E<lt>*E<gt> or E<lt>:*E<gt> will find -all files and directories in the current directory. - -Note that updirs in the glob pattern are resolved before the matching begins, -i.e. a pattern like "*HD:t?p::a*" will be matched as "*HD:a*". Note also, -that a single trailing ':' in the pattern is ignored (unless it's a volume -name pattern like "*HD:"), i.e. a glob like <:*:> will find both directories -I<and> files (and not, as one might expect, only directories). - -The metachars '*', '?' and the escape char '\' are valid characters in -volume, directory and file names on Mac OS. Hence, if you want to match -a '*', '?' or '\' literally, you have to escape these characters. Due to -perl's quoting rules, things may get a bit complicated, when you want to -match a string like '\*' literally, or when you want to match '\' literally, -but treat the immediately following character '*' as metachar. So, here's a -rule of thumb (applies to both single- and double-quoted strings): escape -each '*' or '?' or '\' with a backslash, if you want to treat them literally, -and then double each backslash and your are done. E.g. - -- Match '\*' literally - - escape both '\' and '*' : '\\\*' - double the backslashes : '\\\\\\*' - -(Internally, the glob routine sees a '\\\*', which means that both '\' and -'*' are escaped.) - - -- Match '\' literally, treat '*' as metachar - - escape '\' but not '*' : '\\*' - double the backslashes : '\\\\*' - -(Internally, the glob routine sees a '\\*', which means that '\' is escaped and -'*' is not.) - -Note that you also have to quote literal spaces in the glob pattern, as described -above. - -=back - -=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 - |