In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/ef32f9b97b7f6ea1925757be14c852b20c8145c4?hp=f276fdad8f6660f36944c895587a7748585e4969>
- Log ----------------------------------------------------------------- commit ef32f9b97b7f6ea1925757be14c852b20c8145c4 Author: Rafael Garcia-Suarez <r...@consttype.org> Date: Tue Sep 30 01:19:55 2014 +0200 Add tests for empty strings in @ARGV which should be refused, since no file name should be empty. (Suggested by Richard Soderberg) M t/io/argv.t commit 80a96bfc62584b11992aecd2fb33c6f21cfc24b9 Author: Rafael Garcia-Suarez <r...@consttype.org> Date: Tue Sep 30 00:25:27 2014 +0200 Clarify the documentation for <<>> M pod/perlop.pod commit c6f54c1d24664c889a16e7f7d380041a2696f957 Author: Rafael Garcia-Suarez <r...@consttype.org> Date: Tue Sep 30 00:24:21 2014 +0200 Add tests for $ARGV There weren't apparently any. This also tests that $ARGV behaves correctly both with <> and <<>>. M t/io/argv.t commit 7889afd0b7500393350d5f3dbd5c49b45e3b86d3 Author: Rafael Garcia-Suarez <r...@consttype.org> Date: Mon Sep 29 22:52:32 2014 +0200 Add tests for the <<>> operator M t/io/argv.t commit 1033ba6ee622b4ae14475c6261820c9949ff012f Author: Peter Martini <petercmart...@gmail.com> Date: Sun Aug 10 23:11:20 2014 -0400 Added some documentation for while(<<>>) M pod/perlop.pod commit 157fb5a14d10ed16ffc6ebfc43d2637a016fdfce Author: Rafael Garcia-Suarez <r...@consttype.org> Date: Thu Jul 24 17:43:29 2014 +0200 Introduce the double-diamond operator <<>> This operator works like <> or <ARGV>, as it reads the list of file names to open from the command-line arguments. However, it disables the magic-open feature (that forks to execute piped commands) : $ bleadperl -e 'while(<>){print}' 'echo foo |' foo $ bleadperl -e 'while(<<>>){print}' 'echo foo |' Can't open echo foo |: No such file or directory at -e line 1. M doio.c M embed.fnc M embed.h M op.c M pp_hot.c M pp_sys.c M proto.h M toke.c ----------------------------------------------------------------------- Summary of changes: doio.c | 9 ++++-- embed.fnc | 2 +- embed.h | 2 +- op.c | 2 +- pod/perlop.pod | 14 ++++++++-- pp_hot.c | 4 +-- pp_sys.c | 2 +- proto.h | 2 +- t/io/argv.t | 88 ++++++++++++++++++++++++++++++++++++++++++++++++++++++---- toke.c | 15 ++++++++-- 10 files changed, 120 insertions(+), 20 deletions(-) diff --git a/doio.c b/doio.c index a631eeb..c7aceca 100644 --- a/doio.c +++ b/doio.c @@ -799,7 +799,7 @@ say_false: } PerlIO * -Perl_nextargv(pTHX_ GV *gv) +Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) { IO * const io = GvIOp(gv); @@ -837,7 +837,10 @@ Perl_nextargv(pTHX_ GV *gv) SvSETMAGIC(GvSV(gv)); PL_oldname = SvPVx(GvSV(gv), oldlen); if (LIKELY(!PL_inplace)) { - if (do_open6(gv, PL_oldname, oldlen, NULL, NULL, 0)) { + if (nomagicopen + ? do_open6(gv, "<", 1, NULL, &GvSV(gv), 1) + : do_open6(gv, PL_oldname, oldlen, NULL, NULL, 0) + ) { return IoIFP(GvIOp(gv)); } } @@ -1126,7 +1129,7 @@ Perl_do_eof(pTHX_ GV *gv) PerlIO_set_cnt(IoIFP(io),-1); } if (PL_op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */ - if (gv != PL_argvgv || !nextargv(gv)) /* get another fp handy */ + if (gv != PL_argvgv || !nextargv(gv, FALSE)) /* get another fp handy */ return TRUE; } else diff --git a/embed.fnc b/embed.fnc index 5fa38e8..5de2f83 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1056,7 +1056,7 @@ Apd |SV* |vnormal |NN SV *vs Apd |SV* |vstringify |NN SV *vs Apd |int |vcmp |NN SV *lhv|NN SV *rhv : Used in pp_hot.c and pp_sys.c -p |PerlIO*|nextargv |NN GV* gv +p |PerlIO*|nextargv |NN GV* gv|bool nomagicopen AnpP |char* |ninstr |NN const char* big|NN const char* bigend \ |NN const char* little|NN const char* lend Apd |void |op_free |NULLOK OP* arg diff --git a/embed.h b/embed.h index 1fe7076..ed04c7c 100644 --- a/embed.h +++ b/embed.h @@ -1248,7 +1248,7 @@ #define newSTUB(a,b) Perl_newSTUB(aTHX_ a,b) #define newSVavdefelem(a,b,c) Perl_newSVavdefelem(aTHX_ a,b,c) #define newXS_len_flags(a,b,c,d,e,f,g) Perl_newXS_len_flags(aTHX_ a,b,c,d,e,f,g) -#define nextargv(a) Perl_nextargv(aTHX_ a) +#define nextargv(a,b) Perl_nextargv(aTHX_ a,b) #define oopsAV(a) Perl_oopsAV(aTHX_ a) #define oopsHV(a) Perl_oopsHV(aTHX_ a) #define op_const_sv(a,b) Perl_op_const_sv(aTHX_ a,b) diff --git a/op.c b/op.c index d0b6173..08e6028 100644 --- a/op.c +++ b/op.c @@ -9520,7 +9520,7 @@ Perl_ck_readline(pTHX_ OP *o) } else { OP * const newop - = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); + = newUNOP(OP_READLINE, o->op_flags | OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); op_free(o); return newop; } diff --git a/pod/perlop.pod b/pod/perlop.pod index 52eb968..07bcaf9 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -2853,7 +2853,7 @@ mean C</^/m>. =head2 I/O Operators X<operator, i/o> X<operator, io> X<io> X<while> X<filehandle> -X<< <> >> X<@ARGV> +X<< <> >> X<< <<>> >> X<@ARGV> There are several I/O operators you should know about. @@ -2979,7 +2979,17 @@ it interprets special characters, so if you have a script like this: and call it with C<perl dangerous.pl 'rm -rfv *|'>, it actually opens a pipe, executes the C<rm> command and reads C<rm>'s output from that pipe. If you want all items in C<@ARGV> to be interpreted as file names, you -can use the module C<ARGV::readonly> from CPAN. +can use the module C<ARGV::readonly> from CPAN, or use the double bracket: + + while (<<>>) { + print; + } + +Using double angle brackets inside of a while causes the open to use the +three argument form (with the second argument being C<< < >>), so all +arguments in ARGV are treated as literal filenames (including "-"). +(Note that for convenience, if you use C<< <<>> >> and if @ARGV is +empty, it will still read from the standard input.) You can modify @ARGV before the first <> as long as the array ends up containing the list of filenames you really want. Line numbers (C<$.>) diff --git a/pp_hot.c b/pp_hot.c index 63e0836..e8c3543 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1588,7 +1588,7 @@ Perl_do_readline(pTHX) goto have_fp; } } - fp = nextargv(PL_last_in_gv); + fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL); if (!fp) { /* Note: fp != IoIFP(io) */ (void)do_close(PL_last_in_gv, FALSE); /* now it does*/ } @@ -1675,7 +1675,7 @@ Perl_do_readline(pTHX) { PerlIO_clearerr(fp); if (IoFLAGS(io) & IOf_ARGV) { - fp = nextargv(PL_last_in_gv); + fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL); if (fp) continue; (void)do_close(PL_last_in_gv, FALSE); diff --git a/pp_sys.c b/pp_sys.c index 014ec42..95a709b 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -2124,7 +2124,7 @@ PP(pp_eof) GvSV(gv) = newSVpvs("-"); SvSETMAGIC(GvSV(gv)); } - else if (!nextargv(gv)) + else if (!nextargv(gv, FALSE)) RETPUSHYES; } } diff --git a/proto.h b/proto.h index 4f36b27..bd6234f 100644 --- a/proto.h +++ b/proto.h @@ -3100,7 +3100,7 @@ PERL_CALLCONV STRLEN * Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const ch #define PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD \ assert(bits) -PERL_CALLCONV PerlIO* Perl_nextargv(pTHX_ GV* gv) +PERL_CALLCONV PerlIO* Perl_nextargv(pTHX_ GV* gv, bool nomagicopen) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_NEXTARGV \ assert(gv) diff --git a/t/io/argv.t b/t/io/argv.t index a1febaf..b3825bb 100644 --- a/t/io/argv.t +++ b/t/io/argv.t @@ -7,7 +7,7 @@ BEGIN { BEGIN { require "./test.pl"; } -plan(tests => 24); +plan(tests => 34); my ($devnull, $no_devnull); @@ -21,6 +21,9 @@ if (is_miniperl()) { open(TRY, '>Io_argv1.tmp') || (die "Can't open temp file: $!"); print TRY "a line\n"; close TRY or die "Could not close: $!"; +open(TRY, '>Io_argv2.tmp') || (die "Can't open temp file: $!"); +print TRY "another line\n"; +close TRY or die "Could not close: $!"; $x = runperl( prog => 'while (<>) { print $., $_; }', @@ -34,13 +37,32 @@ is($x, "1a line\n2a line\n", '<> from two files'); stdin => "foo\n", args => [ 'Io_argv1.tmp', '-' ], ); - is($x, "a line\nfoo\n", ' from a file and STDIN'); + is($x, "a line\nfoo\n", '<> from a file and STDIN'); $x = runperl( prog => 'while (<>) { print $_; }', stdin => "foo\n", ); - is($x, "foo\n", ' from just STDIN'); + is($x, "foo\n", '<> from just STDIN'); + + $x = runperl( + prog => 'while (<>) { print $ARGV.q/,/.$_ }', + args => [ 'Io_argv1.tmp', 'Io_argv2.tmp' ], + ); + is($x, "Io_argv1.tmp,a line\nIo_argv2.tmp,another line\n", '$ARGV is the file name'); + + $x = runperl( + prog => 'print $ARGV while <>', + stdin => "foo\nbar\n", + args => [ '-' ], + ); + is($x, "--", '$ARGV is - for explicit STDIN'); + + $x = runperl( + prog => 'print $ARGV while <>', + stdin => "foo\nbar\n", + ); + is($x, "--", '$ARGV is - for implicit STDIN'); } { @@ -69,7 +91,7 @@ close TRY or die "Could not close: $!"; @ARGV = ('Io_argv1.tmp', 'Io_argv2.tmp'); $^I = '_bak'; # not .bak which confuses VMS $/ = undef; -my $i = 7; +my $i = 10; while (<>) { s/^/ok $i\n/; ++$i; @@ -94,7 +116,7 @@ open STDIN, 'Io_argv1.tmp' or die $!; @ARGV = (); ok( !eof(), 'STDIN has something' ); -is( <>, "ok 7\n" ); +is( <>, "ok 10\n" ); SKIP: { skip_if_miniperl($no_devnull, 4); @@ -132,6 +154,62 @@ SKIP: { close $fh or die "Could not close: $!"; } +open(TRY, '>Io_argv1.tmp') || (die "Can't open temp file: $!"); +print TRY "one\ntwo\n"; +close TRY or die "Could not close: $!"; + +$x = runperl( + prog => 'print $..$ARGV.$_ while <<>>', + args => [ 'Io_argv1.tmp' ], +); +is($x, "1Io_argv1.tmpone\n2Io_argv1.tmptwo\n", '<<>>'); + +$x = runperl( + prog => 'while (<<>>) { print }', + stdin => "foo\n", +); +is($x, "foo\n", '<<>> from just STDIN (no argument)'); + +$x = runperl( + prog => 'print $ARGV.q/,/ for <<>>', + stdin => "foo\nbar\n", +); +is($x, "-,-,", '$ARGV is - for STDIN with <<>>'); + +$x = runperl( + prog => 'while (<<>>) { print $_; }', + stdin => "foo\n", + stderr => 1, + args => [ '-' ], +); +is($x, "Can't open -: No such file or directory at -e line 1.\n", '<<>> does not treat - as STDIN'); + +{ + # tests for an empty string in @ARGV + $x = runperl( + prog => 'push @ARGV,q//;print while <>', + stderr => 1, + ); + is($x, "Can't open : No such file or directory at -e line 1.\n", '<<>> does not treat - as STDIN'); + + $x = runperl( + prog => 'push @ARGV,q//;print while <<>>', + stderr => 1, + ); + is($x, "Can't open : No such file or directory at -e line 1.\n", '<<>> does not treat - as STDIN'); +} + +SKIP: { + skip('no echo', 1) unless -x '/bin/echo'; + + $x = runperl( + prog => 'while (<<>>) { print $_; }', + stderr => 1, + args => [ '"echo foo |"' ], + ); + is($x, "Can't open echo foo |: No such file or directory at -e line 1.\n", '<<>> does not treat ...| as fork'); +} + # This used to dump core fresh_perl_is( <<'**PROG**', "foobar", {}, "ARGV aliasing and eof()" ); open OUT, ">Io_argv3.tmp" or die "Can't open temp file: $!"; diff --git a/toke.c b/toke.c index 33a68c6..ff4c789 100644 --- a/toke.c +++ b/toke.c @@ -5796,7 +5796,7 @@ Perl_yylex(pTHX) if (PL_expect != XOPERATOR) { if (s[1] != '<' && !strchr(s,'>')) check_uni(); - if (s[1] == '<') + if (s[1] == '<' && s[2] != '>') s = scan_heredoc(s); else s = scan_inputsymbol(s); @@ -9279,6 +9279,7 @@ S_scan_heredoc(pTHX_ char *s) This code handles: <> read from ARGV + <<>> read from ARGV without magic open <FH> read from filehandle <pkg::FH> read from package qualified filehandle <pkg'FH> read from package qualified filehandle @@ -9293,6 +9294,7 @@ S_scan_inputsymbol(pTHX_ char *start) char *s = start; /* current position in buffer */ char *end; I32 len; + bool nomagicopen = FALSE; char *d = PL_tokenbuf; /* start of temp holding space */ const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */ @@ -9301,7 +9303,14 @@ S_scan_inputsymbol(pTHX_ char *start) end = strchr(s, '\n'); if (!end) end = PL_bufend; - s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */ + if (s[1] == '<' && s[2] == '>' && s[3] == '>') { + nomagicopen = TRUE; + *d = '\0'; + len = 0; + s += 3; + } + else + s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */ /* die if we didn't have space for the contents of the <>, or if it didn't end, or if we see a newline @@ -9411,7 +9420,7 @@ intro_sym: op_append_elem(OP_LIST, newGVOP(OP_GV, 0, gv), newCVREF(0, newGVOP(OP_GV, 0, gv_readline)))) - : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv)); + : (OP*)newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv)); pl_yylval.ival = OP_NULL; } } -- Perl5 Master Repository