diff options
Diffstat (limited to 'gnu/usr.bin/perl/ext/File-Glob')
| -rw-r--r-- | gnu/usr.bin/perl/ext/File-Glob/Glob.pm | 341 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/ext/File-Glob/Glob.xs | 430 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/ext/File-Glob/bsd_glob.c | 1 | ||||
| -rw-r--r-- | gnu/usr.bin/perl/ext/File-Glob/t/rt114984.t | 24 |
4 files changed, 555 insertions, 241 deletions
diff --git a/gnu/usr.bin/perl/ext/File-Glob/Glob.pm b/gnu/usr.bin/perl/ext/File-Glob/Glob.pm index 15d4adb6bbe..c0b5a4720d9 100644 --- a/gnu/usr.bin/perl/ext/File-Glob/Glob.pm +++ b/gnu/usr.bin/perl/ext/File-Glob/Glob.pm @@ -1,38 +1,15 @@ package File::Glob; use strict; -our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, - $AUTOLOAD, $DEFAULT_FLAGS); +our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, $DEFAULT_FLAGS); -use XSLoader (); +require XSLoader; @ISA = qw(Exporter); # NOTE: The glob() export is only here for compatibility with 5.6.0. # csh_glob() should not be used directly, unless you know what you're doing. -@EXPORT_OK = qw( - csh_glob - bsd_glob - glob - GLOB_ABEND - GLOB_ALPHASORT - GLOB_ALTDIRFUNC - GLOB_BRACE - GLOB_CSH - GLOB_ERR - GLOB_ERROR - GLOB_LIMIT - GLOB_MARK - GLOB_NOCASE - GLOB_NOCHECK - GLOB_NOMAGIC - GLOB_NOSORT - GLOB_NOSPACE - GLOB_QUOTE - GLOB_TILDE -); - %EXPORT_TAGS = ( 'glob' => [ qw( GLOB_ABEND @@ -51,140 +28,57 @@ use XSLoader (); GLOB_NOSPACE GLOB_QUOTE GLOB_TILDE - glob bsd_glob + glob ) ], ); +$EXPORT_TAGS{bsd_glob} = [@{$EXPORT_TAGS{glob}}]; +pop @{$EXPORT_TAGS{bsd_glob}}; # no "glob" + +@EXPORT_OK = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob'); -$VERSION = '1.06'; +$VERSION = '1.26'; sub import { require Exporter; - my $i = 1; - while ($i < @_) { - if ($_[$i] =~ /^:(case|nocase|globally)$/) { - splice(@_, $i, 1); - $DEFAULT_FLAGS &= ~GLOB_NOCASE() if $1 eq 'case'; - $DEFAULT_FLAGS |= GLOB_NOCASE() if $1 eq 'nocase'; - if ($1 eq 'globally') { - local $^W; - *CORE::GLOBAL::glob = \&File::Glob::csh_glob; - } - next; + local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; + Exporter::import(grep { + my $passthrough; + if ($_ eq ':case') { + $DEFAULT_FLAGS &= ~GLOB_NOCASE() + } + elsif ($_ eq ':nocase') { + $DEFAULT_FLAGS |= GLOB_NOCASE(); + } + elsif ($_ eq ':globally') { + no warnings 'redefine'; + *CORE::GLOBAL::glob = \&File::Glob::csh_glob; } - ++$i; - } - goto &Exporter::import; -} - -sub AUTOLOAD { - # This AUTOLOAD is used to 'autoload' constants from the constant() - # XS function. If a constant is not found then control is passed - # to the AUTOLOAD in AutoLoader. - - my $constname; - ($constname = $AUTOLOAD) =~ s/.*:://; - my ($error, $val) = constant($constname); - if ($error) { - require Carp; - Carp::croak($error); - } - eval "sub $AUTOLOAD { $val }"; - goto &$AUTOLOAD; -} - -XSLoader::load 'File::Glob', $VERSION; - -# Preloaded methods go here. - -sub GLOB_ERROR { - return (constant('GLOB_ERROR'))[1]; + elsif ($_ eq ':bsd_glob') { + no strict; *{caller."::glob"} = \&bsd_glob_override; + $passthrough = 1; + } + else { + $passthrough = 1; + } + $passthrough; + } @_); } -sub GLOB_CSH () { - GLOB_BRACE() - | GLOB_NOMAGIC() - | GLOB_QUOTE() - | GLOB_TILDE() - | GLOB_ALPHASORT() -} +XSLoader::load(); $DEFAULT_FLAGS = GLOB_CSH(); -if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS)$/) { +if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos)$/) { $DEFAULT_FLAGS |= GLOB_NOCASE(); } -# Autoload methods go after =cut, and are processed by the autosplit program. - -sub bsd_glob { - my ($pat,$flags) = @_; - $flags = $DEFAULT_FLAGS if @_ < 2; - return doglob($pat,$flags); -} - # File::Glob::glob() is deprecated because its prototype is different from # CORE::glob() (use bsd_glob() instead) sub glob { - splice @_, 1; # don't pass PL_glob_index as flags! + splice @_, 1; # no flags goto &bsd_glob; } -## borrowed heavily from gsar's File::DosGlob -my %iter; -my %entries; - -sub csh_glob { - my $pat = shift; - my $cxix = shift; - my @pat; - - # glob without args defaults to $_ - $pat = $_ unless defined $pat; - - # extract patterns - $pat =~ s/^\s+//; # Protect against empty elements in - $pat =~ s/\s+$//; # things like < *.c> and <*.c >. - # These alone shouldn't trigger ParseWords. - if ($pat =~ /\s/) { - # XXX this is needed for compatibility with the csh - # implementation in Perl. Need to support a flag - # to disable this behavior. - require Text::ParseWords; - @pat = Text::ParseWords::parse_line('\s+',0,$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) { - if (@pat) { - $entries{$cxix} = [ map { doglob($_, $DEFAULT_FLAGS) } @pat ]; - } - else { - $entries{$cxix} = [ doglob($pat, $DEFAULT_FLAGS) ]; - } - } - - # 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; - } - } -} - 1; __END__ @@ -194,7 +88,7 @@ File::Glob - Perl extension for BSD glob routine =head1 SYNOPSIS - use File::Glob ':glob'; + use File::Glob ':bsd_glob'; @list = bsd_glob('*.[ch]'); $homedir = bsd_glob('~gnat', GLOB_TILDE | GLOB_ERR); @@ -237,7 +131,8 @@ Since v5.6.0, Perl's CORE::glob() is implemented in terms of bsd_glob(). Note that they don't share the same prototype--CORE::glob() only accepts a single argument. Due to historical reasons, CORE::glob() will also split its argument on whitespace, treating it as multiple patterns, -whereas bsd_glob() considers them as one pattern. +whereas bsd_glob() considers them as one pattern. But see C<:bsd_glob> +under L</EXPORTS>, below. =head2 META CHARACTERS @@ -250,9 +145,55 @@ whereas bsd_glob() considers them as one pattern. The metanotation C<a{b,c,d}e> is a shorthand for C<abe ace ade>. Left to right order is preserved, with results of matches being sorted separately -at a low level to preserve this order. As a special case C<{>, C<}>, and +at a low level to preserve this order. As a special case C<{>, C<}>, and C<{}> are passed undisturbed. +=head2 EXPORTS + +See also the L</POSIX FLAGS> below, which can be exported individually. + +=head3 C<:bsd_glob> + +The C<:bsd_glob> export tag exports bsd_glob() and the constants listed +below. It also overrides glob() in the calling package with one that +behaves like bsd_glob() with regard to spaces (the space is treated as part +of a file name), but supports iteration in scalar context; i.e., it +preserves the core function's feature of returning the next item each time +it is called. + +=head3 C<:glob> + +The C<:glob> tag, now discouraged, is the old version of C<:bsd_glob>. It +exports the same constants and functions, but its glob() override does not +support iteration; it returns the last file name in scalar context. That +means this will loop forever: + + use File::Glob ':glob'; + while (my $file = <* copy.txt>) { + ... + } + +=head3 C<bsd_glob> + +This function, which is included in the two export tags listed above, +takes one or two arguments. The first is the glob pattern. The second is +a set of flags ORed together. The available flags are listed below under +L</POSIX FLAGS>. If the second argument is omitted, C<GLOB_CSH> (or +C<GLOB_CSH|GLOB_NOCASE> on VMS and DOSish systems) is used by default. + +=head3 C<:nocase> and C<:case> + +These two export tags globally modify the default flags that bsd_glob() +and, except on VMS, Perl's built-in C<glob> operator use. C<GLOB_NOCASE> +is turned on or off, respectively. + +=head3 C<csh_glob> + +The csh_glob() function can also be exported, but you should not use it +directly unless you really know what you are doing. It splits the pattern +into words and feeds each one to bsd_glob(). Perl's own glob() function +uses this internally. + =head2 POSIX FLAGS The POSIX defined flags for bsd_glob() are: @@ -393,10 +334,10 @@ Remember that you can use a backslash to escape things. On DOSISH systems, backslash is a valid directory separator character. In this case, use of backslash as a quoting character (via GLOB_QUOTE) -interferes with the use of backslash as a directory separator. The +interferes with the use of backslash as a directory separator. The best (simplest, most portable) solution is to use forward slashes for -directory separators, and backslashes for quoting. However, this does -not match "normal practice" on these systems. As a concession to user +directory separators, and backslashes for quoting. However, this does +not match "normal practice" on these systems. As a concession to user expectation, therefore, backslashes (under GLOB_QUOTE) only quote the glob metacharacters '[', ']', '{', '}', '-', '~', and backslash itself. All other backslashes are passed through unchanged. @@ -407,46 +348,6 @@ Win32 users should use the real slash. If you really want to use backslashes, consider using Sarathy's File::DosGlob, which comes with the standard Perl distribution. -=item * - -Mac OS (Classic) users should note a few differences. Since -Mac OS is not Unix, when the glob code encounters a tilde glob (e.g. -~user) and the C<GLOB_TILDE> flag is used, it simply returns that -pattern without doing any expansion. - -Glob on Mac OS is case-insensitive by default (if you don't use any -flags). If you specify any flags at all and still want glob -to be case-insensitive, you must include C<GLOB_NOCASE> in the flags. - -The path separator is ':' (aka colon), not '/' (aka slash). Mac OS users -should be careful about specifying relative pathnames. While a full path -always begins with a volume name, a relative pathname should always -begin with a ':'. If specifying a volume name only, a trailing ':' is -required. - -The specification of pathnames in glob patterns adheres to the usual Mac -OS conventions: The path separator is a colon ':', not a slash '/'. 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 E<lt>:*:E<gt> will find both -directories I<and> files (and not, as one might expect, only directories). -You can, however, use the C<GLOB_MARK> flag to distinguish (without a file -test) directory names from file names. - -If the C<GLOB_MARK> flag is set, all directory paths will have a ':' appended. -Since a directory like 'lib:' is I<not> a valid I<relative> path on Mac OS, -both a leading and a trailing colon will be added, when the directory name in -question doesn't contain any colons (e.g. 'lib' becomes ':lib:'). - =back =head1 SEE ALSO @@ -462,35 +363,47 @@ E<lt>gsar@activestate.comE<gt>, and Thomas Wegner E<lt>wegner_thomas@yahoo.comE<gt>. The C glob code has the following copyright: - Copyright (c) 1989, 1993 The Regents of the University of California. - All rights reserved. - - This code is derived from software contributed to Berkeley by - Guido van Rossum. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions - are met: - - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - 2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. - 3. Neither the name of the University nor the names of its contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - - THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND - ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE - IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE - ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE - FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL - DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS - OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) - HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT - LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY - OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF - SUCH DAMAGE. +Copyright (c) 1989, 1993 The Regents of the University of California. +All rights reserved. + +This code is derived from software contributed to Berkeley by +Guido van Rossum. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +=over 4 + +=item 1. + +Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +=item 2. + +Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +=item 3. + +Neither the name of the University nor the names of its contributors +may be used to endorse or promote products derived from this software +without specific prior written permission. + +=back + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. =cut diff --git a/gnu/usr.bin/perl/ext/File-Glob/Glob.xs b/gnu/usr.bin/perl/ext/File-Glob/Glob.xs index 3a526fbf03b..e0a36814e09 100644 --- a/gnu/usr.bin/perl/ext/File-Glob/Glob.xs +++ b/gnu/usr.bin/perl/ext/File-Glob/Glob.xs @@ -1,3 +1,5 @@ +#define PERL_NO_GET_CONTEXT + #include "EXTERN.h" #include "perl.h" #include "XSUB.h" @@ -7,7 +9,12 @@ #define MY_CXT_KEY "File::Glob::_guts" XS_VERSION typedef struct { +#ifdef USE_ITHREADS + tTHX interp; +#endif int x_GLOB_ERROR; + HV * x_GLOB_ENTRIES; + Perl_ophook_t x_GLOB_OLD_OPHOOK; } my_cxt_t; START_MY_CXT @@ -21,37 +28,24 @@ START_MY_CXT #else static int errfunc(const char *foo, int bar) { + PERL_UNUSED_ARG(foo); return !(bar == EACCES || bar == ENOENT || bar == ENOTDIR); } #endif -MODULE = File::Glob PACKAGE = File::Glob - -BOOT: +static void +doglob(pTHX_ const char *pattern, int flags) { - MY_CXT_INIT; -} - -void -doglob(pattern,...) - char *pattern -PROTOTYPE: $;$ -PREINIT: + dSP; glob_t pglob; int i; int retval; - int flags = 0; SV *tmp; -PPCODE: { dMY_CXT; - /* allow for optional flags argument */ - if (items > 1) { - flags = (int) SvIV(ST(1)); - } - /* call glob */ + memset(&pglob, 0, sizeof(glob_t)); retval = bsd_glob(pattern, flags, errfunc, &pglob); GLOB_ERROR = retval; @@ -59,14 +53,410 @@ PPCODE: EXTEND(sp, pglob.gl_pathc); for (i = 0; i < pglob.gl_pathc; i++) { /* printf("# bsd_glob: %s\n", pglob.gl_pathv[i]); */ - tmp = sv_2mortal(newSVpvn(pglob.gl_pathv[i], - strlen(pglob.gl_pathv[i]))); + tmp = newSVpvn_flags(pglob.gl_pathv[i], strlen(pglob.gl_pathv[i]), + SVs_TEMP); TAINT; SvTAINT(tmp); PUSHs(tmp); } + PUTBACK; bsd_globfree(&pglob); } +} + +static void +iterate(pTHX_ bool(*globber)(pTHX_ AV *entries, const char *pat, STRLEN len, bool is_utf8)) +{ + dSP; + dMY_CXT; + + const char * const cxixpv = (char *)&PL_op; + STRLEN const cxixlen = sizeof(OP *); + AV *entries; + U32 const gimme = GIMME_V; + SV *patsv = POPs; + bool on_stack = FALSE; + + if (!MY_CXT.x_GLOB_ENTRIES) MY_CXT.x_GLOB_ENTRIES = newHV(); + entries = (AV *)*(hv_fetch(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, 1)); + + /* if we're just beginning, do it all first */ + if (SvTYPE(entries) != SVt_PVAV) { + const char *pat; + STRLEN len; + bool is_utf8; + + /* glob without args defaults to $_ */ + SvGETMAGIC(patsv); + if ( + !SvOK(patsv) + && (patsv = DEFSV, SvGETMAGIC(patsv), !SvOK(patsv)) + ) { + pat = ""; + len = 0; + is_utf8 = 0; + } + else { + pat = SvPV_nomg(patsv,len); + is_utf8 = !!SvUTF8(patsv); + /* the lower-level code expects a null-terminated string */ + if (!SvPOK(patsv) || pat != SvPVX(patsv) || pat[len] != '\0') { + SV *newpatsv = newSVpvn_flags(pat, len, SVs_TEMP); + pat = SvPV_nomg(newpatsv,len); + } + } + + if (!IS_SAFE_SYSCALL(pat, len, "pattern", "glob")) { + if (gimme != G_ARRAY) + PUSHs(&PL_sv_undef); + PUTBACK; + return; + } + + PUTBACK; + on_stack = globber(aTHX_ entries, pat, len, is_utf8); + SPAGAIN; + } + + /* chuck it all out, quick or slow */ + if (gimme == G_ARRAY) { + if (!on_stack) { + EXTEND(SP, AvFILLp(entries)+1); + Copy(AvARRAY(entries), SP+1, AvFILLp(entries)+1, SV *); + SP += AvFILLp(entries)+1; + } + /* No G_DISCARD here! It will free the stack items. */ + (void)hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, 0); + } + else { + if (AvFILLp(entries) + 1) { + mPUSHs(av_shift(entries)); + } + else { + /* return undef for EOL */ + (void)hv_delete(MY_CXT.x_GLOB_ENTRIES, cxixpv, cxixlen, G_DISCARD); + PUSHs(&PL_sv_undef); + } + } + PUTBACK; +} + +/* returns true if the items are on the stack already, but only in + list context */ +static bool +csh_glob(pTHX_ AV *entries, const char *pat, STRLEN len, bool is_utf8) +{ + dSP; + AV *patav = NULL; + const char *patend; + const char *s = NULL; + const char *piece = NULL; + SV *word = NULL; + SV *flags_sv = get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD); + int const flags = (int)SvIV(flags_sv); + U32 const gimme = GIMME_V; + + patend = pat + len; + + assert(SvTYPE(entries) != SVt_PVAV); + sv_upgrade((SV *)entries, SVt_PVAV); + + /* extract patterns */ + s = pat-1; + while (++s < patend) { + switch (*s) { + case '\'': + case '"' : + { + bool found = FALSE; + const char quote = *s; + if (!word) { + word = newSVpvs(""); + if (is_utf8) SvUTF8_on(word); + } + if (piece) sv_catpvn(word, piece, s-piece); + piece = s+1; + while (++s < patend) + if (*s == '\\') { + s++; + /* If the backslash is here to escape a quote, + obliterate it. */ + if (s < patend && *s == quote) + sv_catpvn(word, piece, s-piece-1), piece = s; + } + else if (*s == quote) { + sv_catpvn(word, piece, s-piece); + piece = NULL; + found = TRUE; + break; + } + if (!found) { /* unmatched quote */ + /* Give up on tokenisation and treat the whole string + as a single token, but with whitespace stripped. */ + piece = pat; + while (isSPACE(*pat)) pat++; + while (isSPACE(*(patend-1))) patend--; + /* bsd_glob expects a trailing null, but we cannot mod- + ify the original */ + if (patend < pat + len) { + if (word) sv_setpvn(word, pat, patend-pat); + else + word = newSVpvn_flags( + pat, patend-pat, SVf_UTF8*is_utf8 + ); + piece = NULL; + } + else { + if (word) SvREFCNT_dec(word), word=NULL; + piece = pat; + s = patend; + } + goto end_of_parsing; + } + break; + } + case '\\': + if (!piece) piece = s; + s++; + /* If the backslash is here to escape a quote, + obliterate it. */ + if (s < patend && (*s == '"' || *s == '\'')) { + if (!word) { + word = newSVpvn(piece,s-piece-1); + if (is_utf8) SvUTF8_on(word); + } + else sv_catpvn(word, piece, s-piece-1); + piece = s; + } + break; + default: + if (isSPACE(*s)) { + if (piece) { + if (!word) { + word = newSVpvn(piece,s-piece); + if (is_utf8) SvUTF8_on(word); + } + else sv_catpvn(word, piece, s-piece); + } + if (!word) break; + if (!patav) patav = (AV *)sv_2mortal((SV *)newAV()); + av_push(patav, word); + word = NULL; + piece = NULL; + } + else if (!piece) piece = s; + break; + } + } + end_of_parsing: + + if (patav) { + I32 items = AvFILLp(patav) + 1; + SV **svp = AvARRAY(patav); + while (items--) { + PUSHMARK(SP); + PUTBACK; + doglob(aTHX_ SvPVXx(*svp++), flags); + SPAGAIN; + { + dMARK; + dORIGMARK; + while (++MARK <= SP) + av_push(entries, SvREFCNT_inc_simple_NN(*MARK)); + SP = ORIGMARK; + } + } + } + /* piece is set at this point if there is no trailing whitespace. + It is the beginning of the last token or quote-delimited + piece thereof. word is set at this point if the last token has + multiple quoted pieces. */ + if (piece || word) { + if (word) { + if (piece) sv_catpvn(word, piece, s-piece); + piece = SvPVX(word); + } + PUSHMARK(SP); + PUTBACK; + doglob(aTHX_ piece, flags); + if (word) SvREFCNT_dec(word); + SPAGAIN; + { + dMARK; + dORIGMARK; + /* short-circuit here for a fairly common case */ + if (!patav && gimme == G_ARRAY) { PUTBACK; return TRUE; } + while (++MARK <= SP) + av_push(entries, SvREFCNT_inc_simple_NN(*MARK)); + + SP = ORIGMARK; + } + } + PUTBACK; + return FALSE; +} + +static void +csh_glob_iter(pTHX) +{ + iterate(aTHX_ csh_glob); +} + +/* wrapper around doglob that can be passed to the iterator */ +static bool +doglob_iter_wrapper(pTHX_ AV *entries, const char *pattern, STRLEN len, bool is_utf8) +{ + dSP; + SV * flags_sv = get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD); + int const flags = (int)SvIV(flags_sv); + + PERL_UNUSED_VAR(len); /* we use \0 termination instead */ + /* XXX we currently just use the underlying bytes of the passed SV. + * Some day someone needs to make glob utf8 aware */ + PERL_UNUSED_VAR(is_utf8); + + PUSHMARK(SP); + PUTBACK; + doglob(aTHX_ pattern, flags); + SPAGAIN; + { + dMARK; + dORIGMARK; + if (GIMME_V == G_ARRAY) { PUTBACK; return TRUE; } + sv_upgrade((SV *)entries, SVt_PVAV); + while (++MARK <= SP) + av_push(entries, SvREFCNT_inc_simple_NN(*MARK)); + SP = ORIGMARK; + } + return FALSE; +} + +static void +glob_ophook(pTHX_ OP *o) +{ + if (PL_dirty) return; + { + dMY_CXT; + if (MY_CXT.x_GLOB_ENTRIES + && (o->op_type == OP_GLOB || o->op_type == OP_ENTERSUB)) + (void)hv_delete(MY_CXT.x_GLOB_ENTRIES, (char *)&o, sizeof(OP *), + G_DISCARD); + if (MY_CXT.x_GLOB_OLD_OPHOOK) MY_CXT.x_GLOB_OLD_OPHOOK(aTHX_ o); + } +} + +MODULE = File::Glob PACKAGE = File::Glob + +int +GLOB_ERROR() + PREINIT: + dMY_CXT; + CODE: + RETVAL = GLOB_ERROR; + OUTPUT: + RETVAL + +void +bsd_glob(pattern_sv,...) + SV *pattern_sv +PREINIT: + int flags = 0; + char *pattern; + STRLEN len; +PPCODE: + { + pattern = SvPV(pattern_sv, len); + if (!IS_SAFE_SYSCALL(pattern, len, "pattern", "bsd_glob")) + XSRETURN(0); + /* allow for optional flags argument */ + if (items > 1) { + flags = (int) SvIV(ST(1)); + /* remove unsupported flags */ + flags &= ~(GLOB_APPEND | GLOB_DOOFFS | GLOB_ALTDIRFUNC | GLOB_MAGCHAR); + } else { + SV * flags_sv = get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD); + flags = (int)SvIV(flags_sv); + } + + PUTBACK; + doglob(aTHX_ pattern, flags); + SPAGAIN; + } + +PROTOTYPES: DISABLE +void +csh_glob(...) +PPCODE: + /* For backward-compatibility with the original Perl function, we sim- + * ply take the first argument, regardless of how many there are. + */ + if (items) SP ++; + else { + XPUSHs(&PL_sv_undef); + } + PUTBACK; + csh_glob_iter(aTHX); + SPAGAIN; + +void +bsd_glob_override(...) +PPCODE: + if (items) SP ++; + else { + XPUSHs(&PL_sv_undef); + } + PUTBACK; + iterate(aTHX_ doglob_iter_wrapper); + SPAGAIN; + +#ifdef USE_ITHREADS + +void +CLONE(...) +INIT: + HV *glob_entries_clone = NULL; +CODE: + PERL_UNUSED_ARG(items); + { + dMY_CXT; + if ( MY_CXT.x_GLOB_ENTRIES ) { + CLONE_PARAMS param; + param.stashes = NULL; + param.flags = 0; + param.proto_perl = MY_CXT.interp; + + glob_entries_clone = MUTABLE_HV(sv_dup_inc((SV*)MY_CXT.x_GLOB_ENTRIES, ¶m)); + } + } + { + MY_CXT_CLONE; + MY_CXT.x_GLOB_ENTRIES = glob_entries_clone; + MY_CXT.interp = aTHX; + } + +#endif + +BOOT: +{ +#ifndef PERL_EXTERNAL_GLOB + /* Don't do this at home! The globhook interface is highly volatile. */ + PL_globhook = csh_glob_iter; +#endif +} + +BOOT: +{ + MY_CXT_INIT; + { + dMY_CXT; + MY_CXT.x_GLOB_ENTRIES = NULL; + MY_CXT.x_GLOB_OLD_OPHOOK = PL_opfreehook; +#ifdef USE_ITHREADS + MY_CXT.interp = aTHX; +#endif + PL_opfreehook = glob_ophook; + } +} INCLUDE: const-xs.inc diff --git a/gnu/usr.bin/perl/ext/File-Glob/bsd_glob.c b/gnu/usr.bin/perl/ext/File-Glob/bsd_glob.c index 2ba0d494071..821ef200ad6 100644 --- a/gnu/usr.bin/perl/ext/File-Glob/bsd_glob.c +++ b/gnu/usr.bin/perl/ext/File-Glob/bsd_glob.c @@ -602,6 +602,7 @@ glob0(const Char *pattern, glob_t *pglob) return(globextend(qpat, pglob, &limit)); } else if (!(pglob->gl_flags & GLOB_NOSORT)) + if (pglob->gl_pathv) qsort(pglob->gl_pathv + pglob->gl_offs + oldpathc, pglob->gl_pathc - oldpathc, sizeof(char *), (pglob->gl_flags & (GLOB_ALPHASORT|GLOB_NOCASE)) diff --git a/gnu/usr.bin/perl/ext/File-Glob/t/rt114984.t b/gnu/usr.bin/perl/ext/File-Glob/t/rt114984.t index 285bb70e957..43e90d7508c 100644 --- a/gnu/usr.bin/perl/ext/File-Glob/t/rt114984.t +++ b/gnu/usr.bin/perl/ext/File-Glob/t/rt114984.t @@ -16,16 +16,26 @@ my @mp = (1000..1205); my $path = tempdir uc cleanup => 1; +my $md = 0; +my $mp = 0; + foreach (@md) { - open(my $f, ">", catfile $path, "md_$_.dat"); - close $f; + if (open(my $f, ">", catfile $path, "md_$_.dat")) { + $md++; + close $f; + } } foreach (@mp) { - open(my $f, ">", catfile $path, "mp_$_.dat"); - close $f; + if (open(my $f, ">", catfile $path, "mp_$_.dat")) { + $mp++; + close $f; + } +} +my @b = glob(qq{$path/mp_[0123456789]*.dat $path/md_[0123456789]*.dat}); +if ($md+$mp < @md+@mp) { + warn sprintf("$0: expected to create %d files, created only %d (path $path)\n", + @md+@mp, $md+$mp); } -my @b = glob(qq{$path/mp_[0123456789]*.dat - $path/md_[0123456789]*.dat}); -is scalar(@b), @md+@mp, +is scalar(@b), $md+$mp, 'File::Glob extends the stack when returning a long list'; |