This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Restore VMS glob skip removed in 1bb8785a.
[perl5.git] / t / run / fresh_perl.t
1 #!./perl
2
3 # ** DO NOT ADD ANY MORE TESTS HERE **
4 # Instead, put the test in the appropriate test file and use the 
5 # fresh_perl_is()/fresh_perl_like() functions in t/test.pl.
6
7 # This is for tests that used to abnormally cause segfaults, and other nasty
8 # errors that might kill the interpreter and for some reason you can't
9 # use an eval().
10
11 BEGIN {
12     chdir 't' if -d 't';
13     @INC = '../lib';
14     require './test.pl';        # for which_perl() etc
15 }
16
17 use strict;
18
19 my $Perl = which_perl();
20
21 $|=1;
22
23 my @prgs = ();
24 while(<DATA>) { 
25     if(m/^#{8,}\s*(.*)/) { 
26         push @prgs, ['', $1];
27     }
28     else { 
29         $prgs[-1][0] .= $_;
30     }
31 }
32 plan tests => scalar @prgs;
33
34 foreach my $prog (@prgs) {
35     my($raw_prog, $name) = @$prog;
36
37     my $switch;
38     if ($raw_prog =~ s/^\s*(-\w.*)\n//){
39         $switch = $1;
40     }
41
42     my($prog,$expected) = split(/\nEXPECT\n/, $raw_prog);
43     $prog .= "\n";
44     $expected = '' unless defined $expected;
45
46     if ($prog =~ /^\# SKIP: (.+)/m) {
47         if (eval $1) {
48             ok(1, "Skip: $1");
49             next;
50         }
51     }
52
53     $expected =~ s/\n+$//;
54
55     fresh_perl_is($prog, $expected, { switches => [$switch || ''] }, $name);
56 }
57
58 __END__
59 ########
60 $a = ":="; @_ = split /($a)/o, "a:=b:=c"; print "@_"
61 EXPECT
62 a := b := c
63 ########
64 $cusp = ~0 ^ (~0 >> 1);
65 use integer;
66 $, = " ";
67 print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n";
68 EXPECT
69 7 0 0 8 !
70 ########
71 $foo=undef; $foo->go;
72 EXPECT
73 Can't call method "go" on an undefined value at - line 1.
74 ########
75 BEGIN
76         {
77             "foo";
78         }
79 ########
80 $array[128]=1
81 ########
82 $x=0x0eabcd; print $x->ref;
83 EXPECT
84 Can't call method "ref" without a package or object reference at - line 1.
85 ########
86 chop ($str .= <DATA>);
87 ########
88 close ($banana);
89 ########
90 $x=2;$y=3;$x<$y ? $x : $y += 23;print $x;
91 EXPECT
92 25
93 ########
94 eval 'sub bar {print "In bar"}';
95 ########
96 system './perl -ne "print if eof" /dev/null'
97 ########
98 chop($file = <DATA>);
99 ########
100 package N;
101 sub new {my ($obj,$n)=@_; bless \$n}  
102 $aa=new N 1;
103 $aa=12345;
104 print $aa;
105 EXPECT
106 12345
107 ########
108 $_="foo";
109 printf(STDOUT "%s\n", $_);
110 EXPECT
111 foo
112 ########
113 push(@a, 1, 2, 3,)
114 ########
115 quotemeta ""
116 ########
117 for ("ABCDE") {
118  &sub;
119 s/./&sub($&)/eg;
120 print;}
121 sub sub {local($_) = @_;
122 $_ x 4;}
123 EXPECT
124 Modification of a read-only value attempted at - line 3.
125 ########
126 package FOO;sub new {bless {FOO => BAR}};
127 package main;
128 use strict vars;   
129 my $self = new FOO;
130 print $$self{FOO};
131 EXPECT
132 BAR
133 ########
134 $_="foo";
135 s/.{1}//s;
136 print;
137 EXPECT
138 oo
139 ########
140 print scalar ("foo","bar")
141 EXPECT
142 bar
143 ########
144 sub by_number { $a <=> $b; };# inline function for sort below
145 $as_ary{0}="a0";
146 @ordered_array=sort by_number keys(%as_ary);
147 ########
148 sub NewShell
149 {
150   local($Host) = @_;
151   my($m2) = $#Shells++;
152   $Shells[$m2]{HOST} = $Host;
153   return $m2;
154 }
155  
156 sub ShowShell
157 {
158   local($i) = @_;
159 }
160  
161 &ShowShell(&NewShell(beach,Work,"+0+0"));
162 &ShowShell(&NewShell(beach,Work,"+0+0"));
163 &ShowShell(&NewShell(beach,Work,"+0+0"));
164 ########
165    {
166        package FAKEARRAY;
167    
168        sub TIEARRAY
169        { print "TIEARRAY @_\n"; 
170          die "bomb out\n" unless $count ++ ;
171          bless ['foo'] 
172        }
173        sub FETCH { print "fetch @_\n"; $_[0]->[$_[1]] }
174        sub STORE { print "store @_\n"; $_[0]->[$_[1]] = $_[2] }
175        sub DESTROY { print "DESTROY \n"; undef @{$_[0]}; }
176    }
177    
178 eval 'tie @h, FAKEARRAY, fred' ;
179 tie @h, FAKEARRAY, fred ;
180 EXPECT
181 TIEARRAY FAKEARRAY fred
182 TIEARRAY FAKEARRAY fred
183 DESTROY 
184 ########
185 BEGIN { die "phooey\n" }
186 EXPECT
187 phooey
188 BEGIN failed--compilation aborted at - line 1.
189 ########
190 BEGIN { 1/$zero }
191 EXPECT
192 Illegal division by zero at - line 1.
193 BEGIN failed--compilation aborted at - line 1.
194 ########
195 BEGIN { undef = 0 }
196 EXPECT
197 Modification of a read-only value attempted at - line 1.
198 BEGIN failed--compilation aborted at - line 1.
199 ########
200 {
201     package foo;
202     sub PRINT {
203         shift;
204         print join(' ', reverse @_)."\n";
205     }
206     sub PRINTF {
207         shift;
208           my $fmt = shift;
209         print sprintf($fmt, @_)."\n";
210     }
211     sub TIEHANDLE {
212         bless {}, shift;
213     }
214     sub READLINE {
215         "Out of inspiration";
216     }
217     sub DESTROY {
218         print "and destroyed as well\n";
219   }
220   sub READ {
221       shift;
222       print STDOUT "foo->can(READ)(@_)\n";
223       return 100; 
224   }
225   sub GETC {
226       shift;
227       print STDOUT "Don't GETC, Get Perl\n";
228       return "a"; 
229   }    
230 }
231 {
232     local(*FOO);
233     tie(*FOO,'foo');
234     print FOO "sentence.", "reversed", "a", "is", "This";
235     print "-- ", <FOO>, " --\n";
236     my($buf,$len,$offset);
237     $buf = "string";
238     $len = 10; $offset = 1;
239     read(FOO, $buf, $len, $offset) == 100 or die "foo->READ failed";
240     getc(FOO) eq "a" or die "foo->GETC failed";
241     printf "%s is number %d\n", "Perl", 1;
242 }
243 EXPECT
244 This is a reversed sentence.
245 -- Out of inspiration --
246 foo->can(READ)(string 10 1)
247 Don't GETC, Get Perl
248 Perl is number 1
249 and destroyed as well
250 ########
251 my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n"
252 EXPECT
253 2 2 2
254 ########
255 # used to attach defelem magic to all immortal values,
256 # which made restore of local $_ fail.
257 foo(2>1);
258 sub foo { bar() for @_;  }
259 sub bar { local $_; }
260 print "ok\n";
261 EXPECT
262 ok
263 ########
264 @a = ($a, $b, $c, $d) = (5, 6);
265 print "ok\n"
266   if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]);
267 EXPECT
268 ok
269 ########
270 print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000);
271 EXPECT
272 ok
273 ########
274 print "ok\n" if ("\0" lt "\xFF");
275 EXPECT
276 ok
277 ########
278 open(H,'run/fresh_perl.t'); # must be in the 't' directory
279 stat(H);
280 print "ok\n" if (-e _ and -f _ and -r _);
281 EXPECT
282 ok
283 ########
284 sub thing { 0 || return qw(now is the time) }
285 print thing(), "\n";
286 EXPECT
287 nowisthetime
288 ########
289 $ren = 'joy';
290 $stimpy = 'happy';
291 { local $main::{ren} = *stimpy; print $ren, ' ' }
292 print $ren, "\n";
293 EXPECT
294 happy joy
295 ########
296 $stimpy = 'happy';
297 { local $main::{ren} = *stimpy; print ${'ren'}, ' ' }
298 print +(defined(${'ren'}) ? 'oops' : 'joy'), "\n";
299 EXPECT
300 happy joy
301 ########
302 package p;
303 sub func { print 'really ' unless wantarray; 'p' }
304 sub groovy { 'groovy' }
305 package main;
306 print p::func()->groovy(), "\n"
307 EXPECT
308 really groovy
309 ########
310 @list = ([ 'one', 1 ], [ 'two', 2 ]);
311 sub func { $num = shift; (grep $_->[1] == $num, @list)[0] }
312 print scalar(map &func($_), 1 .. 3), " ",
313       scalar(map scalar &func($_), 1 .. 3), "\n";
314 EXPECT
315 2 3
316 ########
317 ($k, $s)  = qw(x 0);
318 @{$h{$k}} = qw(1 2 4);
319 for (@{$h{$k}}) { $s += $_; delete $h{$k} if ($_ == 2) }
320 print "bogus\n" unless $s == 7;
321 ########
322 my $a = 'outer';
323 eval q[ my $a = 'inner'; eval q[ print "$a " ] ];
324 eval { my $x = 'peace'; eval q[ print "$x\n" ] }
325 EXPECT
326 inner peace
327 ########
328 -w
329 $| = 1;
330 sub foo {
331     print "In foo1\n";
332     eval 'sub foo { print "In foo2\n" }';
333     print "Exiting foo1\n";
334 }
335 foo;
336 foo;
337 EXPECT
338 In foo1
339 Subroutine foo redefined at (eval 1) line 1.
340 Exiting foo1
341 In foo2
342 ########
343 $s = 0;
344 map {#this newline here tickles the bug
345 $s += $_} (1,2,4);
346 print "eat flaming death\n" unless ($s == 7);
347 ########
348 sub foo { local $_ = shift; @_ = split; @_ }
349 @x = foo(' x  y  z ');
350 print "you die joe!\n" unless "@x" eq 'x y z';
351 ########
352 /(?{"{"})/      # Check it outside of eval too
353 EXPECT
354 Sequence (?{...}) not terminated or not {}-balanced in regex; marked by <-- HERE in m/(?{ <-- HERE "{"})/ at - line 1.
355 ########
356 /(?{"{"}})/     # Check it outside of eval too
357 EXPECT
358 Unmatched right curly bracket at (re_eval 1) line 1, at end of line
359 syntax error at (re_eval 1) line 1, near ""{"}"
360 Compilation failed in regexp at - line 1.
361 ########
362 BEGIN { @ARGV = qw(a b c d e) }
363 BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" }
364 END { print "end <",shift,">\nargv <@ARGV>\n" }
365 INIT { print "init <",shift,">\n" }
366 CHECK { print "check <",shift,">\n" }
367 EXPECT
368 argv <a b c d e>
369 begin <a>
370 check <b>
371 init <c>
372 end <d>
373 argv <e>
374 ########
375 -l
376 # fdopen from a system descriptor to a system descriptor used to close
377 # the former.
378 open STDERR, '>&=STDOUT' or die $!;
379 select STDOUT; $| = 1; print fileno STDOUT or die $!;
380 select STDERR; $| = 1; print fileno STDERR or die $!;
381 EXPECT
382 1
383 2
384 ########
385 -w
386 sub testme { my $a = "test"; { local $a = "new test"; print $a }}
387 EXPECT
388 Can't localize lexical variable $a at - line 1.
389 ########
390 package X;
391 sub ascalar { my $r; bless \$r }
392 sub DESTROY { print "destroyed\n" };
393 package main;
394 *s = ascalar X;
395 EXPECT
396 destroyed
397 ########
398 package X;
399 sub anarray { bless [] }
400 sub DESTROY { print "destroyed\n" };
401 package main;
402 *a = anarray X;
403 EXPECT
404 destroyed
405 ########
406 package X;
407 sub ahash { bless {} }
408 sub DESTROY { print "destroyed\n" };
409 package main;
410 *h = ahash X;
411 EXPECT
412 destroyed
413 ########
414 package X;
415 sub aclosure { my $x; bless sub { ++$x } }
416 sub DESTROY { print "destroyed\n" };
417 package main;
418 *c = aclosure X;
419 EXPECT
420 destroyed
421 ########
422 package X;
423 sub any { bless {} }
424 my $f = "FH000"; # just to thwart any future optimisations
425 sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r }
426 sub DESTROY { print "destroyed\n" }
427 package main;
428 $x = any X; # to bump sv_objcount. IO objs aren't counted??
429 *f = afh X;
430 EXPECT
431 destroyed
432 destroyed
433 ########
434 BEGIN {
435   $| = 1;
436   $SIG{__WARN__} = sub {
437     eval { print $_[0] };
438     die "bar\n";
439   };
440   warn "foo\n";
441 }
442 EXPECT
443 foo
444 bar
445 BEGIN failed--compilation aborted at - line 8.
446 ########
447 package X;
448 @ISA='Y';
449 sub new {
450     my $class = shift;
451     my $self = { };
452     bless $self, $class;
453     my $init = shift;
454     $self->foo($init);
455     print "new", $init;
456     return $self;
457 }
458 sub DESTROY {
459     my $self = shift;
460     print "DESTROY", $self->foo;
461 }
462 package Y;
463 sub attribute {
464     my $self = shift;
465     my $var = shift;
466     if (@_ == 0) {
467         return $self->{$var};
468     } elsif (@_ == 1) {
469         $self->{$var} = shift;
470     }
471 }
472 sub AUTOLOAD {
473     $AUTOLOAD =~ /::([^:]+)$/;
474     my $method = $1;
475     splice @_, 1, 0, $method;
476     goto &attribute;
477 }
478 package main;
479 my $x = X->new(1);
480 for (2..3) {
481     my $y = X->new($_);
482     print $y->foo;
483 }
484 print $x->foo;
485 EXPECT
486 new1new22DESTROY2new33DESTROY31DESTROY1
487 ########
488 re();
489 sub re {
490     my $re = join '', eval 'qr/(??{ $obj->method })/';
491     $re;
492 }
493 EXPECT
494 ########
495 use strict;
496 my $foo = "ZZZ\n";
497 END { print $foo }
498 EXPECT
499 ZZZ
500 ########
501 eval '
502 use strict;
503 my $foo = "ZZZ\n";
504 END { print $foo }
505 ';
506 EXPECT
507 ZZZ
508 ########
509 -w
510 if (@ARGV) { print "" }
511 else {
512   if ($x == 0) { print "" } else { print $x }
513 }
514 EXPECT
515 Use of uninitialized value $x in numeric eq (==) at - line 3.
516 ########
517 $x = sub {};
518 foo();
519 sub foo { eval { return }; }
520 print "ok\n";
521 EXPECT
522 ok
523 ########
524 # moved to op/lc.t
525 EXPECT
526 ########
527 sub f { my $a = 1; my $b = 2; my $c = 3; my $d = 4; next }
528 my $x = "foo";
529 { f } continue { print $x, "\n" }
530 EXPECT
531 foo
532 ########
533 sub C () { 1 }
534 sub M { $_[0] = 2; }
535 eval "C";
536 M(C);
537 EXPECT
538 Modification of a read-only value attempted at - line 2.
539 ########
540 print qw(ab a\b a\\b);
541 EXPECT
542 aba\ba\b
543 ########
544 # lexicals declared after the myeval() definition should not be visible
545 # within it
546 sub myeval { eval $_[0] }
547 my $foo = "ok 2\n";
548 myeval('sub foo { local $foo = "ok 1\n"; print $foo; }');
549 die $@ if $@;
550 foo();
551 print $foo;
552 EXPECT
553 ok 1
554 ok 2
555 ########
556 # lexicals outside an eval"" should be visible inside subroutine definitions
557 # within it
558 eval <<'EOT'; die $@ if $@;
559 {
560     my $X = "ok\n";
561     eval 'sub Y { print $X }'; die $@ if $@;
562     Y();
563 }
564 EOT
565 EXPECT
566 ok
567 ########
568 # [ID 20001202.002] and change #8066 added 'at -e line 1';
569 # reversed again as a result of [perl #17763]
570 die qr(x)
571 EXPECT
572 (?^:x)
573 ########
574 # 20001210.003 mjd@plover.com
575 format REMITOUT_TOP =
576 FOO
577 .
578
579 format REMITOUT =
580 BAR
581 .
582
583 # This loop causes a segv in 5.6.0
584 for $lineno (1..61) {
585    write REMITOUT;
586 }
587
588 print "It's OK!";
589 EXPECT
590 It's OK!
591 ########
592 # Inaba Hiroto
593 reset;
594 if (0) {
595   if ("" =~ //) {
596   }
597 }
598 ########
599 # Nicholas Clark
600 $ENV{TERM} = 0;
601 reset;
602 // if 0;
603 ########
604 # Vadim Konovalov
605 use strict;
606 sub new_pmop($) {
607     my $pm = shift;
608     return eval "sub {shift=~/$pm/}";
609 }
610 new_pmop "abcdef"; reset;
611 new_pmop "abcdef"; reset;
612 new_pmop "abcdef"; reset;
613 new_pmop "abcdef"; reset;
614 ########
615 # David Dyck
616 # coredump in 5.7.1
617 close STDERR; die;
618 EXPECT
619 ########
620 # core dump in 20000716.007
621 -w
622 "x" =~ /(\G?x)?/;
623 ########
624 # Bug 20010515.004
625 my @h = 1 .. 10;
626 bad(@h);
627 sub bad {
628    undef @h;
629    print "O";
630    print for @_;
631    print "K";
632 }
633 EXPECT
634 OK
635 ########
636 # Bug 20010506.041
637 "abcd\x{1234}" =~ /(a)(b[c])(d+)?/i and print "ok\n";
638 EXPECT
639 ok
640 ########
641 my $foo = Bar->new();
642 my @dst;
643 END {
644     ($_ = "@dst") =~ s/\(0x.+?\)/(0x...)/;
645     print $_, "\n";
646 }
647 package Bar;
648 sub new {
649     my Bar $self = bless [], Bar;
650     eval '$self';
651     return $self;
652 }
653 sub DESTROY { 
654     push @dst, "$_[0]";
655 }
656 EXPECT
657 Bar=ARRAY(0x...)
658 ######## (?{...}) compilation bounces on PL_rs
659 -0
660 {
661   /(?{ $x })/;
662   # {
663 }
664 BEGIN { print "ok\n" }
665 EXPECT
666 ok
667 ######## scalar ref to file test operator segfaults on 5.6.1 [ID 20011127.155]
668 # This only happens if the filename is 11 characters or less.
669 $foo = \-f "blah";
670 print "ok" if ref $foo && !$$foo;
671 EXPECT
672 ok
673 ######## [ID 20011128.159] 'X' =~ /\X/ segfault in 5.6.1
674 print "ok" if 'X' =~ /\X/;
675 EXPECT
676 ok
677 ######## segfault in 5.6.1 within peep()
678 @a = (1..9);
679 @b = sort { @c = sort { @d = sort { 0 } @a; @d; } @a; } @a;
680 print join '', @a, "\n";
681 EXPECT
682 123456789
683 ######## example from Camel 5, ch. 15, pp.406 (with my)
684 # SKIP: ord "A" == 193 # EBCDIC
685 use strict;
686 use utf8;
687 my $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
688 $人++; # a child is born
689 print $人, "\n";
690 EXPECT
691 3
692 ######## example from Camel 5, ch. 15, pp.406 (with our)
693 # SKIP: ord "A" == 193 # EBCDIC
694 use strict;
695 use utf8;
696 our $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
697 $人++; # a child is born
698 print $人, "\n";
699 EXPECT
700 3
701 ######## example from Camel 5, ch. 15, pp.406 (with package vars)
702 # SKIP: ord "A" == 193 # EBCDIC
703 use utf8;
704 $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
705 $人++; # a child is born
706 print $人, "\n";
707 EXPECT
708 3
709 ######## example from Camel 5, ch. 15, pp.406 (with use vars)
710 # SKIP: ord "A" == 193 # EBCDIC
711 use strict;
712 use utf8;
713 use vars qw($人);
714 $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
715 $人++; # a child is born
716 print $人, "\n";
717 EXPECT
718 3
719 ########
720 # test that closures generated by eval"" hold on to the CV of the eval""
721 # for their entire lifetime
722 $code = eval q[
723   sub { eval '$x = "ok 1\n"'; }
724 ];
725 &{$code}();
726 print $x;
727 EXPECT
728 ok 1
729 ######## [ID 20020623.009] nested eval/sub segfaults
730 $eval = eval 'sub { eval "sub { %S }" }';
731 $eval->({});
732 ######## [perl #17951] Strange UTF error
733 -W
734 # From: "John Kodis" <kodis@mail630.gsfc.nasa.gov>
735 # Newsgroups: comp.lang.perl.moderated
736 # Subject: Strange UTF error
737 # Date: Fri, 11 Oct 2002 16:19:58 -0400
738 # Message-ID: <pan.2002.10.11.20.19.48.407190@mail630.gsfc.nasa.gov>
739 $_ = "foobar\n";
740 utf8::upgrade($_); # the original code used a UTF-8 locale (affects STDIN)
741 # matching is actually irrelevant: avoiding several dozen of these
742 # Illegal hexadecimal digit '   ' ignored at /usr/lib/perl5/5.8.0/utf8_heavy.pl line 152
743 # is what matters.
744 /^([[:digit:]]+)/;
745 EXPECT
746 ######## [perl #20667] unicode regex vs non-unicode regex
747 $toto = 'Hello';
748 $toto =~ /\w/; # this line provokes the problem!
749 $name = 'A B';
750 # utf8::upgrade($name) if @ARGV;
751 if ($name =~ /(\p{IsUpper}) (\p{IsUpper})/){
752     print "It's good! >$1< >$2<\n";
753 } else {
754     print "It's not good...\n";
755 }
756 EXPECT
757 It's good! >A< >B<
758 ######## [perl #8760] strangeness with utf8 and warn
759 $_="foo";utf8::upgrade($_);/bar/i,warn$_;
760 EXPECT
761 foo at - line 1.
762 ######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <200309010925.h819Pf0X011457@smtp3.ActiveState.com>
763 -lw
764 # Make sure the presence of the CORE::GLOBAL::glob typeglob does not affect
765 # whether File::Glob::csh_glob is called.
766 if ($^O eq 'VMS') {
767     # A pattern with a double quote in it is a syntax error to LIB$FIND_FILE
768     # Should we strip quotes in Perl_vms_start_glob the way csh_glob() does?
769     print "ok1\nok2\n";
770 }
771 else {
772     ++$INC{"File/Glob.pm"}; # prevent it from loading
773     my $called1 =
774     my $called2 = 0;
775     *File::Glob::csh_glob = sub { ++$called1 };
776     my $output1 = eval q{ glob(q(./"TEST")) };
777     undef *CORE::GLOBAL::glob; # but leave the typeglob itself there
778     ++$CORE::GLOBAL::glob if 0; # "used only once"
779     undef *File::Glob::csh_glob; # avoid redefinition warnings
780     *File::Glob::csh_glob = sub { ++$called2 };
781     my $output2 = eval q{ glob(q(./"TEST")) };
782     print "ok1" if $called1 eq $called2;
783     print "ok2" if $output1 eq $output2;
784 }
785 EXPECT
786 ok1
787 ok2
788 ######## "#75146: 27e904532594b7fb (fix for #23810) introduces a #regression"
789 use strict;
790
791 unshift @INC, sub {
792     my ($self, $fn) = @_;
793
794     (my $pkg = $fn) =~ s{/}{::}g;
795     $pkg =~ s{.pm$}{};
796
797     if ($pkg eq 'Credit') {
798         my $code = <<'EOC';
799 package Credit;
800
801 use NonsenseAndBalderdash;
802
803 1;
804 EOC
805         eval $code;
806         die "\$@ is $@";
807     }
808
809     #print STDERR "Generator: not one of mine, ignoring\n";
810     return undef;
811 };
812
813 # create load-on-demand new() constructors
814 {
815     package Credit;
816     sub new {
817         eval "use Credit";
818     }
819 };
820
821 eval {
822     my $credit = new Credit;
823 };
824
825 print "If you get here, you didn't crash\n";
826 EXPECT
827 If you get here, you didn't crash