How to find open global filehandles in a perl program

Question

I just tracked down a problem where I had to close all open filehandles for my Apache cgi script to continue. I traced the problem to Parse::RecDescent.

#!/usr/bin/env perl

use strict;
use warnings;
use feature qw/say/;
$|++;

print "Content-Type: text/plain\n\n";

use Parse::RecDescent;

say "$$: pre-fork: ". time;

if(my $pid = fork) {
    # parent
    say "$$: return immediately: ". time;
}
else {
    # child 
    say "$$: kicked off big process: ". time;
    close STDIN;
    close STDOUT;
    close STDERR;
    # close *{'Parse::RecDescent::ERROR'};
    sleep 5;
}

My question is how do I find all open package filehandles?

I know fileno will return a counter for an open filehandle. Is there a way to do a reverse lookup for these, or close filehandles by their fileno counter?

Answer 1

On some systems, the directory returned by "/proc/$$/fd/" contains the list of open file descriptors. You could use POSIX::close to close them.

# close all filehandles
for (glob "/proc/$$/fd/*") { POSIX::close($1) if m{/(\d+)$}; }

Answer 2

What about globally overriding open with a version that keeps a list of all of the handles it creates? Something like this could be a start:

use Scalar::Util 'weaken';
use Symbol ();
my @handles;
BEGIN {
    *CORE::GLOBAL::open = sub (*;$@) {
        if (defined $_[0] and not ref $_[0]) {
            splice @_, 0, 1, Symbol::qualify_to_ref($_[0])
        }
        my $ret =
            @_ == 1 ? CORE::open $_[0] :
            @_ == 2 ? CORE::open $_[0], $_[1] :
                      CORE::open $_[0], $_[1], @_[2 .. $#_];
        if ($ret) {
            push @handles, $_[0];
            weaken $handles[-1];
        }
        $ret
    }
}

sub close_all_handles {
    $_ and eval {close $_} for @handles
}

open FH, $0;

say scalar <FH>;  # prints "use Scalar::Util 'weaken';"

close_all_handles;

say scalar <FH>;  # error: readline() on closed file handle

This should catch all of the global handles, and even any lexical handles that got created but were never cleaned up (due to circular references or other reasons).

If you place this override (the BEGIN block) before the call to use Parse::RecDescent then it will override the calls to open that the module makes.

Answer 3

I ended up using @ikegami's suggestion but I was interested in @Axeman's method. Here is a simplified version.

# Find all file-handles in packages.
my %seen;
sub recurse {
    no strict 'refs';
    my $package = shift or return;
    return if $seen{$package}++;

    for my $part (sort keys %{$package}) {
        if (my $fileno = fileno($package.$part)) {
            print $package.$part." => $fileno\n";
        }
    }
    for my $part (grep /::/, sort keys %{$package}) {
        (my $sub_pkg = $package.$part) =~ s/main:://;
        recurse($sub_pkg);
    }
}
recurse('main::');

Answer 4

When tracking down the close-on-exec details for ikegami's curiosity, I think I found that all you need to do is close STDIN, STDOUT, and STDERR yourself if you are simply executing another process:

   $SYSTEM_FD_MAX
   $^F     The maximum system file descriptor, ordinarily 2.
           System file descriptors are passed to exec()ed
           processes, while higher file descriptors are not.
           Also, during an open(), system file descriptors are
           preserved even if the open() fails.  (Ordinary file
           descriptors are closed before the open() is
           attempted.)  The close-on-exec status of a file
           descriptor will be decided according to the value of
           $^F when the corresponding file, pipe, or socket was
           opened, not the time of the exec().

Of course, if your long-lived task does not require an execve(2) call to run, then the close-on-exec flag won't help you at all. It all depends upon what sleep 5 is a stand-in for.

Answer 5

You can descend through the package tree:

use strict;
use warnings;
use constant BREAK_DESCENT => {};

use Carp    qw<croak>;
use English qw<$EVAL_ERROR>; # $@

sub break_descent { 
    return BREAK_DESCENT if defined wantarray;
    die BREAK_DESCENT;
}

sub _package_descend {
    my ( $package_name, $stash, $selector ) = @_;
    my $in_main     = $package_name =~ m/^(?:main)?::$/; 
    foreach my $name ( keys %$stash ) { 
        next if ( $in_main and $name eq 'main::' );
        my $full_name = $package_name . $name;
        local $_      = do { no strict 'refs'; \*$full_name; };
        my $return 
            = $name =~ m/::$/ 
            ? _package_descend( $full_name, *{$_}{HASH}, $selector ) 
            : $selector->( $package_name, $name => $_ )
            ;
        return BREAK_DESCENT if ( ref( $return ) and $return == BREAK_DESCENT );
    }
    return;
}

sub package_walk {

    my ( $package_name, $selector ) 
        = @_ == 1 ? ( '::', shift )
        :           @_
        ;

    $package_name  .= '::' unless substr( $package_name, -2 ) eq '::';
    local $EVAL_ERROR;

    eval { 
       no strict 'refs';
       _package_descend( $package_name, \%$package_name, $selector ); 
    };

    return unless $EVAL_ERROR;
    return if     do { no warnings 'numeric'; $EVAL_ERROR == BREAK_DESCENT; };

    say STDERR $EVAL_ERROR;
    croak( 'Failed in selector!' );
}

package_walk( sub { 
    my ( $pkg, $name ) = @_;
    #say "$pkg$name";
    # to not close handles in ::main::
    #return if $pkg =~  m/^(?:main)?::$/;
    # use IO::Handle methods...
    map { defined and $_->opened and $_->close } *{$_}{IO}; 
});