refcnt: fd -1 < 0 with MIME::Lite

[p5pRT]

Migrated from rt.perl.org#122112 (status was 'pending release')

Searchable as RT122112$

[p5pRT]

From efimov@reg.ru

the following code

use strict;
use warnings;
{
  package MyFile;
  sub print {
  my $self = shift;
  print {$$self} @​_;
  }

}

$SIG{ALRM}=sub{die};
alarm 1;
my $pid = open FILE, "|-";
bless \*FILE, 'MyFile';
defined($pid) or die "open of pipe failed​: $!\n";
if ( !$pid ) { ### child
  exec("sleep", "3");
} else { ### parent
  print FILE "test\n123\n\121";
  close FILE || die;
}

dies with

====
Died at 55.pl line 12.
refcnt​: fd -1 < 0

same happening in MIME​::Lite if sendmail works too slow​:

===
use strict;
use warnings;
use MIME​::Lite;
$SIG{ALRM}=sub{die};
alarm 1;
my $mailer = bless( {
  'SubAttrs' => {
  'content-type' => {
  'charset' => 'windows-1251'
  }
  },
  'Parts' => [],
  'Attrs' => {
  'content-disposition' => 'inline',
  'content-type' => 'text/plain',
  'mime-version' => '1.0',
  'content-length' => undef,
  'content-transfer-encoding' => '8bit'
  },
  'Data' => 'zzzzz',
  'Header' => [
  ['x-mailer','MIME​::Lite 3.029 (F2.82;
T2.04; A2.12; B3.14; Q3.13)'],
  ['date','Mon, 16 Jun 2014 14​:15​:54 +0400'],
  ['from','test <noreply@​example.com>'],
  ['to','test@​example.com'],
  ['subject','test'],
  ['reply-to','test <noreply@​example.com>'],
  ['bcc','outbox']
  ]
  }, 'MIME​::Lite' );
$mailer->send('sendmail', 'sleep 3');

"refcnt​: fd -1 < 0" - seems a perl bug (an assertion in C code)

reproducible in 5.14, 5.18, 5.20

==========
Summary of my perl5 (revision 5 version 20 subversion 0) configuration​:

  Platform​:
  osname=linux, osvers=3.8.0-39-generic, archname=x86_64-linux-thread-multi-ld
  uname='linux green-u 3.8.0-39-generic #58~precise1-ubuntu smp fri
may 2 21​:33​:40 utc 2014 x86_64 x86_64 x86_64 gnulinux '
  config_args='-de
-Dprefix=/home/perlbrew/perls/perl-5.20.0-thread-multi-ld -Dusethreads
-Duselongdouble -Dusemultiplicity
-Aeval​:scriptdir=/home/perlbrew/perls/perl-5.20.0-thread-multi-ld/bin'
  hint=recommended, useposix=true, d_sigaction=define
  useithreads=define, usemultiplicity=define
  use64bitint=define, use64bitall=define, uselongdouble=define
  usemymalloc=n, bincompat5005=undef
  Compiler​:
  cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -fwrapv
-fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include
-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
  optimize='-O2',
  cppflags='-D_REENTRANT -D_GNU_SOURCE -fwrapv -fno-strict-aliasing
-pipe -fstack-protector -I/usr/local/include'
  ccversion='', gccversion='4.6.3', gccosandvers=''
  intsize=4, longsize=8, ptrsize=8, doublesize=8, byteorder=12345678
  d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16
  ivtype='long', ivsize=8, nvtype='long double', nvsize=16,
Off_t='off_t', lseeksize=8
  alignbytes=16, prototype=define
  Linker and Libraries​:
  ld='cc', ldflags =' -fstack-protector -L/usr/local/lib'
  libpth=/usr/local/lib
/usr/lib/gcc/x86_64-linux-gnu/4.6/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=-lnsl -lgdbm -ldl -lm -lcrypt -lutil -lpthread -lc -lgdbm_compat
  perllibs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc
  libc=, so=so, useshrplib=false, libperl=libperl.a
  gnulibc_version='2.15'
  Dynamic Linking​:
  dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
  cccdlflags='-fPIC', lddlflags='-shared -O2 -L/usr/local/lib
-fstack-protector'

Characteristics of this binary (from libperl)​:
  Compile-time options​: HAS_TIMES MULTIPLICITY PERLIO_LAYERS
  PERL_DONT_CREATE_GVSV
  PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
  PERL_IMPLICIT_CONTEXT PERL_MALLOC_WRAP
  PERL_NEW_COPY_ON_WRITE PERL_PRESERVE_IVUV
  USE_64_BIT_ALL USE_64_BIT_INT USE_ITHREADS
  USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE
  USE_LOCALE_CTYPE USE_LOCALE_NUMERIC USE_LONG_DOUBLE
  USE_PERLIO USE_PERL_ATOF USE_REENTRANT_API
  Built under linux
  Compiled at May 30 2014 06​:30​:13
  %ENV​:
  PERL5LIB=""
  PERLBREW_BASHRC_VERSION="0.67"
  PERLBREW_HOME="/home/vse/.perlbrew"
  PERLBREW_MANPATH="/home/perlbrew/perls/perl-5.20.0-thread-multi-ld/man"
  PERLBREW_PATH="/home/perlbrew/bin​:/home/perlbrew/perls/perl-5.20.0-thread-multi-ld/bin"
  PERLBREW_PERL="perl-5.20.0-thread-multi-ld"
  PERLBREW_ROOT="/home/perlbrew"
  PERLBREW_VERSION="0.67"
  @​INC​:
  /home/perlbrew/perls/perl-5.20.0-thread-multi-ld/lib/site_perl/5.20.0/x86_64-linux-thread-multi-ld
  /home/perlbrew/perls/perl-5.20.0-thread-multi-ld/lib/site_perl/5.20.0
  /home/perlbrew/perls/perl-5.20.0-thread-multi-ld/lib/5.20.0/x86_64-linux-thread-multi-ld
  /home/perlbrew/perls/perl-5.20.0-thread-multi-ld/lib/5.20.0
  .

[p5pRT]

From victor@vsespb.ru

Another way to reproduce (without blessing a filehandle)

use strict;
use warnings;
use Carp; # mandatory
$SIG{ALRM}=sub{die};
alarm 1;
my $cmd = 'sleep 3';
my $pid = open FH, "|$cmd" or die "$!\n";
close FH;

__END__

Died at 57.pl line 4.
refcnt​: fd -1 < 0

(strange that does not work without 'use Carp' or 'use something_not_not_anything_else')

On Mon Jun 16 05​:29​:13 2014, efimov@​reg.ru wrote​:

the following code

use strict;
use warnings;
{
package MyFile;
sub print {
my $self = shift;
print {$$self} @​_;
}

}

$SIG{ALRM}=sub{die};
alarm 1;
my $pid = open FILE, "|-";
bless \*FILE, 'MyFile';
defined($pid) or die "open of pipe failed​: $!\n";
if ( !$pid ) { ### child
exec("sleep", "3");
} else { ### parent
print FILE "test\n123\n\121";
close FILE || die;
}

dies with

====
Died at 55.pl line 12.
refcnt​: fd -1 < 0

same happening in MIME​::Lite if sendmail works too slow​:

===
use strict;
use warnings;
use MIME​::Lite;
$SIG{ALRM}=sub{die};
alarm 1;
my $mailer = bless( {
'SubAttrs' => {
'content-type' => {
'charset' =>
'windows-1251'
}
},
'Parts' => [],
'Attrs' => {
'content-disposition' => 'inline',
'content-type' => 'text/plain',
'mime-version' => '1.0',
'content-length' => undef,
'content-transfer-encoding' => '8bit'
},
'Data' => 'zzzzz',
'Header' => [
['x-mailer','MIME​::Lite 3.029 (F2.82;
T2.04; A2.12; B3.14; Q3.13)'],
['date','Mon, 16 Jun 2014 14​:15​:54
+0400'],
['from','test <noreply@​example.com>'],
['to','test@​example.com'],
['subject','test'],
['reply-to','test
<noreply@​example.com>'],
['bcc','outbox']
]
}, 'MIME​::Lite' );
$mailer->send('sendmail', 'sleep 3');

"refcnt​: fd -1 < 0" - seems a perl bug (an assertion in C code)

reproducible in 5.14, 5.18, 5.20

==========
Summary of my perl5 (revision 5 version 20 subversion 0)
configuration​:

Platform​:
osname=linux, osvers=3.8.0-39-generic, archname=x86_64-linux-thread-
multi-ld
uname='linux green-u 3.8.0-39-generic #58~precise1-ubuntu smp fri
may 2 21​:33​:40 utc 2014 x86_64 x86_64 x86_64 gnulinux '
config_args='-de
-Dprefix=/home/perlbrew/perls/perl-5.20.0-thread-multi-ld -Dusethreads
-Duselongdouble -Dusemultiplicity
-Aeval​:scriptdir=/home/perlbrew/perls/perl-5.20.0-thread-multi-ld/bin'
hint=recommended, useposix=true, d_sigaction=define
useithreads=define, usemultiplicity=define
use64bitint=define, use64bitall=define, uselongdouble=define
usemymalloc=n, bincompat5005=undef
Compiler​:
cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -fwrapv
-fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include
-D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
optimize='-O2',
cppflags='-D_REENTRANT -D_GNU_SOURCE -fwrapv -fno-strict-aliasing
-pipe -fstack-protector -I/usr/local/include'
ccversion='', gccversion='4.6.3', gccosandvers=''
intsize=4, longsize=8, ptrsize=8, doublesize=8, byteorder=12345678
d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16
ivtype='long', ivsize=8, nvtype='long double', nvsize=16,
Off_t='off_t', lseeksize=8
alignbytes=16, prototype=define
Linker and Libraries​:
ld='cc', ldflags =' -fstack-protector -L/usr/local/lib'
libpth=/usr/local/lib
/usr/lib/gcc/x86_64-linux-gnu/4.6/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=-lnsl -lgdbm -ldl -lm -lcrypt -lutil -lpthread -lc
-lgdbm_compat
perllibs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc
libc=, so=so, useshrplib=false, libperl=libperl.a
gnulibc_version='2.15'
Dynamic Linking​:
dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
cccdlflags='-fPIC', lddlflags='-shared -O2 -L/usr/local/lib
-fstack-protector'

Characteristics of this binary (from libperl)​:
Compile-time options​: HAS_TIMES MULTIPLICITY PERLIO_LAYERS
PERL_DONT_CREATE_GVSV
PERL_HASH_FUNC_ONE_AT_A_TIME_HARD
PERL_IMPLICIT_CONTEXT PERL_MALLOC_WRAP
PERL_NEW_COPY_ON_WRITE PERL_PRESERVE_IVUV
USE_64_BIT_ALL USE_64_BIT_INT USE_ITHREADS
USE_LARGE_FILES USE_LOCALE USE_LOCALE_COLLATE
USE_LOCALE_CTYPE USE_LOCALE_NUMERIC
USE_LONG_DOUBLE
USE_PERLIO USE_PERL_ATOF USE_REENTRANT_API
Built under linux
Compiled at May 30 2014 06​:30​:13
%ENV​:
PERL5LIB=""
PERLBREW_BASHRC_VERSION="0.67"
PERLBREW_HOME="/home/vse/.perlbrew"
PERLBREW_MANPATH="/home/perlbrew/perls/perl-5.20.0-thread-multi-
ld/man"
PERLBREW_PATH="/home/perlbrew/bin​:/home/perlbrew/perls/perl-
5.20.0-thread-multi-ld/bin"
PERLBREW_PERL="perl-5.20.0-thread-multi-ld"
PERLBREW_ROOT="/home/perlbrew"
PERLBREW_VERSION="0.67"
@​INC​:
/home/perlbrew/perls/perl-5.20.0-thread-multi-
ld/lib/site_perl/5.20.0/x86_64-linux-thread-multi-ld
/home/perlbrew/perls/perl-5.20.0-thread-multi-
ld/lib/site_perl/5.20.0
/home/perlbrew/perls/perl-5.20.0-thread-multi-
ld/lib/5.20.0/x86_64-linux-thread-multi-ld
/home/perlbrew/perls/perl-5.20.0-thread-multi-ld/lib/5.20.0
.

[p5pRT]

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

[p5pRT]

From @tonycoz

On Mon Jun 16 06​:14​:37 2014, vsespb wrote​:

Another way to reproduce (without blessing a filehandle)

use strict;
use warnings;
use Carp; # mandatory
$SIG{ALRM}=sub{die};
alarm 1;
my $cmd = 'sleep 3';
my $pid = open FH, "|$cmd" or die "$!\n";
close FH;

This croaked for me without the use Carp​:

  tony@​mars​:.../git/perl2$ ./perl -Ilib fdlesszero.pl
  Died at fdlesszero.pl line 1.
  refcnt​: fd -1 < 0
  tony@​mars​:.../git/perl2$ cat fdlesszero.pl
  $SIG{ALRM}=sub{die};
  alarm 1;
  my $cmd = 'sleep 3';
  my $pid = open FH, "|$cmd" or die "$!\n";
  close FH;

What appears to be happening is, the explicit close executes, and ends up calling into my_pclose().

This function basically does two things,

a) calls PerlIO_close(), which closes the fd and sets the handle's fd to -1

b) loops on wait4pid(), waiting for the child process to complete

wait4pid() uses waitpid() or wait4() to wait for the child, if it's interruptted as in this case, it calls PERL_ASYNC_CHECK() which delivers any pending signals.

That dies, which tries to destroy FH again, and since fd is now -1, we get the croak above.

I can prevent the croak() by adding​:

  if (fd < 0) {
  /* the handle has already been closed */
  return -1;
  }

to the top of Perl_my_pclose().

It doesn't matter in this particular case, since the parent process immediately exits, but in a more complex case where the perl process keeps running this will result in zombie processes.

Tony

[p5pRT]

From victor@vsespb.ru

I think it should behave like this (when there is wait() called from destructor).

$ perl 1.pl
main pid 32071
Died at 1.pl line 9.
destruct exit 32072 -1
destruct exit 32071 65280

$ cat 1.pl
use strict;
use warnings;
print "main pid $$\n";
unless (fork()){
sleep 3;
exit;
}
END{ wait; print "destruct exit $$ $?\n"; };
$SIG{ALRM}=sub{die};
alarm 1;
wait;
print "main exit $$ $?\n";

So instead

  if (fd < 0) {
  /* the handle has already been closed */
  return -1;
  }

Perl_my_pclose should continue and run wait4pid loop, but PerlIO_close should be skipped.

Also, "if (fd < 0) {" can be improved like
"if we are in signal handler which is called from Perl_my_pclose for same filehandle".
(disclaimer​: totally not sure how it's possible to implement in terms of perl internals)

On Mon Jul 07 00​:22​:57 2014, tonyc wrote​:

On Mon Jun 16 06​:14​:37 2014, vsespb wrote​:

Another way to reproduce (without blessing a filehandle)

use strict;
use warnings;
use Carp; # mandatory
$SIG{ALRM}=sub{die};
alarm 1;
my $cmd = 'sleep 3';
my $pid = open FH, "|$cmd" or die "$!\n";
close FH;

This croaked for me without the use Carp​:

tony@​mars​:.../git/perl2$ ./perl -Ilib fdlesszero.pl
Died at fdlesszero.pl line 1.
refcnt​: fd -1 < 0
tony@​mars​:.../git/perl2$ cat fdlesszero.pl
$SIG{ALRM}=sub{die};
alarm 1;
my $cmd = 'sleep 3';
my $pid = open FH, "|$cmd" or die "$!\n";
close FH;

What appears to be happening is, the explicit close executes, and ends
up calling into my_pclose().

This function basically does two things,

a) calls PerlIO_close(), which closes the fd and sets the handle's fd
to -1

b) loops on wait4pid(), waiting for the child process to complete

wait4pid() uses waitpid() or wait4() to wait for the child, if it's
interruptted as in this case, it calls PERL_ASYNC_CHECK() which
delivers any pending signals.

That dies, which tries to destroy FH again, and since fd is now -1, we
get the croak above.

I can prevent the croak() by adding​:

if (fd < 0) {
/* the handle has already been closed */
return -1;
}

to the top of Perl_my_pclose().

It doesn't matter in this particular case, since the parent process
immediately exits, but in a more complex case where the perl process
keeps running this will result in zombie processes.

Tony

[p5pRT]

From @tonycoz

On Mon Jul 07 12​:48​:51 2014, vsespb wrote​:

So instead

if (fd < 0) {
/* the handle has already been closed */
return -1;
}

Perl_my_pclose should continue and run wait4pid loop, but PerlIO_close
should be skipped.

Without the original fd we can't look up the pid to wait on.

We can't re-order the close/wait to wait/close, since if we're writing to the child, it may be waiting for EOF (eg. a filter) before exiting.

Tony

[p5pRT]

From victor@vsespb.ru

On Mon Jul 07 16​:35​:06 2014, tonyc wrote​:

On Mon Jul 07 12​:48​:51 2014, vsespb wrote​:

So instead

if (fd < 0) {
/* the handle has already been closed */
return -1;
}

Perl_my_pclose should continue and run wait4pid loop, but
PerlIO_close
should be skipped.

Without the original fd we can't look up the pid to wait on.

We need make function re-entrant. Can save PID for later user in global varibale.

We can't re-order the close/wait to wait/close, since if we're writing
to the child, it may be waiting for EOF (eg. a filter) before exiting.

yes, right.

Here is prototype. All tests pass and original problem fixed.

====
+bool inside_my_pclose = FALSE;
+Pid_t inside_my_pclose_pid;
+
  /* VMS' my_pclose() is in VMS.c; same with OS/2 */
#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
  int status;
  SV **svp;
  Pid_t pid;
  Pid_t pid2 = 0;
  bool close_failed;
  dSAVEDERRNO;
  const int fd = PerlIO_fileno(ptr);
  bool should_wait;

  svp = av_fetch(PL_fdpid,fd,TRUE);
  pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
  SvREFCNT_dec(*svp);
  *svp = NULL;

+ if (fd < 0 && inside_my_pclose) {
+ /* the handle has already been closed */
+ close_failed = FALSE;
+ pid = inside_my_pclose_pid;
+ should_wait = TRUE;
+ }
+ else {
+
#if defined(USE_PERLIO)
  /* Find out whether the refcount is low enough for us to wait for the
  child proc without blocking. */
  should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
#else
  should_wait = pid > 0;
#endif

#ifdef OS2
  if (pid == -1) { /* Opened by popen. */
  return my_syspclose(ptr);
  }
#endif
+
  close_failed = (PerlIO_close(ptr) == EOF);
+ }
+
+ inside_my_pclose = TRUE;
+ inside_my_pclose_pid = pid;
  SAVE_ERRNO;
  if (should_wait) do {
  pid2 = wait4pid(pid, &status, 0);
  } while (pid2 == -1 && errno == EINTR);
+ inside_my_pclose = FALSE;
+
  if (close_failed) {
  RESTORE_ERRNO;
  return -1;
  }
  return(
  should_wait
  ? pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)
  : 0
  );
}

but real patch should also keep relation between PID and FH and work even if my_close(FILE1) called but then my_close(FILE2) called from inside signal handler.

[p5pRT]

From @tonycoz

On Tue Jul 08 03​:02​:17 2014, vsespb wrote​:

On Mon Jul 07 16​:35​:06 2014, tonyc wrote​:

On Mon Jul 07 12​:48​:51 2014, vsespb wrote​:

So instead

if (fd < 0) {
/* the handle has already been closed */
return -1;
}

Perl_my_pclose should continue and run wait4pid loop, but
PerlIO_close
should be skipped.

Without the original fd we can't look up the pid to wait on.

We need make function re-entrant. Can save PID for later user in
global varibale.

We can't re-order the close/wait to wait/close, since if we're
writing
to the child, it may be waiting for EOF (eg. a filter) before
exiting.

yes, right.

Here is prototype. All tests pass and original problem fixed.

...

but real patch should also keep relation between PID and FH and work
even if my_close(FILE1) called but then my_close(FILE2) called from
inside signal handler.

Another problem I can see with the current my_pclose() code - the second time we enter my_pclose() for our sample code, the PerlIO object has already been freed by PerlIO_close(), so we're accessing a freed object. Because of the way PerlIO allocates memory, this isn't picked up by valgrind.

I can think of a few different possibilities to fix the problem​:

a) implement a half-close operation for PerlIO that closes the handle but doesn't release the PerlIO object. my_pclose() would half-close the object, perform the wait, then do the full close which releases the PerlIO object. I'm not sure how much work this is.

b) keep a linked list (or other structure, but hopefully we don't have a lot of them) of closing-in-progress pipe PerlIO handles, my_pclose() checks if the handle is on the list. If it is, it bypasses the PerlIO_close(), if not, call PerlIO_close() and add an entry to the list with the PerlIO object pointer[1] and pid. After the wait() loop is complete remove the entry from the list. I think this might be the correct solution. Locking may need to be an issue as the linked list needs to be visible cross-thread as some handles are visible cross-thread. This is the multi-handle version of your solution.

c) implement something close to the vms/vms.c implementation of my_popen()/my_pclose() which keeps a fairly complex data structure for each pipe. Overkill here I think.

Tony

[1] this is undefined behaviour, but less so than following the pointer, I expect

[p5pRT]

From e.lepikhin@corp.mail.ru

Created by johnlepikhin@gmail.com

This is a bug report for perl from johnlepikhin@​gmail.com,
generated with the help of perlbug 1.40 running under perl 5.24.1.

-----------------------------------------------------------------
Perl crashes with error message "refcnt​: fd -1 < 0" when exception
is thrown in SigALRM handler while waiting for child process to be
closed. How to reproduce​:

$ perl -e 'alarm(1); $SIG{ALRM} = sub { die "" }; open($fh, "-|",
"sleep 2"); eval { close($fh); } '
refcnt​: fd -1 < 0

Perl Info

Flags:
    category=core
    severity=high

Site configuration information for perl 5.24.1:

Configured by Debian Project at Tue Sep 12 16:37:26 UTC 2017.

Summary of my perl5 (revision 5 version 24 subversion 1) 
configuration:
   
  Platform:
    osname=linux, osvers=3.16.0, 
    archname=x86_64-linux-gnu-thread-multi
    uname='linux localhost 3.16.0 #1 smp debian 3.16.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-Gg9XxY/perl-5.24.1=. -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.24 
    -Darchlib=/usr/lib/x86_64-linux-gnu/perl/5.24 
    -Dvendorprefix=/usr -Dvendorlib=/usr/share/perl5 
    -Dvendorarch=/usr/lib/x86_64-linux-gnu/perl5/5.24 
    -Dsiteprefix=/usr/local -Dsitelib=/usr/local/share/perl/5.24.1 
    -Dsitearch=/usr/local/lib/x86_64-linux-gnu/perl/5.24.1 
    -Dman1dir=/usr/share/man/man1 -Dman3dir=/usr/share/man/man3 
    -Dsiteman1dir=/usr/local/man/man1 
    -Dsiteman3dir=/usr/local/man/man3 -Dusesitecustomize 
    -Duse64bitint -Dman1ext=1 -Dman3ext=3perl 
    -Dpager=/usr/bin/sensible-pager -Uafs -Ud_csh -Ud_ualarm 
    -Uusesfio -Uusenm -Ui_libutil -Uversiononly -DDEBUGGING=-g 
    -Doptimize=-O2 -dEs -Duseshrplib -Dlibperl=libperl.so.5.24.1'
    hint=recommended, useposix=true, d_sigaction=define
    useithreads=define, usemultiplicity=define
    use64bitint=define, use64bitall=define, uselongdouble=undef
    usemymalloc=n, 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='6.3.0 20170516', 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/6/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.24.so, so=so, useshrplib=true, 
    libperl=libperl.so.5.24
    gnulibc_version='2.24'
  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 
-- 
QA automation engineer at Mail.ru. Telegram: johnlepikhin

[p5pRT]

From @tonycoz

On Wed, 11 Apr 2018 05​:53​:26 -0700, e.lepikhin@​corp.mail.ru wrote​:

Perl crashes with error message "refcnt​: fd -1 < 0" when exception
is thrown in SigALRM handler while waiting for child process to be
closed. How to reproduce​:

$ perl -e 'alarm(1); $SIG{ALRM} = sub { die "" }; open($fh, "-|",
"sleep 2"); eval { close($fh); } '
refcnt​: fd -1 < 0

This looks like a duplicate for 122112.

Tony

[p5pRT]

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

[p5pRT]

From @tonycoz

On Mon, 07 Jul 2014 12​:48​:51 -0700, vsespb wrote​:

Perl_my_pclose should continue and run wait4pid loop, but PerlIO_close
should be skipped.

Also, "if (fd < 0) {" can be improved like
"if we are in signal handler which is called from Perl_my_pclose for
same filehandle".
(disclaimer​: totally not sure how it's possible to implement in terms
of perl internals)

The attached fixes this specific problem.

It does leave the PerlIO handle in the IO SV IFP slot, so if someone attempts to use the handle after an interruptted pipe close they might still have problems.

Tony

[p5pRT]

From @tonycoz

0001-perl-122112-test-for-signal-handler-death-in-pclose.patch

From 8d15119dfcdaaf499a5e551b78da9212e639df9e Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 30 May 2018 14:03:04 +1000
Subject: (perl #122112) test for signal handler death in pclose

---
 t/io/pipe.t | 25 ++++++++++++++++++++++++-
 1 file changed, 24 insertions(+), 1 deletion(-)

diff --git a/t/io/pipe.t b/t/io/pipe.t
index f9ee65afe8..8196f05393 100644
--- a/t/io/pipe.t
+++ b/t/io/pipe.t
@@ -10,7 +10,7 @@ if (!$Config{'d_fork'}) {
     skip_all("fork required to pipe");
 }
 else {
-    plan(tests => 25);
+    plan(tests => 27);
 }
 
 my $Perl = which_perl();
@@ -241,3 +241,26 @@ SKIP: {
 
   is($child, -1, 'child reaped if piped program cannot be executed');
 }
+
+SKIP: {
+    # this is probably more restrictive than necessary
+    skip "Might not be using perl's pclose", 2
+      unless $^O =~ /^(linux|.*bsd|darwin)$/ia;
+    # [perl #122112] refcnt: fd -1 < 0 when a signal handler dies
+    # while a pipe close is waiting on a child process
+    my $prog = <<PROG;
+\$SIG{ALRM}=sub{die};
+alarm 1;
+\$Perl = "$Perl";
+my \$cmd = qq(\$Perl -e "sleep 3");
+my \$pid = open my \$fh, "|\$cmd" or die "\$!\n";
+close \$fh;
+PROG
+    my $out = fresh_perl($prog, {});
+    $::TODO = "not fixed yet";
+    cmp_ok($out, '!~', qr/refcnt/, "no exception from PerlIO");
+    undef $::TODO;
+    # checks that that program did something rather than failing to
+    # compile
+    cmp_ok($out, '=~', qr/Died at/, "but we did get the exception from die");
+}
-- 
2.11.0

[p5pRT]

From @tonycoz

0002-perl-122112-prevent-access-to-closed-pip-FH-on-a-sig.patch

From 4a0e84cfb4e3e88db08219eb4fc033b8ddbc29d5 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Wed, 13 Sep 2017 08:53:38 +1000
Subject: (perl #122112) prevent access to closed pip FH on a signal that dies

Don't access a closed PerlIO handle if a signal handler dies
when closing a pipe.
---
 doio.c      | 106 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 sv.h        |   1 +
 t/io/pipe.t |   2 --
 util.c      |   4 +--
 4 files changed, 108 insertions(+), 5 deletions(-)

diff --git a/doio.c b/doio.c
index 4b8923f77c..03c75219df 100644
--- a/doio.c
+++ b/doio.c
@@ -1726,6 +1726,110 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit)
     return retval;
 }
 
+#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
+
+static int
+S_pclose_free(pTHX_ SV *io, MAGIC *mg) {
+    if (mg->mg_obj && SvIVX(mg->mg_obj) > 0) {
+        /* We should only get here for an implicit close.
+
+           We do the close here rather than in S_do_pclose() because
+           during destruction magic is freed before io_close() is
+           called, so we no longer have access to the original PerlIO
+           object, which has been closed if we get here.
+         */
+        int fd = (int)SvIVX(mg->mg_obj);
+        SV **svp = av_fetch(PL_fdpid,fd,TRUE);
+        Pid_t pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
+
+        if (pid > 0) {
+            Pid_t pid2;
+            int status;
+            do {
+                /* a die within a signal handler in here may ... */
+                pid2 = wait4pid(pid, &status, 0);
+                /* ... prevent anything following here running */
+            } while (pid2 == -1 && errno == EINTR);
+        }
+        /* ensure sv_clear() doesn't try to close it again */
+        IoIFP(io) = NULL;
+        SvREFCNT_dec(*svp);
+        *svp = NULL;
+    }
+    return 0;
+}
+
+static const MGVTBL pclose_vtbl =
+    {
+        NULL, /* svt_get */
+        NULL, /* svt_set */
+        NULL, /* svt_len */
+        NULL, /* svt_clear */
+        S_pclose_free, /* svt_free */
+        NULL, /* svt_copy */
+        NULL, /* svt_dup */
+        NULL  /* svt_local */
+    };
+
+static int
+S_do_pclose(pTHX_ IO *io) {
+    MAGIC *mg = mg_findext((SV*)io, PERL_MAGIC_uvar, &pclose_vtbl);
+    int status;
+    if (!mg) {
+        mg = sv_magicext((SV*)io, sv_2mortal(newSViv(-1)), PERL_MAGIC_uvar, &pclose_vtbl, NULL, 0);
+    }
+    if (SvIVX(mg->mg_obj) == -1) {
+        int fd = PerlIO_fileno(IoIFP(io));
+        sv_setiv(mg->mg_obj, fd);
+
+        /* it's possible for a signal handler to be called when pclose() waits
+           on the child process, and for that signal handler to die, which leaves
+           the underlying PerlIO object freed, but the child process still
+           un-wait()ed upon.
+        */
+        status = PerlProc_pclose(IoIFP(io));
+    }
+    else {
+
+        /* if we get here, close() has been explicitly called on a
+           pipe handle we've already tried to close.
+
+           The magic free code will handle the implicit close in this
+           case.
+        */
+
+        int fd = (int)SvIVX(mg->mg_obj);
+        SV **svp = av_fetch(PL_fdpid,fd,TRUE);
+        Pid_t pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
+
+        if (pid > 0) {
+            Pid_t pid2;
+            do {
+                /* a die within a signal handler in here may ... */
+                pid2 = wait4pid(pid, &status, 0);
+                /* ... prevent anything following here running */
+            } while (pid2 == -1 && errno == EINTR);
+            status = pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status);
+        }
+        else {
+            status = 0;
+        }
+        SvREFCNT_dec(*svp);
+        *svp = NULL;
+    }
+    sv_setiv(mg->mg_obj, -1);
+
+    return status;
+}
+
+#define do_pclose(io) S_do_pclose(aTHX_ (io));
+
+#else
+
+#define do_pclose(io) PerlProc_pclose(IoIFP(io))
+
+#endif
+
 bool
 Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail)
 {
@@ -1735,7 +1839,7 @@ Perl_io_close(pTHX_ IO *io, GV *gv, bool not_implicit, bool warn_on_fail)
 
     if (IoIFP(io)) {
 	if (IoTYPE(io) == IoTYPE_PIPE) {
-	    const int status = PerlProc_pclose(IoIFP(io));
+            const int status = do_pclose(io);
 	    if (not_implicit) {
 		STATUS_NATIVE_CHILD_SET(status);
 		retval = (STATUS_UNIX == 0);
diff --git a/sv.h b/sv.h
index 1c7224277f..503fd14eb7 100644
--- a/sv.h
+++ b/sv.h
@@ -1422,6 +1422,7 @@ object type. Exposed to perl code via Internals::SvREADONLY().
 #define IoFMT_GV(sv)	((XPVIO*)  SvANY(sv))->xio_fmt_gv
 #define IoBOTTOM_NAME(sv)((XPVIO*) SvANY(sv))->xio_bottom_name
 #define IoBOTTOM_GV(sv)	((XPVIO*)  SvANY(sv))->xio_bottom_gv
+#define IoPIPE_PID(sv)	((XPVIO*)  SvANY(sv))->xio_pipe_pid
 #define IoTYPE(sv)	((XPVIO*)  SvANY(sv))->xio_type
 #define IoFLAGS(sv)	((XPVIO*)  SvANY(sv))->xio_flags
 
diff --git a/t/io/pipe.t b/t/io/pipe.t
index 8196f05393..c95da9c796 100644
--- a/t/io/pipe.t
+++ b/t/io/pipe.t
@@ -257,9 +257,7 @@ my \$pid = open my \$fh, "|\$cmd" or die "\$!\n";
 close \$fh;
 PROG
     my $out = fresh_perl($prog, {});
-    $::TODO = "not fixed yet";
     cmp_ok($out, '!~', qr/refcnt/, "no exception from PerlIO");
-    undef $::TODO;
     # checks that that program did something rather than failing to
     # compile
     cmp_ok($out, '=~', qr/Died at/, "but we did get the exception from die");
diff --git a/util.c b/util.c
index 647f53307d..58fdc4e6e3 100644
--- a/util.c
+++ b/util.c
@@ -2795,8 +2795,6 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
 
     svp = av_fetch(PL_fdpid,fd,TRUE);
     pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
-    SvREFCNT_dec(*svp);
-    *svp = NULL;
 
 #if defined(USE_PERLIO)
     /* Find out whether the refcount is low enough for us to wait for the
@@ -2816,6 +2814,8 @@ Perl_my_pclose(pTHX_ PerlIO *ptr)
     if (should_wait) do {
 	pid2 = wait4pid(pid, &status, 0);
     } while (pid2 == -1 && errno == EINTR);
+    SvREFCNT_dec(*svp);
+    *svp = NULL;
     if (close_failed) {
 	RESTORE_ERRNO;
 	return -1;
-- 
2.11.0

[p5pRT]

From @tonycoz

On Tue, 29 May 2018 22​:54​:52 -0700, tonyc wrote​:

On Mon, 07 Jul 2014 12​:48​:51 -0700, vsespb wrote​:

Perl_my_pclose should continue and run wait4pid loop, but
PerlIO_close
should be skipped.

Also, "if (fd < 0) {" can be improved like
"if we are in signal handler which is called from Perl_my_pclose for
same filehandle".
(disclaimer​: totally not sure how it's possible to implement in terms
of perl internals)

The attached fixes this specific problem.

It does leave the PerlIO handle in the IO SV IFP slot, so if someone
attempts to use the handle after an interruptted pipe close they might
still have problems.

I think the attached is a better solution, as detailed in the commit message.

Tony