Skip to content
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

5.28.0 regression: In-place edit without "while(<>)" does not replace files #16748

Closed
p5pRT opened this issue Nov 15, 2018 · 32 comments
Closed

Comments

@p5pRT
Copy link

p5pRT commented Nov 15, 2018

Migrated from rt.perl.org#133659 (status was 'resolved')

Searchable as RT133659$

@p5pRT
Copy link
Author

p5pRT commented Nov 15, 2018

From @ppisar

Hello,

I'm forwarding a bug report
<https://bugzilla.redhat.com/show_bug.cgi?id=1650041> about a regression in
in-place edits first seen in perl 5.28.0​:

If perl is asked for an in-place edit with an "-i" option and the Perl code
does not use "while(<>){...}" idiom, the output file is deleted instead of
renamed back to the input file name​:

$ cat test
1
$ strace perl -i -e '$/=undef; $a=<>; $a=~s/1/2/; print $a' test
[...]
openat(AT_FDCWD, "test", O_RDONLY|O_CLOEXEC) = 3
ioctl(3, TCGETS, 0x7ffeb193f510) = -1 ENOTTY (Inappropriate ioctl for device)
lseek(3, 0, SEEK_CUR) = 0
fstat(3, {st_mode=S_IFREG|0664, st_size=2, ...}) = 0
umask(0177) = 002
getpid() = 1192
openat(AT_FDCWD, "XXH6qplJ", O_RDWR|O_CREAT|O_EXCL|O_CLOEXEC, 0600) = 4
fcntl(4, F_GETFD) = 0x1 (flags FD_CLOEXEC)
umask(002) = 0177
fcntl(4, F_SETFD, FD_CLOEXEC) = 0
ioctl(4, TCGETS, 0x7ffeb193f5a0) = -1 ENOTTY (Inappropriate ioctl for device)
lseek(4, 0, SEEK_CUR) = 0
fstat(4, {st_mode=S_IFREG|0600, st_size=0, ...}) = 0
getpid() = 1192
openat(AT_FDCWD, ".", O_RDONLY|O_NONBLOCK|O_CLOEXEC|O_DIRECTORY) = 5
fstat(5, {st_mode=S_IFDIR|S_ISVTX|0777, st_size=180, ...}) = 0
brk(NULL) = 0x55f03b859000
brk(0x55f03b87b000) = 0x55f03b87b000
fstat(4, {st_mode=S_IFREG|0600, st_size=0, ...}) = 0
fchmod(4, 0100664) = 0
fstat(3, {st_mode=S_IFREG|0664, st_size=2, ...}) = 0
read(3, "1\n", 8192) = 2
read(3, "", 8192) = 0
[...]
write(4, "2\n", 2) = 2
close(3) = 0
getpid() = 1192
close(4) = 0
unlinkat(5, "XXH6qplJ", 0) = 0
[...]
close(5) = 0
exit_group(0) = ?

Expected behvior is that the "test" file ends up with "2\n" inside. As you can
see in ther strace output, the output file was unlinked instead of renamed
from "XXH6qplJ" to "test".

I can reproduce it with 5.28.0 as well as with latest blead
v5.29.4-43-ged0ccc61a6. The example works with 5.26.2.

Reducing the reproducer I got this code that works​:

$ ./perl -Ilib -i -e '$/=undef; while ($_=<>) {s/1/2/; print}' /tmp/test

while this does not work​:

$ ./perl -Ilib -i -e '$/=undef; $_=<>; {s/1/2/; print}' /tmp/test

It seems there is a special handling for "while(<>)" that triggers the final
rename. I believe this regression comes with the more secure file replacement
introduced in 5.28.0.

By the way, perlrun POD setion for "-i" option seems out-dated as it still
reads​:

  [...] It does this by renaming the input file, opening
  the output file by the original name, and selecting that output
  file as the default for print() statements.

While the 5.28.0 code first creates a temporary file, write an output there
and then renames it back to the original name.

-- Petr

@p5pRT
Copy link
Author

p5pRT commented Nov 15, 2018

From @jkeenan

On Thu, 15 Nov 2018 11​:42​:26 GMT, ppisar wrote​:

Hello,

I'm forwarding a bug report
<https://bugzilla.redhat.com/show_bug.cgi?id=1650041> about a
regression in
in-place edits first seen in perl 5.28.0​:

If perl is asked for an in-place edit with an "-i" option and the Perl
code
does not use "while(<>){...}" idiom, the output file is deleted
instead of
renamed back to the input file name​:

[snip]

Reducing the reproducer I got this code that works​:

$ ./perl -Ilib -i -e '$/=undef; while ($_=<>) {s/1/2/; print}'
/tmp/test

while this does not work​:

$ ./perl -Ilib -i -e '$/=undef; $_=<>; {s/1/2/; print}' /tmp/test

Does anyone have any idea how to bisect this?

So far I haven't been able to figure out how to fit this into one of the examples in 'perldoc Porting/bisect-runner.pl'.

[snip]

Thank you very much.

--
James E Keenan (jkeenan@​cpan.org)

@p5pRT
Copy link
Author

p5pRT commented Nov 15, 2018

The RT System itself - Status changed from 'new' to 'open'

@p5pRT
Copy link
Author

p5pRT commented Nov 15, 2018

From @tonycoz

On Thu, 15 Nov 2018 03​:42​:26 -0800, ppisar wrote​:

Expected behvior is that the "test" file ends up with "2\n" inside. As
you can
see in ther strace output, the output file was unlinked instead of
renamed
from "XXH6qplJ" to "test".

I can reproduce it with 5.28.0 as well as with latest blead
v5.29.4-43-ged0ccc61a6. The example works with 5.26.2.

Reducing the reproducer I got this code that works​:

$ ./perl -Ilib -i -e '$/=undef; while ($_=<>) {s/1/2/; print}'
/tmp/test

while this does not work​:

$ ./perl -Ilib -i -e '$/=undef; $_=<>; {s/1/2/; print}' /tmp/test

It seems there is a special handling for "while(<>)" that triggers the
final
rename. I believe this regression comes with the more secure file
replacement
introduced in 5.28.0.

It's not the while() in particular that's special, but calling <> again to iterate to the next file (or the end of the list.)

I hadn't considered the non-looping in-place editing (and none of the tests do it that I'm aware of), but I was trying to get reasonable behaviour for​:

  perl -i -pe 's/FAILED/OK/ or die' somefile

Should the file be replaced if the code dies?

I don't know a way to detect in the magic that does the clean up whether we're cleaning up due to a die or falling off the end of the code as in your case.

As a workaround you can explicitly close ARGVOUT​:

./perl -i -e 'local $/; my $s=<>; $s=~s/FAILED/OK/; print $s; close ARGVOUT'

Maybe it should always replace it like it did previously.

By the way, perlrun POD setion for "-i" option seems out-dated as it
still
reads​:

[...] It does this by renaming the input file, opening
the output file by the original name, and selecting that output
file as the default for print() statements.

While the 5.28.0 code first creates a temporary file, write an output
there
and then renames it back to the original name.

Yes, this needs to be updated.

Tony

@p5pRT
Copy link
Author

p5pRT commented Nov 16, 2018

From @ppisar

On 2018-11-15, "James E Keenan via RT" <perlbug-followup@​perl.org> wrote​:

Reducing the reproducer I got this code that works​:

$ ./perl -Ilib -i -e '$/=undef; while ($_=<>) {s/1/2/; print}'
/tmp/test

while this does not work​:

$ ./perl -Ilib -i -e '$/=undef; $_=<>; {s/1/2/; print}' /tmp/test

Does anyone have any idea how to bisect this?

So far I haven't been able to figure out how to fit this into one of
the examples in 'perldoc Porting/bisect-runner.pl'.

I finished bisecting now (using my own scripts) and it converged to this commit
(v5.27.3-66-ge0d4aead3c)​:

commit e0d4aea (HEAD, refs/bisect/bad)
Author​: Tony Cook <tony@​develop-help.com>
Date​: Wed Jan 11 14​:49​:53 2017 +1100

  (perl #127663) safer in-place editing
 
  Previously in-place editing opened the file then immediately
  *replaced* the file, so if an error occurs while writing the output,
  such as running out of space, the content of the original file is lost.
 
  This changes in-place editing to write to a work file which is renamed
  over the original only once the output file is successfully closed.
 
  It also fixes an issue with setting setuid/setgid file modes for
  recursive in-place editing.

-- Petr

@p5pRT
Copy link
Author

p5pRT commented Nov 16, 2018

From @ppisar

On 2018-11-15, "Tony Cook via RT" <perlbug-followup@​perl.org> wrote​:

It's not the while() in particular that's special, but calling <>
again to iterate to the next file (or the end of the list.)

I hadn't considered the non-looping in-place editing (and none of the
tests do it that I'm aware of), but I was trying to get reasonable
behaviour for​:

perl -i -pe 's/FAILED/OK/ or die' somefile

Should the file be replaced if the code dies?

In my opinion, the file should be kept intact if the interpreter is
going to terminate because of an error (die, exit 1, an I/O failure).
That's the point of
<https://rt.perl.org/Public/Bug/Display.html?id=57512#txn-673862> (still
not fully resolved).

However, I can image that a multiple file edit cannot have a correct
behavior​:

$ perl -i -pe 's/FAILED/OK/ or die' somefile anotherfile

because if somefile edits and replaces successfully but editing
anotherfile fails, perl as a whole command will return an error exit
code but somefile will have been already mangled. (I know perl is not
a transactional database system.) We would have to postpone the file
rename after processing all arguments and that could exhaust open file
descriptors and disk space. I don't think it's feasible to take the
multiple file usecase seriously.

I don't know a way to detect in the magic that does the clean up
whether we're cleaning up due to a die or falling off the end of the
code as in your case.

Can we decide on $@​ value? Or better on some flag that instructs perl
process to return a non-zero exit code?

As a workaround you can explicitly close ARGVOUT​:

./perl -i -e 'local $/; my $s=<>; $s=~s/FAILED/OK/; print $s; close ARGVOUT'

Yes, the explicit close helps here.

-- Petr

@p5pRT
Copy link
Author

p5pRT commented Nov 19, 2018

From @peff

Created by @peff

In perl 5.26.0 and earlier, using "-i" would modify the file even if you
left a "-p" loop early. E.g.​:

  $ echo foo >file
  $ perl -i -pe 'last' file
  $ cat file
  [no output; we left the loop before printing anything]

But in 5.28.0, the file is left untouched​:

  $ cat file
  foo

This bisects in the perl-git mirror to e0d4aea ((perl #127663) safer
in-place editing, 2017-01-11), and reproduces even on the current tip of
that mirror's master branch.

The above code is obviously a toy example to reproduce the issue. If you
want a more real-world case, the script I noticed this in was printing
the first non-comment line in a file​:

  perl -i -ne 'print && exit 0 if /^[^#]/' $file

Perl Info

Flags:
    category=core
    severity=medium

Site configuration information for perl 5.28.0:

Configured by Debian at Wed Oct 31 15:45:10 UTC 2018.

Summary of my perl5 (revision 5 version 28 subversion 0) configuration:
   
  Platform:
    osname=linux
    osvers=4.9.0
    archname=x86_64-linux-gnu-thread-multi
    uname='linux localhost 4.9.0 #1 smp debian 4.9.0 x86_64 gnulinux '
    config_args='-Dusethreads -Duselargefiles -Dcc=x86_64-linux-gnu-gcc -Dcpp=x86_64-linux-gnu-cpp -Dld=x86_64-linux-gnu-gcc -Dccflags=-DDEBIAN -Wdate-time -D_FORTIFY_SOURCE=2 -g -O2 -fdebug-prefix-map=/build/perl-wsSTqO/perl-5.28.0=. -fstack-protector-strong -Wformat -Werror=format-security -Dldflags= -Wl,-z,relro -Dlddlflags=-shared -Wl,-z,relro -Dcccdlflags=-fPIC -Darchname=x86_64-linux-gnu -Dprefix=/usr -Dprivlib=/usr/share/perl/5.28 -Darchlib=/usr/lib/x86_64-linux-gnu/perl/5.28 -Dvendorprefix=/usr -Dvendorlib=/usr/share/perl5 -Dvendorarch=/usr/lib/x86_64-linux-gnu/perl5/5.28 -Dsiteprefix=/usr/local -Dsitelib=/usr/local/share/perl/5.28.0 -Dsitearch=/usr/local/lib/x86_64-linux-gnu/perl/5.28.0 -Dman1dir=/usr/share/man/man1 -Dman3dir=/usr/share/man/man3 -Dsiteman1dir=/usr/local/man/man1 -Dsiteman3dir=/usr/local/man/man3 -Duse64bitint -Dman1ext=1 -Dman3ext=3perl
-Dpager=/usr/bin/sensible-pager -Uafs -Ud_csh -Ud_ualarm -Uusesfio -Uusenm -Ui_libutil -Ui_xlocale -Uversiononly -DDEBUGGING=-g -Doptimize=-O2 -dEs -Duseshrplib -Dlibperl=libperl.so.5.28.0'
    hint=recommended
    useposix=true
    d_sigaction=define
    useithreads=define
    usemultiplicity=define
    use64bitint=define
    use64bitall=define
    uselongdouble=undef
    usemymalloc=n
    default_inc_excludes_dot=define
    bincompat5005=undef
  Compiler:
    cc='x86_64-linux-gnu-gcc'
    ccflags ='-D_REENTRANT -D_GNU_SOURCE -DDEBIAN -fwrapv -fno-strict-aliasing -pipe -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'
    optimize='-O2 -g'
    cppflags='-D_REENTRANT -D_GNU_SOURCE -DDEBIAN -fwrapv -fno-strict-aliasing -pipe -I/usr/local/include'
    ccversion=''
    gccversion='8.2.0'
    gccosandvers=''
    intsize=4
    longsize=8
    ptrsize=8
    doublesize=8
    byteorder=12345678
    doublekind=3
    d_longlong=define
    longlongsize=8
    d_longdbl=define
    longdblsize=16
    longdblkind=3
    ivtype='long'
    ivsize=8
    nvtype='double'
    nvsize=8
    Off_t='off_t'
    lseeksize=8
    alignbytes=8
    prototype=define
  Linker and Libraries:
    ld='x86_64-linux-gnu-gcc'
    ldflags =' -fstack-protector-strong -L/usr/local/lib'
    libpth=/usr/local/lib /usr/lib/gcc/x86_64-linux-gnu/8/include-fixed /usr/include/x86_64-linux-gnu /usr/lib /lib/x86_64-linux-gnu /lib/../lib /usr/lib/x86_64-linux-gnu /usr/lib/../lib /lib
    libs=-lgdbm -lgdbm_compat -ldb -ldl -lm -lpthread -lc -lcrypt
    perllibs=-ldl -lm -lpthread -lc -lcrypt
    libc=libc-2.27.so
    so=so
    useshrplib=true
    libperl=libperl.so.5.28
    gnulibc_version='2.27'
  Dynamic Linking:
    dlsrc=dl_dlopen.xs
    dlext=so
    d_dlsymun=undef
    ccdlflags='-Wl,-E'
    cccdlflags='-fPIC'
    lddlflags='-shared -L/usr/local/lib -fstack-protector-strong'

Locally applied patches:
    DEBPKG:debian/cpan_definstalldirs - Provide a sensible INSTALLDIRS default for modules installed from CPAN.
    DEBPKG:debian/db_file_ver - https://bugs.debian.org/340047 Remove overly restrictive DB_File version check.
    DEBPKG:debian/doc_info - Replace generic man(1) instructions with Debian-specific information.
    DEBPKG:debian/enc2xs_inc - https://bugs.debian.org/290336 Tweak enc2xs to follow symlinks and ignore missing @INC directories.
    DEBPKG:debian/errno_ver - https://bugs.debian.org/343351 Remove Errno version check due to upgrade problems with long-running processes.
    DEBPKG:debian/libperl_embed_doc - https://bugs.debian.org/186778 Note that libperl-dev package is required for embedded linking
    DEBPKG:fixes/respect_umask - Respect umask during installation
    DEBPKG:debian/writable_site_dirs - Set umask approproately for site install directories
    DEBPKG:debian/extutils_set_libperl_path - EU:MM: set location of libperl.a under /usr/lib
    DEBPKG:debian/no_packlist_perllocal - Don't install .packlist or perllocal.pod for perl or vendor
    DEBPKG:debian/fakeroot - Postpone LD_LIBRARY_PATH evaluation to the binary targets.
    DEBPKG:debian/instmodsh_doc - Debian policy doesn't install .packlist files for core or vendor.
    DEBPKG:debian/ld_run_path - Remove standard libs from LD_RUN_PATH as per Debian policy.
    DEBPKG:debian/libnet_config_path - Set location of libnet.cfg to /etc/perl/Net as /usr may not be writable.
    DEBPKG:debian/perlivp - https://bugs.debian.org/510895 Make perlivp skip include directories in /usr/local
    DEBPKG:debian/squelch-locale-warnings - https://bugs.debian.org/508764 Squelch locale warnings in Debian package maintainer scripts
    DEBPKG:debian/patchlevel - https://bugs.debian.org/567489 List packaged patches for 5.28.0-3 in patchlevel.h
    DEBPKG:fixes/document_makemaker_ccflags - https://bugs.debian.org/628522 [rt.cpan.org #68613] Document that CCFLAGS should include $Config{ccflags}
    DEBPKG:debian/find_html2text - https://bugs.debian.org/640479 Configure CPAN::Distribution with correct name of html2text
    DEBPKG:debian/perl5db-x-terminal-emulator.patch - https://bugs.debian.org/668490 Invoke x-terminal-emulator rather than xterm in perl5db.pl
    DEBPKG:debian/cpan-missing-site-dirs - https://bugs.debian.org/688842 Fix CPAN::FirstTime defaults with nonexisting site dirs if a parent is writable
    DEBPKG:fixes/memoize_storable_nstore - [rt.cpan.org #77790] https://bugs.debian.org/587650 Memoize::Storable: respect 'nstore' option not respected
    DEBPKG:debian/makemaker-pasthru - https://bugs.debian.org/758471 Pass LD settings through to subdirectories
    DEBPKG:debian/makemaker-manext - https://bugs.debian.org/247370 Make EU::MakeMaker honour MANnEXT settings in generated manpage headers
    DEBPKG:debian/kfreebsd-softupdates - https://bugs.debian.org/796798 Work around Debian Bug#796798
    DEBPKG:fixes/autodie-scope - https://bugs.debian.org/798096 Fix a scoping issue with "no autodie" and the "system" sub
    DEBPKG:fixes/memoize-pod - [rt.cpan.org #89441] Fix POD errors in Memoize
    DEBPKG:debian/hurd-softupdates - https://bugs.debian.org/822735 Fix t/op/stat.t failures on hurd
    DEBPKG:fixes/math_complex_doc_great_circle - https://bugs.debian.org/697567 [rt.cpan.org #114104] Math::Trig: clarify definition of great_circle_midpoint
    DEBPKG:fixes/math_complex_doc_see_also - https://bugs.debian.org/697568 [rt.cpan.org #114105] Math::Trig: add missing SEE ALSO
    DEBPKG:fixes/math_complex_doc_angle_units - https://bugs.debian.org/731505 [rt.cpan.org #114106] Math::Trig: document angle units
    DEBPKG:fixes/cpan_web_link - https://bugs.debian.org/367291 CPAN: Add link to main CPAN web site
    DEBPKG:debian/hppa_op_optimize_workaround - https://bugs.debian.org/838613 Temporarily lower the optimization of op.c on hppa due to gcc-6 problems
    DEBPKG:debian/installman-utf8 - https://bugs.debian.org/840211 Generate man pages with UTF-8 characters
    DEBPKG:fixes/getopt-long-4 - https://bugs.debian.org/864544 [rt.cpan.org #122068] Fix issue #122068.
    DEBPKG:debian/hppa_opmini_optimize_workaround - https://bugs.debian.org/869122 Lower the optimization level of opmini.c on hppa
    DEBPKG:debian/sh4_op_optimize_workaround - https://bugs.debian.org/869373 Also lower the optimization level of op.c and opmini.c on sh4
    DEBPKG:debian/perldoc-pager - https://bugs.debian.org/870340 [rt.cpan.org #120229] Fix perldoc terminal escapes when sensible-pager is less
    DEBPKG:debian/prune_libs - https://bugs.debian.org/128355 Prune the list of libraries wanted to what we actually need.
    DEBPKG:debian/mod_paths - Tweak @INC ordering for Debian
    DEBPKG:debian/configure-regen - https://bugs.debian.org/762638 Regenerate Configure et al. after probe unit changes
    DEBPKG:debian/deprecate-with-apt - https://bugs.debian.org/747628 Point users to Debian packages of deprecated core modules
    DEBPKG:debian/disable-stack-check - https://bugs.debian.org/902779 [perl #133327] Disable debugperl stack extension checks for binary compatibility with perl
    DEBPKG:fixes/in-place-edit-handles - https://bugs.debian.org/902925 [perl #133314] (perl #133314) always close the directory handle on clean up
    DEBPKG:debian/gdbm-fatal - [perl #133295] https://bugs.debian.org/904005 Temporarily skip GDBM_File fatal.t for gdbm >= 1.15 compatibility


@INC for perl 5.28.0:
    /home/peff/local/git/current/share/perl
    /home/peff/local/share/perl/5.28.0
    /home/peff/local/share/perl
    /home/peff/local/lib/perl5/site_perl
    /home/peff/local/lib/perl/5.28.0
    /home/peff/local/lib/perl
    /home/peff/local/lib
    /etc/perl
    /usr/local/lib/x86_64-linux-gnu/perl/5.28.0
    /usr/local/share/perl/5.28.0
    /usr/lib/x86_64-linux-gnu/perl5/5.28
    /usr/share/perl5
    /usr/lib/x86_64-linux-gnu/perl/5.28
    /usr/share/perl/5.28
    /usr/local/lib/site_perl
    /usr/lib/x86_64-linux-gnu/perl-base


Environment for perl 5.28.0:
    HOME=/home/peff
    LANG=en_US.UTF-8
    LANGUAGE (unset)
    LC_COLLATE=C
    LD_LIBRARY_PATH=
    LOGDIR (unset)
    PATH=/home/peff/.bin:/home/peff/local/bin:/home/peff/local/git/current/bin:/usr/local/bin:/usr/bin:/bin:/usr/games:/home/peff/compile/node/node-v8.9.3-linux-x64/bin:/usr/local/sbin:/sbin:/usr/sbin:/home/peff/compile/gh/shell/bin:/home/peff/work/mmake/bin:/home/peff/.rvm/bin
    PERL5LIB=/home/peff/local/git/current/share/perl:/home/peff/local/share/perl:/home/peff/local/lib/perl5/site_perl:/home/peff/local/lib/perl:/home/peff/local/lib
    PERL_BADLANG (unset)
    SHELL=/bin/bash

@p5pRT
Copy link
Author

p5pRT commented Nov 19, 2018

From @jkeenan

On Mon, 19 Nov 2018 20​:23​:24 GMT, peff@​peff.net wrote​:

This is a bug report for perl from peff@​peff.net,
generated with the help of perlbug 1.41 running under perl 5.28.0.

-----------------------------------------------------------------
[Please describe your issue here]

In perl 5.26.0 and earlier, using "-i" would modify the file even if
you
left a "-p" loop early. E.g.​:

$ echo foo >file
$ perl -i -pe 'last' file
$ cat file
[no output; we left the loop before printing anything]

But in 5.28.0, the file is left untouched​:

$ cat file
foo

This bisects in the perl-git mirror to e0d4aea ((perl #127663)
safer
in-place editing, 2017-01-11), and reproduces even on the current tip
of
that mirror's master branch.

The above code is obviously a toy example to reproduce the issue. If
you
want a more real-world case, the script I noticed this in was printing
the first non-comment line in a file​:

perl -i -ne 'print && exit 0 if /^[^#]/' $file

This seems very similar to another recent report​:

https://rt-archive.perl.org/perl5/Ticket/Display.html?id=133659

TonyC, p5p list​: Could you take a look at both?

Thank you very much.

--
James E Keenan (jkeenan@​cpan.org)

@p5pRT
Copy link
Author

p5pRT commented Nov 19, 2018

The RT System itself - Status changed from 'new' to 'open'

@p5pRT
Copy link
Author

p5pRT commented Nov 20, 2018

From @tonycoz

On Mon, 19 Nov 2018 12​:23​:24 -0800, peff@​peff.net wrote​:

In perl 5.26.0 and earlier, using "-i" would modify the file even if
you
left a "-p" loop early. E.g.​:

$ echo foo >file
$ perl -i -pe 'last' file
$ cat file
[no output; we left the loop before printing anything]

But in 5.28.0, the file is left untouched​:

$ cat file
foo

This bisects in the perl-git mirror to e0d4aea ((perl #127663)
safer
in-place editing, 2017-01-11), and reproduces even on the current tip
of
that mirror's master branch.

The above code is obviously a toy example to reproduce the issue. If
you
want a more real-world case, the script I noticed this in was printing
the first non-comment line in a file​:

perl -i -ne 'print && exit 0 if /^[^#]/' $file

This is the same as 133659, merging.

Tony

@p5pRT
Copy link
Author

p5pRT commented Nov 20, 2018

From @tonycoz

On Fri, 16 Nov 2018 02​:44​:10 -0800, ppisar wrote​:

On 2018-11-15, "Tony Cook via RT" <perlbug-followup@​perl.org> wrote​:

It's not the while() in particular that's special, but calling <>
again to iterate to the next file (or the end of the list.)

I hadn't considered the non-looping in-place editing (and none of the
tests do it that I'm aware of), but I was trying to get reasonable
behaviour for​:

perl -i -pe 's/FAILED/OK/ or die' somefile

Should the file be replaced if the code dies?

In my opinion, the file should be kept intact if the interpreter is
going to terminate because of an error (die, exit 1, an I/O failure).
That's the point of
<https://rt.perl.org/Public/Bug/Display.html?id=57512#txn-673862>
(still
not fully resolved).

However, I can image that a multiple file edit cannot have a correct
behavior​:

$ perl -i -pe 's/FAILED/OK/ or die' somefile anotherfile

because if somefile edits and replaces successfully but editing
anotherfile fails, perl as a whole command will return an error exit
code but somefile will have been already mangled. (I know perl is not
a transactional database system.) We would have to postpone the file
rename after processing all arguments and that could exhaust open file
descriptors and disk space. I don't think it's feasible to take the
multiple file usecase seriously.

I don't know a way to detect in the magic that does the clean up
whether we're cleaning up due to a die or falling off the end of the
code as in your case.

Can we decide on $@​ value? Or better on some flag that instructs perl
process to return a non-zero exit code?

$@​ isn't useful here, it may have been set by a previous eval.

Perhaps​:

- if we're in global destruction, and PL_statusvalue ($?) is zero, treat this as a successful in-place edit (replace the original file with the work file)

This would mean all of​:

  perl -i -pe 's/FAILED/OK/ or die' somefile
  perl -i -pe 's/FAILED/OK/ or exit 1' somefile

*wouldn't* replace the file, but all of​:

  perl -i -ne 'last' somefile
  perl -i -ne 'exit' somefile

*would* replace the file.

Unfortunately non-trivial code that uses in-place editing will still have problems​:

  sub foo {
  local (*ARGV, *ARGVOUT);
  @​ARGV = @​_;
  my $d = do { local $/; <> };
  $d =~ s/FAILED/OK/;
  print $d;
  die;
  }

  eval { foo("somefile") };

at the point where ARGVOUT is cleaned up we aren't in global destruction, so the file isn't replaced.

Tony

@p5pRT
Copy link
Author

p5pRT commented Nov 22, 2018

From @tonycoz

On Mon, 19 Nov 2018 16​:31​:12 -0800, tonyc wrote​:

Unfortunately non-trivial code that uses in-place editing will still
have problems​:

sub foo {
local (*ARGV, *ARGVOUT);
@​ARGV = @​_;
my $d = do { local $/; <> };
$d =~ s/FAILED/OK/;
print $d;
die;
}

eval { foo("somefile") };

at the point where ARGVOUT is cleaned up we aren't in global
destruction, so the file isn't replaced.

Oops, the input file *is* replaced.

The attached does the simple version of the check, but doesn't handle the more complex case.

Tony

@p5pRT
Copy link
Author

p5pRT commented Nov 22, 2018

From @tonycoz

0001-perl-133659-tests-for-global-destruction-handling-of.patch
From bfcb1def3fc594025a4a38c4247f1c85e815b3fa Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Tue, 20 Nov 2018 16:43:43 +1100
Subject: (perl #133659) tests for global destruction handling of inplace
 editing

---
 t/io/inplace.t | 28 +++++++++++++++++++++++++++-
 1 file changed, 27 insertions(+), 1 deletion(-)

diff --git a/t/io/inplace.t b/t/io/inplace.t
index 98159e06bf..ac50f1ab77 100644
--- a/t/io/inplace.t
+++ b/t/io/inplace.t
@@ -5,7 +5,7 @@ require './test.pl';
 
 $^I = $^O eq 'VMS' ? '_bak' : '.bak';
 
-plan( tests => 6 );
+plan( tests => 8 );
 
 my @tfiles     = (tempfile(), tempfile(), tempfile());
 my @tfiles_bak = map "$_$^I", @tfiles;
@@ -91,3 +91,29 @@ SKIP:
     
     END { unlink_all(@ifiles); }
 }
+
+{
+    my @tests =
+      ( # opts, code, result, name, $TODO
+       [ "-n", "die", "bar\n", "die shouldn't touch file" ],
+       [ "-n", "last", "", "last should update file", "not implemented yet" ],
+      );
+    our $file = tempfile() ;
+
+    for my $test (@tests) {
+        (my ($opts, $code, $result, $name), our $TODO) = @$test;
+        open my $fh, ">", $file or die;
+        print $fh "bar\n";
+        close $fh;
+
+        runperl( prog => $code,
+                 switches => [ grep length, "-i", $opts ],
+                 args => [ $file ],
+                 stderr => 1, # discarded
+               );
+        open $fh, "<", $file or die;
+        my $data = do { local $/; <$fh>; };
+        close $fh;
+        is($data, $result, $name);
+    }
+}
-- 
2.11.0

@p5pRT
Copy link
Author

p5pRT commented Nov 22, 2018

From @tonycoz

0002-perl-133659-make-an-in-place-edit-successful-if-the-.patch
From 969988ae104a4f4bd7f6ce7028a2b94e6deb9eb4 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 21 Nov 2018 10:05:27 +1100
Subject: (perl #133659) make an in-place edit successful if the exit status is
 zero

during global destruction.

This means that code like:

  perl -i -ne '...; last'

will replace the input file with the in-place edit output of the file,
but:

  perl -i -ne '...; die'

or

  perl -i -ne '...; exit 1'

won't.
---
 doio.c           | 45 +++++++++++++++++++++++++--------------------
 t/io/inplace.t   |  2 +-
 t/run/switches.t |  4 ++--
 3 files changed, 28 insertions(+), 23 deletions(-)

diff --git a/doio.c b/doio.c
index 77421de1d1..9fe222e082 100644
--- a/doio.c
+++ b/doio.c
@@ -1173,34 +1173,39 @@ S_argvout_free(pTHX_ SV *io, MAGIC *mg) {
         dir = INT2PTR(DIR *, SvIV(*dir_psv));
 #endif
         if (IoIFP(io)) {
-            SV **pid_psv;
-            PerlIO *iop = IoIFP(io);
+            if (PL_phase == PERL_PHASE_DESTRUCT && PL_statusvalue == 0) {
+                (void)argvout_final(mg, (IO*)io, FALSE);
+            }
+            else {
+                SV **pid_psv;
+                PerlIO *iop = IoIFP(io);
 
-            assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
+                assert(SvTYPE(mg->mg_obj) == SVt_PVAV);
 
-            pid_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE);
+                pid_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_ORIG_PID, FALSE);
 
-            assert(pid_psv && *pid_psv);
+                assert(pid_psv && *pid_psv);
 
-            if (SvIV(*pid_psv) == (IV)PerlProc_getpid()) {
-                /* if we get here the file hasn't been closed explicitly by the
-                   user and hadn't been closed implicitly by nextargv(), so
-                   abandon the edit */
-                SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
-                const char *temp_pv = SvPVX(*temp_psv);
+                if (SvIV(*pid_psv) == (IV)PerlProc_getpid()) {
+                    /* if we get here the file hasn't been closed explicitly by the
+                       user and hadn't been closed implicitly by nextargv(), so
+                       abandon the edit */
+                    SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
+                    const char *temp_pv = SvPVX(*temp_psv);
 
-                assert(temp_psv && *temp_psv && SvPOK(*temp_psv));
-                (void)PerlIO_close(iop);
-                IoIFP(io) = IoOFP(io) = NULL;
+                    assert(temp_psv && *temp_psv && SvPOK(*temp_psv));
+                    (void)PerlIO_close(iop);
+                    IoIFP(io) = IoOFP(io) = NULL;
 #ifdef ARGV_USE_ATFUNCTIONS
-                if (dir) {
-                    if (unlinkat(my_dirfd(dir), temp_pv, 0) < 0 &&
-                        NotSupported(errno))
-                        (void)UNLINK(temp_pv);
-                }
+                    if (dir) {
+                        if (unlinkat(my_dirfd(dir), temp_pv, 0) < 0 &&
+                            NotSupported(errno))
+                            (void)UNLINK(temp_pv);
+                    }
 #else
-                (void)UNLINK(temp_pv);
+                    (void)UNLINK(temp_pv);
 #endif
+                }
             }
         }
 #ifdef ARGV_USE_ATFUNCTIONS
diff --git a/t/io/inplace.t b/t/io/inplace.t
index ac50f1ab77..0403cd9250 100644
--- a/t/io/inplace.t
+++ b/t/io/inplace.t
@@ -96,7 +96,7 @@ SKIP:
     my @tests =
       ( # opts, code, result, name, $TODO
        [ "-n", "die", "bar\n", "die shouldn't touch file" ],
-       [ "-n", "last", "", "last should update file", "not implemented yet" ],
+       [ "-n", "last", "", "last should update file" ],
       );
     our $file = tempfile() ;
 
diff --git a/t/run/switches.t b/t/run/switches.t
index 7ccef1e063..594cad6e7f 100644
--- a/t/run/switches.t
+++ b/t/run/switches.t
@@ -429,7 +429,7 @@ __EOF__
 
     # exit or die should leave original content in file
     for my $inplace (qw/-i -i.bak/) {
-        for my $prog (qw/die exit/) {
+        for my $prog ("die", "exit 1") {
             open my $fh, ">", $work or die "$0: failed to open '$work': $!";
             print $fh $yada;
             close $fh or die "Failed to close: $!";
@@ -443,7 +443,7 @@ __EOF__
             my $data = do { local $/; <$in> };
             close $in;
             is ($data, $yada, "check original content still in file");
-            unlink $work;
+            unlink $work, "$work.bak";
         }
     }
 
-- 
2.11.0

@p5pRT
Copy link
Author

p5pRT commented Nov 22, 2018

From @tonycoz

On Wed, 21 Nov 2018 19​:15​:41 -0800, tonyc wrote​:

The attached does the simple version of the check, but doesn't handle
the more complex case.

The attached is the first step towards a solution for the more complex case, but as the tests show it doesn't handle at least one of the more painful possible ways for die_unwinding() to be interrupted (though it tries.)

Tony

@p5pRT
Copy link
Author

p5pRT commented Nov 22, 2018

From @tonycoz

0003-DON-T-APPLY-THIS.patch
From 55904124aeff51e3a674769f21750ee51b1a3502 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Thu, 22 Nov 2018 14:11:16 +1100
Subject: DON'T APPLY THIS

Attempt at defining an interpreter variable that detects unwinding
from a die.

Unfortunately it doesn't work.
---
 MANIFEST                         |  1 +
 embedvar.h                       |  1 +
 ext/XS-APItest/APItest.pm        |  2 +-
 ext/XS-APItest/APItest.xs        |  5 +++
 ext/XS-APItest/t/die_unwinding.t | 75 ++++++++++++++++++++++++++++++++++++++++
 intrpvar.h                       |  2 ++
 pp_ctl.c                         | 30 ++++++++++++++++
 sv.c                             |  1 +
 8 files changed, 116 insertions(+), 1 deletion(-)
 create mode 100644 ext/XS-APItest/t/die_unwinding.t

diff --git a/MANIFEST b/MANIFEST
index 006267323a..5adc1ec8db 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4276,6 +4276,7 @@ ext/XS-APItest/t/cv_name.t	test cv_name
 ext/XS-APItest/t/eval-filter.t	Simple source filter/eval test
 ext/XS-APItest/t/exception.t	XS::APItest extension
 ext/XS-APItest/t/extend.t	test EXTEND() macro
+ext/XS-APItest/t/die_unwinding.t	Test PL_die_unwinding
 ext/XS-APItest/t/fetch_pad_names.t	Tests for UTF8 names in pad
 ext/XS-APItest/t/get.t		test get_sv et al.
 ext/XS-APItest/t/gotosub.t	XS::APItest: tests goto &xsub and hints
diff --git a/embedvar.h b/embedvar.h
index 5bd4a4ea9e..022425be64 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -119,6 +119,7 @@
 #define PL_delaymagic_gid	(vTHX->Idelaymagic_gid)
 #define PL_delaymagic_uid	(vTHX->Idelaymagic_uid)
 #define PL_destroyhook		(vTHX->Idestroyhook)
+#define PL_die_unwinding	(vTHX->Idie_unwinding)
 #define PL_diehook		(vTHX->Idiehook)
 #define PL_doswitches		(vTHX->Idoswitches)
 #define PL_dowarn		(vTHX->Idowarn)
diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
index 61531fc97a..12d331b246 100644
--- a/ext/XS-APItest/APItest.pm
+++ b/ext/XS-APItest/APItest.pm
@@ -5,7 +5,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '0.99';
+our $VERSION = '1.99';
 
 require XSLoader;
 
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index a30659f14f..5a86773184 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -1345,6 +1345,8 @@ my_ck_rv2cv(pTHX_ OP *o)
     return old_ck_rv2cv(aTHX_ o);
 }
 
+#define die_unwinding() (PL_die_unwinding)
+
 #include "const-c.inc"
 
 MODULE = XS::APItest		PACKAGE = XS::APItest
@@ -1600,6 +1602,9 @@ tryAMAGICunDEREF_var(sv, what)
 	/* The reference is owned by something else.  */
 	PUSHs(sv);
 
+IV
+die_unwinding()
+
 MODULE = XS::APItest		PACKAGE = XS::APItest::XSUB
 
 BOOT:
diff --git a/ext/XS-APItest/t/die_unwinding.t b/ext/XS-APItest/t/die_unwinding.t
new file mode 100644
index 0000000000..5be18a312b
--- /dev/null
+++ b/ext/XS-APItest/t/die_unwinding.t
@@ -0,0 +1,75 @@
+#!perl
+use Test::More;
+use XS::APItest qw(die_unwinding);
+
+is(die_unwinding(), 0, "start zero");
+
+{
+    my $x = Foo->new(0, "should be zero on normal destruction");
+}
+
+{
+    eval {
+        my $x = Foo->new(1, "should be non-zero on die in eval");
+        die;
+    };
+}
+{
+    eval {
+        my $x = Foo->new(0, "should be zero on normal exit in eval");
+    };
+}
+
+{
+    eval {
+        my $y = Foo->new(1, "should be non-zero before");
+        our $x;
+        tie $x, 'TieDie';
+        local $x = 0;
+        my $z = Foo->new(1, "should be non-zero after");
+    };
+}
+
+is(die_unwinding(), 0, "finish zero");
+
+done_testing();
+
+package Foo;
+use Test::More;
+use XS::APItest qw(die_unwinding);
+
+sub new {
+    my ($class, $expect, $name) = @_;
+
+    bless [ $expect, $name ], $class;
+}
+
+sub DESTROY {
+    my ($expect, $name) = @{$_[0]};
+
+    if ($expect) {
+        isnt(die_unwinding(), 0, $name);
+    }
+    else {
+        is(die_unwinding(), 0, $name);
+    }
+}
+
+package TieDie;
+use parent 'Tie::Scalar';
+
+sub TIESCALAR {
+    my ($class) = @_;
+
+    bless \(my $x = 1), $class;
+}
+
+sub FETCH {
+    ${$_[0]};
+}
+
+sub STORE {
+    my ($self, $val) = @_;
+
+    die if $val;
+}
diff --git a/intrpvar.h b/intrpvar.h
index fad1eaafbb..23dd8a608b 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -817,6 +817,8 @@ PERLVARI(I, dump_re_max_len, STRLEN, 60)
 
 PERLVAR(I, internal_random_state, PL_RANDOM_STATE_TYPE)
 
+PERLVARI(I, die_unwinding, IV, 0);
+
 /* If you are adding a U8 or U16, check to see if there are 'Space' comments
  * above on where there are gaps which currently will be structure padding.  */
 
diff --git a/pp_ctl.c b/pp_ctl.c
index 17d4f0d14a..261a2b4f2a 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1614,6 +1614,27 @@ Perl_qerror(pTHX_ SV *err)
 	++PL_parser->error_count;
 }
 
+static int
+S_die_unwinding_free(pTHX_ SV *sv, MAGIC *mg) {
+    PERL_UNUSED_ARG(sv);
+    PERL_UNUSED_ARG(mg);
+
+    --PL_die_unwinding;
+    return 0;
+}
+
+static const MGVTBL die_unwinding_vtbl =
+    {
+        NULL, /* svt_get */
+        NULL, /* svt_set */
+        NULL, /* svt_len */
+        NULL, /* svt_clear */
+        S_die_unwinding_free, /* svt_free */
+        NULL, /* svt_copy */
+        NULL,  /* svt_dup */
+        NULL /* svt_local */
+    };
+
 
 
 /* pop a CXt_EVAL context and in addition, if it was a require then
@@ -1629,6 +1650,12 @@ S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
     SV  *namesv = NULL; /* init to avoid dumb compiler warning */
     bool do_croak;
 
+    DEBUG_U( PerlIO_printf(PerlIO_stderr(), "action %d old op %d unwinding %d\n",
+                           action, CxOLD_OP_TYPE(cx), (int)PL_die_unwinding); );
+    if (action) {
+        ++PL_die_unwinding;
+        sv_magicext(errsv, NULL, PERL_MAGIC_uvar, &die_unwinding_vtbl, NULL, 0);
+    }
     CX_LEAVE_SCOPE(cx);
     do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
     if (do_croak) {
@@ -1728,6 +1755,9 @@ Perl_die_unwind(pTHX_ SV *msv)
 			   SVfARG(exceptsv));
 	}
 
+        ++PL_die_unwinding;
+        sv_magicext(exceptsv, NULL, PERL_MAGIC_uvar, &die_unwinding_vtbl, NULL, 0);
+
 	while ((cxix = dopoptoeval(cxstack_ix)) < 0
 	       && PL_curstackinfo->si_prev)
 	{
diff --git a/sv.c b/sv.c
index 983646f335..5c3ddbaebe 100644
--- a/sv.c
+++ b/sv.c
@@ -15327,6 +15327,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_delaymagic	= proto_perl->Idelaymagic;
     PL_phase		= proto_perl->Iphase;
     PL_localizing	= proto_perl->Ilocalizing;
+    PL_die_unwinding    = proto_perl->Idie_unwinding;
 
     PL_hv_fetch_ent_mh	= NULL;
     PL_modcount		= proto_perl->Imodcount;
-- 
2.11.0

@p5pRT
Copy link
Author

p5pRT commented Nov 22, 2018

From @ppisar

On 2018-11-22, "Tony Cook via RT" <perlbug-followup@​perl.org> wrote​:

The attached does the simple version of the check, but doesn't handle the more complex case.

[...]

From 969988a Mon Sep 17 00​:00​:00 2001
From​: Tony Cook <tony@​develop-help.com>
Date​: Wed, 21 Nov 2018 10​:05​:27 +1100
Subject​: (perl #133659) make an in-place edit successful if the exit status is
zero

during global destruction.

This means that code like​:

perl -i -ne '...; last'

will replace the input file with the in-place edit output of the file,
but​:

perl -i -ne '...; die'

or

perl -i -ne '...; exit 1'

won't.
---
doio.c | 45 +++++++++++++++++++++++++--------------------
t/io/inplace.t | 2 +-
t/run/switches.t | 4 ++--
3 files changed, 28 insertions(+), 23 deletions(-)

diff --git a/doio.c b/doio.c
index 77421de1d1..9fe222e082 100644
--- a/doio.c
+++ b/doio.c
@​@​ -1173,34 +1173,39 @​@​ S_argvout_free(pTHX_ SV *io, MAGIC *mg) {
dir = INT2PTR(DIR *, SvIV(*dir_psv));
#endif
if (IoIFP(io)) {
- SV **pid_psv;
- PerlIO *iop = IoIFP(io);
+ if (PL_phase == PERL_PHASE_DESTRUCT && PL_statusvalue == 0) {
+ (void)argvout_final(mg, (IO*)io, FALSE);

Thank you for the patches, but this code calls argvout_final() that does not
exist anywhere in the Perl sources. Maybe you forgot to add the new function
to the patch?

-- Petr

@p5pRT
Copy link
Author

p5pRT commented Nov 22, 2018

From @tonycoz

On Thu, Nov 22, 2018 at 08​:21​:10AM -0000, Petr Pisar wrote​:

Thank you for the patches, but this code calls argvout_final() that does not
exist anywhere in the Perl sources. Maybe you forgot to add the new function
to the patch?

Oops, no, I missed including a patch.

Attached.

This belongs before the other two.

Tony

@p5pRT
Copy link
Author

p5pRT commented Nov 22, 2018

From @tonycoz

0001-perl-133659-move-argvout-cleanup-to-a-new-function.patch
From a5665f6892b6ac67d291465265ed2eeee887d7ea Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Tue, 20 Nov 2018 15:30:20 +1100
Subject: (perl #133659) move argvout cleanup to a new function

---
 doio.c    | 62 ++++++++++++++++++++++++++++++++++++++------------------------
 embed.fnc |  1 +
 embed.h   |  1 +
 proto.h   |  3 +++
 4 files changed, 43 insertions(+), 24 deletions(-)

diff --git a/doio.c b/doio.c
index 8d9131cc85..77421de1d1 100644
--- a/doio.c
+++ b/doio.c
@@ -1526,31 +1526,14 @@ S_dir_unchanged(pTHX_ const char *orig_pv, MAGIC *mg) {
 #define dir_unchanged(orig_psv, mg) \
     S_dir_unchanged(aTHX_ (orig_psv), (mg))
 
-/* explicit renamed to avoid C++ conflict    -- kja */
-bool
-Perl_do_close(pTHX_ GV *gv, bool not_implicit)
-{
+STATIC bool
+S_argvout_final(pTHX_ MAGIC *mg, IO *io, bool not_implicit) {
     bool retval;
-    IO *io;
-    MAGIC *mg;
 
-    if (!gv)
-	gv = PL_argvgv;
-    if (!gv || !isGV_with_GP(gv)) {
-	if (not_implicit)
-	    SETERRNO(EBADF,SS_IVCHAN);
-	return FALSE;
-    }
-    io = GvIO(gv);
-    if (!io) {		/* never opened */
-	if (not_implicit) {
-	    report_evil_fh(gv);
-	    SETERRNO(EBADF,SS_IVCHAN);
-	}
-	return FALSE;
-    }
-    if ((mg = mg_findext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl))
-        && mg->mg_obj) {
+    /* ensure args are checked before we start using them */
+    PERL_ARGS_ASSERT_ARGVOUT_FINAL;
+
+    {
         /* handle to an in-place edit work file */
         SV **back_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_BACKUP_NAME, FALSE);
         SV **temp_psv = av_fetch((AV*)mg->mg_obj, ARGVMG_TEMP_NAME, FALSE);
@@ -1717,7 +1700,38 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit)
                            SvPVX(*temp_psv), Strerror(errno));
             }
         }
-    freext:
+ freext:
+        ;
+    }
+    return retval;
+}
+
+/* explicit renamed to avoid C++ conflict    -- kja */
+bool
+Perl_do_close(pTHX_ GV *gv, bool not_implicit)
+{
+    bool retval;
+    IO *io;
+    MAGIC *mg;
+
+    if (!gv)
+	gv = PL_argvgv;
+    if (!gv || !isGV_with_GP(gv)) {
+	if (not_implicit)
+	    SETERRNO(EBADF,SS_IVCHAN);
+	return FALSE;
+    }
+    io = GvIO(gv);
+    if (!io) {		/* never opened */
+	if (not_implicit) {
+	    report_evil_fh(gv);
+	    SETERRNO(EBADF,SS_IVCHAN);
+	}
+	return FALSE;
+    }
+    if ((mg = mg_findext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl))
+        && mg->mg_obj) {
+        retval = argvout_final(mg, io, not_implicit);
         mg_freeext((SV*)io, PERL_MAGIC_uvar, &argvout_vtbl);
     }
     else {
diff --git a/embed.fnc b/embed.fnc
index 2ed2cc32b9..408917e0a7 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -440,6 +440,7 @@ p	|bool|do_exec3	|NN const char *incmd|int fd|int do_report
 #endif
 #if defined(PERL_IN_DOIO_C)
 s	|void	|exec_failed	|NN const char *cmd|int fd|int do_report
+s	|bool	|argvout_final	|NN MAGIC *mg|NN IO *io|bool not_implicit
 #endif
 #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
 : Defined in doio.c, used only in pp_sys.c
diff --git a/embed.h b/embed.h
index 4cc97126bd..ffa5b1d581 100644
--- a/embed.h
+++ b/embed.h
@@ -1755,6 +1755,7 @@
 #define deb_stack_n(a,b,c,d,e)	S_deb_stack_n(aTHX_ a,b,c,d,e)
 #  endif
 #  if defined(PERL_IN_DOIO_C)
+#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 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)
diff --git a/proto.h b/proto.h
index e57df2f206..061a9d72a0 100644
--- a/proto.h
+++ b/proto.h
@@ -4752,6 +4752,9 @@ STATIC void	S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max, I
 	assert(stack_base)
 #endif
 #if defined(PERL_IN_DOIO_C)
+STATIC bool	S_argvout_final(pTHX_ MAGIC *mg, IO *io, bool not_implicit);
+#define PERL_ARGS_ASSERT_ARGVOUT_FINAL	\
+	assert(mg); assert(io)
 STATIC void	S_exec_failed(pTHX_ const char *cmd, int fd, int do_report);
 #define PERL_ARGS_ASSERT_EXEC_FAILED	\
 	assert(cmd)
-- 
2.11.0

@p5pRT
Copy link
Author

p5pRT commented Nov 22, 2018

From @ppisar

On 2018-11-22, Tony Cook <tony@​develop-help.com> wrote​:

--q7ufeuufo5kv7m4x
Content-Type​: text/plain; charset=us-ascii
Content-Disposition​: inline

On Thu, Nov 22, 2018 at 08​:21​:10AM -0000, Petr Pisar wrote​:

Thank you for the patches, but this code calls argvout_final() that does not
exist anywhere in the Perl sources. Maybe you forgot to add the new function
to the patch?

Oops, no, I missed including a patch.

Attached.

This belongs before the other two.

That helped. I confirm that the tree patches​:

(perl #133659) tests for global destruction handling of inplace editing
(perl #133659) move argvout cleanup to a new function
(perl #133659) make an in-place edit successful if the exit status is zero

fix the trivial edit and that all Perl tests pass.

-- Petr

@p5pRT
Copy link
Author

p5pRT commented Nov 22, 2018

From @jkeenan

The original poster, Domibay - Hugo <hugo@​domibay.org>, posted 3
additional comments which made it to RT but which we're not cc-ed to
perl5-porters, so I'm including them here. --jkeenan

#1

Hi,

Thank you for taking the time to look into this case.

I executed your code and it worked fine at first.
But then I found that the Method "Family​::extendedMethod" was missing a
feature where it would execute the "Family​::baseMethod"

package Family;
sub extendedMethod {
  my $self = $_[0];

  $self->baseMethod;
  print "We extend a hearty greeting\n";
}

So the expected output would be​:

We basically say Hello World
We extend a hearty greeting

To illustrate the intended functionality of the derived "Family​::Child"
Package
I add this code to "Family​::Child​::baseMethod"

package Family​::Child;
sub baseMethod {
  my $self = $_[0];
  $self->extendedMethod();
  print "and the Child chuckles.\n";
}

so the intented functionality should display this output​:

We basically say Hello World
We extend a hearty greeting
and the Child chuckles.

I found there is no way to achieve this in a streamlined development
without changing the Parent "Family" Package or overriding the
"Family​::extendedMethod" Method with a copy and paste of its code.

You can find more information about Object-oriented Design Patterns at
https://en.wikipedia.org/wiki/Inheritance_(object-oriented_programming)#Visibility_of_inherited_members
https://en.wikipedia.org/wiki/Law_of_Demeter#In_object-oriented_programming

Please, have also a look on this Talk about "Upcasting" and "Downcasting"
http​://www.cs.utexas.edu/~cannata/cs345/Class%20Notes/14%20Java%20Upcasting%20Downcasting.htm

As referring to additional Documentation about expected behaviour
I point also to "Coercions"
https://en.wikipedia.org/wiki/Subtyping#Coercions
https://en.wikibooks.org/wiki/Computer_Programming/Type_conversion#Implicit_type_conversion

As the author of the Package "Family" would expect that any object
passed to a Method of "Family" would be coerced into an object of
"Family" to guarantee the coherence of the "Family" Class functionality.

# 2

package Family;
sub extendedMethod {
my $self = $_[0];

$self->baseMethod;
print "We extend a hearty greeting\n";
}

So after adding the "Family​::baseMethod" feature to the Method
"Family​::extendedMethod"
on executing I got the warning​:

Deep recursion on subroutine "Family​::Child​::baseMethod" at Family.pm
line 18.
Deep recursion on subroutine "Family​::extendedMethod" at Family.pm line 29.

And my computer blocked with high workload until finally I was able to
kill the Process.

Certainly the Perl Engine found the code in "Family​::extendedMethod"

$self->baseMethod;

and understood "$self" as "Family​::Child" and started to execute
"Family​::Child​::baseMethod" without taking into consideration that
"$self" in "Family​::extendedMethod" stands in the context of "Family"
and is expected to execute "Family​::baseMethod".

# 3

As the author of the Package "Family" would expect that any object
passed to a Method of "Family" would be coerced into an object of
"Family" to guarantee the coherence of the "Family" Class
functionality.

This affects especially Packages published for third parties by authors
on CPAN perhaps which are meant to be derived.

And it limits the Polymorphism Capability of all derived Classes since
authors of derived "Family​::Child" and "Family​::Child​::Grandchild"
Classes must be aware of the "Family" inner implementation to avoid
fatal collisions.

@p5pRT
Copy link
Author

p5pRT commented Nov 22, 2018

From @jkeenan

Please ignore the previous post in #133659 (5.28.0 regression​: In-place edit without .... It was posted to the wrong thread.

@p5pRT
Copy link
Author

p5pRT commented Nov 26, 2018

From @tonycoz

On Thu, 22 Nov 2018 03​:26​:07 -0800, ppisar wrote​:

On 2018-11-22, Tony Cook <tony@​develop-help.com> wrote​:

--q7ufeuufo5kv7m4x
Content-Type​: text/plain; charset=us-ascii
Content-Disposition​: inline

On Thu, Nov 22, 2018 at 08​:21​:10AM -0000, Petr Pisar wrote​:

Thank you for the patches, but this code calls argvout_final() that
does not
exist anywhere in the Perl sources. Maybe you forgot to add the new
function
to the patch?

Oops, no, I missed including a patch.

Attached.

This belongs before the other two.

That helped. I confirm that the tree patches​:

(perl #133659) tests for global destruction handling of inplace
editing
(perl #133659) move argvout cleanup to a new function
(perl #133659) make an in-place edit successful if the exit status is
zero

fix the trivial edit and that all Perl tests pass.

Applied as 404395d, 640e129 and 85d2f7c.

Leaving this open as the more general issue isn't solved.

Tony

@p5pRT
Copy link
Author

p5pRT commented Nov 26, 2018

From @jmdh

On Sun, 25 Nov 2018 19​:23​:34 -0800, tonyc wrote​:

On Thu, 22 Nov 2018 03​:26​:07 -0800, ppisar wrote​:

On 2018-11-22, Tony Cook <tony@​develop-help.com> wrote​:

--q7ufeuufo5kv7m4x
Content-Type​: text/plain; charset=us-ascii
Content-Disposition​: inline

On Thu, Nov 22, 2018 at 08​:21​:10AM -0000, Petr Pisar wrote​:

Thank you for the patches, but this code calls argvout_final()
that
does not
exist anywhere in the Perl sources. Maybe you forgot to add the
new
function
to the patch?

Oops, no, I missed including a patch.

Attached.

This belongs before the other two.

That helped. I confirm that the tree patches​:

(perl #133659) tests for global destruction handling of inplace
editing
(perl #133659) move argvout cleanup to a new function
(perl #133659) make an in-place edit successful if the exit status is
zero

fix the trivial edit and that all Perl tests pass.

Applied as 404395d,
640e129 and
85d2f7c.

Leaving this open as the more general issue isn't solved.

Tony

Thanks. FTR, this was also reported in Debian as
<https://bugs.debian.org/914651>

I think this should be proposed for a stable release since it's a regression (even if the whole issue isn't fixed, the use case reported by the OP is). So maybe that is a reason to split the more general issue into a new ticket and mark this one as blocking 5.28.x? Or do you think that it would be harmful/confusing to apply just the partial fix?

(My motivation for asking the question​: I'd like to fix the simple case in Debian since it is affecting our users).

Cheers,
Dominic.

@p5pRT
Copy link
Author

p5pRT commented Dec 3, 2018

From @tonycoz

On Mon, 26 Nov 2018 04​:54​:56 -0800, dom wrote​:

I think this should be proposed for a stable release since it's a
regression (even if the whole issue isn't fixed, the use case reported
by the OP is). So maybe that is a reason to split the more general
issue into a new ticket and mark this one as blocking 5.28.x? Or do
you think that it would be harmful/confusing to apply just the partial
fix?

I've split the unfixed behaviour into

https://rt-archive.perl.org/perl5/Ticket/Display.html?id=133709

I've proposed the changes for backporting in​:

https://perl5.git.perl.org/perl.git/commit/39fda5e8d93f00ab7ec77a2f35074c0aceb28c1e

and marking this as resolved.

Tony

@p5pRT
Copy link
Author

p5pRT commented Dec 3, 2018

@tonycoz - Status changed from 'open' to 'pending release'

@p5pRT
Copy link
Author

p5pRT commented Dec 7, 2018

From @jmdh

On Mon, 03 Dec 2018 15​:09​:22 -0800, tonyc wrote​:

On Mon, 26 Nov 2018 04​:54​:56 -0800, dom wrote​:

I think this should be proposed for a stable release since it's a
regression (even if the whole issue isn't fixed, the use case
reported
by the OP is). So maybe that is a reason to split the more general
issue into a new ticket and mark this one as blocking 5.28.x? Or do
you think that it would be harmful/confusing to apply just the
partial
fix?

I've split the unfixed behaviour into

https://rt-archive.perl.org/perl5/Ticket/Display.html?id=133709

I've proposed the changes for backporting in​:

https://perl5.git.perl.org/perl.git/commit/39fda5e8d93f00ab7ec77a2f35074c0aceb28c1e

and marking this as resolved.

Tony

Thanks! For the record, I have cherry-picked the three commits onto Debian's 5.28.1 which should be uploaded to unstable in the next few days.

@p5pRT
Copy link
Author

p5pRT commented Dec 7, 2018

From [Unknown Contact. See original ticket]

On Mon, 03 Dec 2018 15​:09​:22 -0800, tonyc wrote​:

On Mon, 26 Nov 2018 04​:54​:56 -0800, dom wrote​:

I think this should be proposed for a stable release since it's a
regression (even if the whole issue isn't fixed, the use case
reported
by the OP is). So maybe that is a reason to split the more general
issue into a new ticket and mark this one as blocking 5.28.x? Or do
you think that it would be harmful/confusing to apply just the
partial
fix?

I've split the unfixed behaviour into

https://rt-archive.perl.org/perl5/Ticket/Display.html?id=133709

I've proposed the changes for backporting in​:

https://perl5.git.perl.org/perl.git/commit/39fda5e8d93f00ab7ec77a2f35074c0aceb28c1e

and marking this as resolved.

Tony

Thanks! For the record, I have cherry-picked the three commits onto Debian's 5.28.1 which should be uploaded to unstable in the next few days.

@p5pRT
Copy link
Author

p5pRT commented Jan 9, 2019

From @steve-m-hay

On Fri, 07 Dec 2018 04​:57​:37 -0800, dom wrote​:

On Mon, 03 Dec 2018 15​:09​:22 -0800, tonyc wrote​:

On Mon, 26 Nov 2018 04​:54​:56 -0800, dom wrote​:

I think this should be proposed for a stable release since it's a
regression (even if the whole issue isn't fixed, the use case
reported
by the OP is). So maybe that is a reason to split the more general
issue into a new ticket and mark this one as blocking 5.28.x? Or do
you think that it would be harmful/confusing to apply just the
partial
fix?

I've split the unfixed behaviour into

https://rt-archive.perl.org/perl5/Ticket/Display.html?id=133709

I've proposed the changes for backporting in​:

https://perl5.git.perl.org/perl.git/commit/39fda5e8d93f00ab7ec77a2f35074c0aceb28c1e

and marking this as resolved.

Tony

Thanks! For the record, I have cherry-picked the three commits onto
Debian's 5.28.1 which should be uploaded to unstable in the next few
days.

Now cherry-picked into maint-5.28 for 5.28.1.

The original report at the top of this ticket noted that the POD needed updating too.

@p5pRT
Copy link
Author

p5pRT commented Jan 9, 2019

From @steve-m-hay

On Wed, 09 Jan 2019 10​:09​:16 -0800, shay wrote​:

On Fri, 07 Dec 2018 04​:57​:37 -0800, dom wrote​:

On Mon, 03 Dec 2018 15​:09​:22 -0800, tonyc wrote​:

On Mon, 26 Nov 2018 04​:54​:56 -0800, dom wrote​:

I think this should be proposed for a stable release since it's a
regression (even if the whole issue isn't fixed, the use case
reported
by the OP is). So maybe that is a reason to split the more
general
issue into a new ticket and mark this one as blocking 5.28.x? Or
do
you think that it would be harmful/confusing to apply just the
partial
fix?

I've split the unfixed behaviour into

https://rt-archive.perl.org/perl5/Ticket/Display.html?id=133709

I've proposed the changes for backporting in​:

https://perl5.git.perl.org/perl.git/commit/39fda5e8d93f00ab7ec77a2f35074c0aceb28c1e

and marking this as resolved.

Tony

Thanks! For the record, I have cherry-picked the three commits onto
Debian's 5.28.1 which should be uploaded to unstable in the next few
days.

Now cherry-picked into maint-5.28 for 5.28.1.

Oops! That should have been 5.28.2.

@p5pRT
Copy link
Author

p5pRT commented May 22, 2019

From @khwilliamson

Thank you for filing this report. You have helped make Perl better.

With the release today of Perl 5.30.0, this and 160 other issues have been
resolved.

Perl 5.30.0 may be downloaded via​:
https://metacpan.org/release/XSAWYERX/perl-5.30.0

If you find that the problem persists, feel free to reopen this ticket.

@p5pRT
Copy link
Author

p5pRT commented May 22, 2019

@khwilliamson - Status changed from 'pending release' to 'resolved'

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Labels
None yet
Projects
None yet
Development

No branches or pull requests

1 participant