Skip to content

readline ARGV: don't try to open '|-' or '-|' and warn #21181

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 1 commit into from
Aug 1, 2023
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
51 changes: 46 additions & 5 deletions doio.c
Original file line number Diff line number Diff line change
Expand Up @@ -1358,6 +1358,36 @@ static const MGVTBL argvout_vtbl =
NULL /* svt_local */
};

static bool
S_is_fork_open(const char *name) {
/* return true if name matches /^\A\s*(\|\s+-|\-\s+|)\s*\z/ */
while (isSPACE(*name))
name++;
if (*name == '|') {
++name;
while (isSPACE(*name))
name++;
if (*name != '-')
return false;
++name;
}
else if (*name == '-') {
++name;
while (isSPACE(*name))
name++;
if (*name != '|')
return false;
++name;
}
else
return false;

while (isSPACE(*name))
name++;

return *name == 0;
}

PerlIO *
Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
{
Expand Down Expand Up @@ -1400,11 +1430,22 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen)
SvSETMAGIC(GvSV(gv));
PL_oldname = SvPVx(GvSV(gv), oldlen);
if (LIKELY(!PL_inplace)) {
if (nomagicopen
? do_open6(gv, "<", 1, NULL, &GvSV(gv), 1)
: do_open6(gv, PL_oldname, oldlen, NULL, NULL, 0)
) {
return IoIFP(GvIOp(gv));
if (nomagicopen) {
if (do_open6(gv, "<", 1, NULL, &GvSV(gv), 1)) {
return IoIFP(GvIOp(gv));
}
}
else {
if (is_fork_open(PL_oldname)) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
"Forked open '%s' not meaningful in <>",
PL_oldname);
continue;
}

if ( do_open6(gv, PL_oldname, oldlen, NULL, NULL, 0) ) {
return IoIFP(GvIOp(gv));
}
}
}
else {
Expand Down
1 change: 1 addition & 0 deletions embed.fnc
Original file line number Diff line number Diff line change
Expand Up @@ -4041,6 +4041,7 @@ S |void |exec_failed |NN const char *cmd \
|int do_report
RS |bool |ingroup |Gid_t testgid \
|bool effective
ST |bool |is_fork_open |NN const char *name
S |bool |openn_cleanup |NN GV *gv \
|NN IO *io \
|NULLOK PerlIO *fp \
Expand Down
1 change: 1 addition & 0 deletions embed.h
Original file line number Diff line number Diff line change
Expand Up @@ -1163,6 +1163,7 @@
# define argvout_final(a,b,c) S_argvout_final(aTHX_ a,b,c)
# define exec_failed(a,b,c) S_exec_failed(aTHX_ a,b,c)
# define ingroup(a,b) S_ingroup(aTHX_ a,b)
# define is_fork_open S_is_fork_open
# define openn_cleanup(a,b,c,d,e,f,g,h,i,j,k,l,m) S_openn_cleanup(aTHX_ a,b,c,d,e,f,g,h,i,j,k,l,m)
# define openn_setup(a,b,c,d,e,f) S_openn_setup(aTHX_ a,b,c,d,e,f)
# endif
Expand Down
7 changes: 7 additions & 0 deletions pod/perldiag.pod
Original file line number Diff line number Diff line change
Expand Up @@ -2604,6 +2604,13 @@ same name?
iterate multiple values at a time. This syntax is currently experimental
and its behaviour may change in future releases of Perl.

=item Forked open '%s' not meaningful in <>

(S inplace) You had C<|-> or C<-|> in C<@ARGV> and tried to use C<< <>
>> to read from it.

Previously this would fork and produce a confusing error message.

=item Format not terminated

(F) A format must be terminated by a line with a solitary dot. Perl got
Expand Down
5 changes: 5 additions & 0 deletions proto.h

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

16 changes: 15 additions & 1 deletion t/io/argv.t
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,7 @@ BEGIN {
set_up_inc('../lib');
}

plan(tests => 37);
plan(tests => 53);

my ($devnull, $no_devnull);

Expand Down Expand Up @@ -252,6 +252,20 @@ close IN;
unlink "tmpIo_argv3.tmp";
**PROG**

{
my $warn;
local $SIG{__WARN__} = sub { $warn = "@_" };
for my $op ("|-", "-|", "| -", "- |") {
for my $forked ($op, " $op", "$op ", " $op ") {
@ARGV = ( $forked );
undef $warn;
while (<>) {}
like($warn, qr/^Forked open '\Q$forked\E' not meaningful in <>/,
"check for warning for $forked");
}
}
}

# This used to fail an assertion.
# The tricks with *x and $x are to make PL_argvgv point to a freed SV when
# the readline op does SvREFCNT_inc on it. undef *x clears the scalar slot
Expand Down