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
