In the latest maintperl snapshot, simply loading FileCache from miniperl gives a nasty stack dump:
$ mcr [-]miniperl -e "use FileCache;"
%SYSTEM-F-ACCVIO, access violation, reason mask=00, virtual address=000000000000005C, PC=000000000011FA70, PS=0000001B
%TRACE-F-TRACEBACK, symbolic stack dump follows
image module routine line rel PC abs PC
MINIPERL SV Perl_sv_free 58951 000000000000C9A0 000000000011FA70
MINIPERL MG Perl_magic_setsig 67031 0000000000003688 00000000000E6D68
MINIPERL MG Perl_mg_set 53115 000000000000046C 00000000000E3B4C
MINIPERL PP_HOT Perl_pp_aassign 54016 00000000000043F8 000000000014E0B8
MINIPERL DUMP Perl_runops_debug 55095 00000000000067BC 00000000000C23EC
MINIPERL PERL Perl_call_sv 55051 0000000000004F14 00000000000701F4
MINIPERL PERL S_call_list_body 62301 0000000000009CF4 0000000000074FD4
MINIPERL PERL Perl_call_list 62230 0000000000000000 0000000000000000
MINIPERL OP Perl_newATTRSUB 57547 000000000000E864 00000000000A5724
MINIPERL OP Perl_utilize 56162 0000000000009E2C 00000000000A0CEC
MINIPERL PERLY Perl_yyparse 54858 0000000000001838 00000000001B88C8
MINIPERL PERL S_parse_body 54613 00000000000038B4 000000000006EB94
MINIPERL PERL perl_parse 54124 0000000000002264 000000000006D544
MINIPERL MINIPERLMAIN main 53006 0000000000000188 0000000000060188
MINIPERL MINIPERLMAIN __main 0 0000000000000070 0000000000060070
PTHREAD$RTL 0 000000000003E4E0 000000007BCD04E0
PTHREAD$RTL 0 000000000001C31C 000000007BCAE31C
0 FFFFFFFF8028359C FFFFFFFF8028359C
The relevant line from Perl_magic_setsig where it is attempting to free something that doesn't exist is:
67031 SvREFCNT_dec(PL_psig_name[i]);
which after macro expansion looks like:
Perl_sv_free(my_perl, (SV*)((my_perl->Ipsig_name)[i]))
The value of i when the crash occurs is 20, which is the value of
SIGCHLD, which is not a signal we currently support in Perl on VMS. The
possible patch attached below avoids the problem by checking
$Config{sig_name} in FileCache.pm before setting signals. That (and the
side note mentioned below) get all the FileCache tests passing.I don't really know enough about Perl's signal handling to know if this is the best or even correct solution. It does seem that a more friendly "you can't do that signal" would be better than simply stepping off into never-never land.
Side note: C<Foo'Bar> is not valid filename syntax on VMS so I have adjusted the tests accordingly.
--- lib/FileCache.pm;-0 Sat Jun 14 00:57:14 2003
+++ lib/FileCache.pm Fri Jun 20 01:25:48 2003
@@ -72,6 +72,7 @@
require 5.006;
use Carp;
+use Config;
use strict;
no strict 'refs';
# These are not C<my> for legacy reasons.
@@ -88,7 +89,9 @@
*{$pkg.'::close'} = \&cacheout_close;
# Reap our children
- @{"$pkg\::SIG"}{'CLD', 'CHLD', 'PIPE'} = ('IGNORE')x3;
+ ${"$pkg\::SIG"}{'CLD'} = 'IGNORE' if $Config{sig_name} =~ /\bCLD\b/;
+ ${"$pkg\::SIG"}{'CHLD'} = 'IGNORE' if $Config{sig_name} =~ /\bCHLD\b/;
+ ${"$pkg\::SIG"}{'PIPE'} = 'IGNORE' if $Config{sig_name} =~ /\bPIPE\b/;
# Truth is okay here because setting maxopen to 0 would be bad
return $cacheout_maxopen = $args{maxopen} if $args{maxopen};
--- lib/FileCache/t/01open.t;-0 Sun Jun 15 14:14:24 2003
+++ lib/FileCache/t/01open.t Fri Jun 20 11:09:51 2003
@@ -2,7 +2,7 @@
use FileCache;
use vars qw(@files);
BEGIN {
- @files = qw(foo bar baz quux Foo'Bar);
+ @files = qw(foo bar baz quux Foo_Bar);
chdir 't' if -d 't';
#For tests within the perl distribution
--- lib/FileCache/t/03append.t;-0 Sun Jun 15 14:14:24 2003
+++ lib/FileCache/t/03append.t Fri Jun 20 11:12:05 2003
@@ -2,7 +2,7 @@
use FileCache maxopen=>2;
use vars qw(@files);
BEGIN {
- @files = qw(foo bar baz quux Foo'Bar);
+ @files = qw(foo bar baz quux Foo_Bar);
chdir 't' if -d 't';
#For tests within the perl distribution
--- lib/FileCache/t/05override.t;-0 Sun Jun 15 14:14:24 2003
+++ lib/FileCache/t/05override.t Fri Jun 20 11:31:58 2003
@@ -8,12 +8,12 @@
END;
}
END{
- unlink("Foo'Bar");
+ unlink("Foo_Bar");
}
print "1..1\n";
{# Test 5: that close is overridden properly within the caller
- cacheout local $_ = "Foo'Bar";
+ cacheout local $_ = "Foo_Bar";
print $_ "Hello World\n";
close($_);
print 'not ' if fileno($_);
