use strict;
use warnings;

my $file = 'reqtest.pl';
my $fh;

open $fh, ">$file" or die "Can't create file '$file': $!: $^E\n";
print $fh <<'EOT';
BEGIN {
    print STDERR "Hit CTRL+C now!\n";
    sleep 3;
}
1;
EOT
close $fh;

unshift @INC, sub {
    my($coderef, $filename) = @_;
    return unless $filename eq $file;
    open $fh, $filename or die "Can't read file '$file': $!: $^E\n";
    return $fh;
};

$SIG{INT} = sub {
    print "Caught SIGINT. Terminating.\n";
    if (defined fileno $fh) {
        close $fh or warn "Can't close fh: $!: $^E\n";
    }
    else {
        print STDERR "fh is already closed\n";
    }
    if (-f $file) {
        unlink $file or warn "Can't delete file '$file': $!: $^E\n";
    }
    else {
        print STDERR "file is already deleted (!)\n";
    }
    exit;
};

require $file or die "require() failed\n";

unlink $file or die "Can't delete file '$file': $!: $^E\n";
[download]

However, I now find that the SIGINT handler says that the file is already closed, and the unlink() still fails! (Running on Cygwin also shows that the file is "already closed", but, of course, the unlink() works on Cygwin anyway.)

I don't believe there is any problem with the two closures (the @INC sub and the SIGINT handler) sharing the same $file and $fh, because the following similar program (without require()) works as expected:

use strict;
use warnings;

my $file = 'reqtest.pl';
my $fh;

open $fh, ">$file" or die "Can't create file '$file': $!: $^E\n";
print $fh "1;\n";
close $fh;

my $sub = sub {
    open $fh, $file or die "Can't open $file: $!: $^E\n";
    print STDERR "Hit CTRL+C now!\n";
    sleep 3;
};

$SIG{INT} = sub {
    print "Caught SIGINT. Terminating.\n";
    if (defined fileno $fh) {
        close $fh or warn "Can't close fh: $!: $^E\n";
    }
    else {
        print STDERR "fh is already closed\n";
    }
    if (-f $file) {
        unlink $file or warn "Can't delete file '$file': $!: $^E\n";
    }
    else {
        print STDERR "file is already deleted (!)\n";
    }
    exit;
};

$sub->();

unlink $file or die "Can't delete file '$file': $!: $^E\n";
[download]

I believe the SIGINT handler in the first program is mistaken when it claims that the $fh is already closed, because (a) if I insert another sleep() at the point where that message is printed, then I can see using Process Explorer (from www.sysinternals.com) that perl.exe still has a handle on the require()'d file, and (b) if the $fh really was closed then why would the unlink() fail?

All I can think is that perl has somehow got confused with the state of the $fh. It thinks that it is closed but in fact there is at least an operating-system-level filehandle still open.

Does this look like a perl bug, or have I got something wrong here?

Update:

After walking through the perl internals with a C debugger, it does indeed look like perl.exe has the require()'d file open, but has lost the IO thingy in the $fh through which it could be closed. See my post to p5p for details (here).

If the perl internals really are broken then the best I can hope for is a future fix, but I still need some way of doing this now with existing perls.

I've therefore pursued the route of doing some non-portable things for Win32-land, and come up with the following. This uses the GetOsFHandle() and CloseHandle() functions in the Win32API::File module (part of libwin32) to access the underlying operating-system filehandle. For other OS's, I've created a pair of functions of the same names which manipulate the file descriptor instead. This program works fine under both native Win32 and Cygwin. (Note that simply using file descriptors for Win32 too didn't work -- you really do have to go down to the level of the OS filehandles to get this to work!).

use strict;
use warnings;

BEGIN {
    if ($^O =~ /MSWin32/io) {
        require Win32API::File;
        Win32API::File->import(qw(GetOsFHandle CloseHandle));
    }
    else {
        no strict 'refs';
        *{GetOsFHandle} = sub {
            use strict 'refs';
            return fileno $_[0];
        };
        *{CloseHandle} = sub {
            use strict 'refs';
            open my $fh, '<&' . $_[0] or return;
            return close $fh;
        };
    }
}

my $file = 'reqtest.pl';
my $osfh;

open my $fh, ">$file" or die "Can't create file '$file': $!: $^E\n";
print $fh <<'EOT';
BEGIN {
    print STDERR "Hit CTRL+C now!\n";
    sleep 3;
}
1;
EOT
close $fh;

unshift @INC, sub {
    my($coderef, $filename) = @_;
    return unless $filename eq $file;
    open my $fh2, $filename or die "Can't read file '$file': $!: $^E\n
+";
    $osfh = GetOsFHandle($fh2);
    return $fh2;
};

$SIG{INT} = sub {
    print STDERR "Caught SIGINT. Terminating.\n";
    if (defined $osfh) {
        CloseHandle($osfh) or warn "Can't close osfh: $!: $^E\n";
    }
    else {
        print STDERR "osfh is already closed\n";
    }
    if (-f $file) {
        unlink $file or warn "Can't delete file '$file': $!: $^E\n";
    }
    else {
        print STDERR "file is already deleted (!)\n";
    }
    exit;
};

require $file or die "require() failed\n";

unlink $file or die "Can't delete file '$file': $!: $^E\n";
[download]

Further Update:

Perhaps a simpler solution is actually just to delay the handling of the SIGINT until after the require() has completed. In this way, we don't even need a special coderef entry in @INC:

use strict;
use warnings;

my $file = 'reqtest.pl';
my $interrupted = 0;

open my $fh, ">$file" or die "Can't create file '$file': $!: $^E\n";
print $fh <<'EOT';
BEGIN {
    print STDERR "Hit CTRL+C now!\n";
    sleep 3;
}
1;
EOT
close $fh;

$SIG{INT} = sub {
    print "Caught SIGINT. Terminating.\n";
    $interrupted = 1;
};

sub handle_sigint {
    if (-f $file) {
        unlink $file or warn "Can't delete file '$file': $!: $^E\n";
    }
    else {
        print STDERR "file is already deleted (!)\n";
    }
    exit;
}

require $file or die "require() failed\n";
handle_sigint() if $interrupted;

unlink $file or die "Can't delete file '$file': $!: $^E\n";
[download]