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
CommitLineData
a0d0e21e
LW
1#!./perl
2
eeabcb2d
MS
3# ** DO NOT ADD ANY MORE TESTS HERE **
4# Instead, put the test in the appropriate test file and use the
f5cda331 5# fresh_perl_is()/fresh_perl_like() functions in t/test.pl.
eeabcb2d 6
f15b33d3 7# This is for tests that used to abnormally cause segfaults, and other nasty
c9beb3f5
MS
8# errors that might kill the interpreter and for some reason you can't
9# use an eval().
fb73857a 10
c9beb3f5
MS
11BEGIN {
12 chdir 't' if -d 't';
13 @INC = '../lib';
c59238f2 14 require './test.pl'; # for which_perl() etc
c9beb3f5
MS
15}
16
17use strict;
a0d0e21e 18
c59238f2 19my $Perl = which_perl();
b5fe401b 20
a0d0e21e
LW
21$|=1;
22
c9beb3f5
MS
23my @prgs = ();
24while(<DATA>) {
25 if(m/^#{8,}\s*(.*)/) {
26 push @prgs, ['', $1];
27 }
28 else {
29 $prgs[-1][0] .= $_;
30 }
31}
eeabcb2d 32plan tests => scalar @prgs;
a0d0e21e 33
c9beb3f5
MS
34foreach my $prog (@prgs) {
35 my($raw_prog, $name) = @$prog;
68dc0745 36
a0d0e21e 37 my $switch;
ccecb81f 38 if ($raw_prog =~ s/^\s*(-\w.*)\n//){
fb73857a 39 $switch = $1;
a0d0e21e 40 }
c9beb3f5
MS
41
42 my($prog,$expected) = split(/\nEXPECT\n/, $raw_prog);
ccecb81f
MS
43 $prog .= "\n";
44 $expected = '' unless defined $expected;
c9beb3f5 45
b97a373d
JH
46 if ($prog =~ /^\# SKIP: (.+)/m) {
47 if (eval $1) {
48 ok(1, "Skip: $1");
49 next;
50 }
51 }
52
f5cda331
JH
53 $expected =~ s/\n+$//;
54
ccecb81f 55 fresh_perl_is($prog, $expected, { switches => [$switch || ''] }, $name);
a0d0e21e
LW
56}
57
58__END__
2ace3117 59########
a6d8037e 60$a = ":="; @_ = split /($a)/o, "a:=b:=c"; print "@_"
44a8e56a
PP
61EXPECT
62a := b := c
63########
36477c24 64$cusp = ~0 ^ (~0 >> 1);
85e0ebd8 65use integer;
36477c24 66$, = " ";
85e0ebd8 67print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, 8 | (($cusp + 1) % 8 + 7), "!\n";
36477c24 68EXPECT
85e0ebd8 697 0 0 8 !
36477c24 70########
a0d0e21e
LW
71$foo=undef; $foo->go;
72EXPECT
72b5445b 73Can't call method "go" on an undefined value at - line 1.
a0d0e21e
LW
74########
75BEGIN
76 {
77 "foo";
78 }
79########
a0d0e21e
LW
80$array[128]=1
81########
82$x=0x0eabcd; print $x->ref;
83EXPECT
84Can't call method "ref" without a package or object reference at - line 1.
85########
648cac19 86chop ($str .= <DATA>);
a0d0e21e
LW
87########
88close ($banana);
89########
90$x=2;$y=3;$x<$y ? $x : $y += 23;print $x;
91EXPECT
9225
93########
84251760 94eval 'sub bar {print "In bar"}';
a0d0e21e 95########
7b903762 96system './perl -ne "print if eof" /dev/null'
a0d0e21e 97########
648cac19 98chop($file = <DATA>);
a0d0e21e
LW
99########
100package N;
101sub new {my ($obj,$n)=@_; bless \$n}
102$aa=new N 1;
103$aa=12345;
104print $aa;
105EXPECT
10612345
107########
a0d0e21e
LW
108$_="foo";
109printf(STDOUT "%s\n", $_);
110EXPECT
111foo
112########
113push(@a, 1, 2, 3,)
114########
115quotemeta ""
116########
117for ("ABCDE") {
118 &sub;
119s/./&sub($&)/eg;
120print;}
121sub sub {local($_) = @_;
122$_ x 4;}
123EXPECT
124Modification of a read-only value attempted at - line 3.
125########
126package FOO;sub new {bless {FOO => BAR}};
127package main;
128use strict vars;
129my $self = new FOO;
130print $$self{FOO};
131EXPECT
132BAR
133########
134$_="foo";
135s/.{1}//s;
136print;
137EXPECT
138oo
139########
140print scalar ("foo","bar")
141EXPECT
142bar
143########
144sub by_number { $a <=> $b; };# inline function for sort below
145$as_ary{0}="a0";
146@ordered_array=sort by_number keys(%as_ary);
147########
148sub NewShell
149{
150 local($Host) = @_;
151 my($m2) = $#Shells++;
152 $Shells[$m2]{HOST} = $Host;
153 return $m2;
154}
155
156sub 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
178eval 'tie @h, FAKEARRAY, fred' ;
179tie @h, FAKEARRAY, fred ;
180EXPECT
181TIEARRAY FAKEARRAY fred
182TIEARRAY FAKEARRAY fred
183DESTROY
184########
185BEGIN { die "phooey\n" }
186EXPECT
187phooey
188BEGIN failed--compilation aborted at - line 1.
189########
190BEGIN { 1/$zero }
191EXPECT
192Illegal division by zero at - line 1.
193BEGIN failed--compilation aborted at - line 1.
194########
195BEGIN { undef = 0 }
196EXPECT
197Modification of a read-only value attempted at - line 1.
198BEGIN failed--compilation aborted at - line 1.
a7adf1f0
PP
199########
200{
201 package foo;
202 sub PRINT {
203 shift;
204 print join(' ', reverse @_)."\n";
205 }
46fc3d4c
PP
206 sub PRINTF {
207 shift;
208 my $fmt = shift;
209 print sprintf($fmt, @_)."\n";
210 }
a7adf1f0
PP
211 sub TIEHANDLE {
212 bless {}, shift;
213 }
58f51617
SV
214 sub READLINE {
215 "Out of inspiration";
216 }
a7adf1f0
PP
217 sub DESTROY {
218 print "and destroyed as well\n";
2ae324a7
PP
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 }
a7adf1f0
PP
230}
231{
232 local(*FOO);
233 tie(*FOO,'foo');
234 print FOO "sentence.", "reversed", "a", "is", "This";
58f51617 235 print "-- ", <FOO>, " --\n";
2ae324a7
PP
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";
46fc3d4c 241 printf "%s is number %d\n", "Perl", 1;
a7adf1f0
PP
242}
243EXPECT
244This is a reversed sentence.
58f51617 245-- Out of inspiration --
2ae324a7
PP
246foo->can(READ)(string 10 1)
247Don't GETC, Get Perl
46fc3d4c 248Perl is number 1
a7adf1f0 249and destroyed as well
a6006777
PP
250########
251my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n"
252EXPECT
2532 2 2
254########
8ff950ac 255# used to attach defelem magic to all immortal values,
8b530633
GA
256# which made restore of local $_ fail.
257foo(2>1);
258sub foo { bar() for @_; }
259sub bar { local $_; }
260print "ok\n";
261EXPECT
262ok
263########
a6006777
PP
264@a = ($a, $b, $c, $d) = (5, 6);
265print "ok\n"
266 if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]);
267EXPECT
268ok
269########
270print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000);
271EXPECT
272ok
273########
8ebc5c01 274print "ok\n" if ("\0" lt "\xFF");
a6006777
PP
275EXPECT
276ok
277########
7b903762 278open(H,'run/fresh_perl.t'); # must be in the 't' directory
a6006777
PP
279stat(H);
280print "ok\n" if (-e _ and -f _ and -r _);
281EXPECT
282ok
283########
284sub thing { 0 || return qw(now is the time) }
285print thing(), "\n";
286EXPECT
287nowisthetime
288########
289$ren = 'joy';
290$stimpy = 'happy';
291{ local $main::{ren} = *stimpy; print $ren, ' ' }
292print $ren, "\n";
293EXPECT
294happy joy
295########
296$stimpy = 'happy';
297{ local $main::{ren} = *stimpy; print ${'ren'}, ' ' }
298print +(defined(${'ren'}) ? 'oops' : 'joy'), "\n";
299EXPECT
300happy joy
301########
302package p;
303sub func { print 'really ' unless wantarray; 'p' }
304sub groovy { 'groovy' }
305package main;
306print p::func()->groovy(), "\n"
307EXPECT
308really groovy
309########
d53f8f1c
HS
310@list = ([ 'one', 1 ], [ 'two', 2 ]);
311sub func { $num = shift; (grep $_->[1] == $num, @list)[0] }
312print scalar(map &func($_), 1 .. 3), " ",
313 scalar(map scalar &func($_), 1 .. 3), "\n";
314EXPECT
3152 3
316########
44a8e56a
PP
317($k, $s) = qw(x 0);
318@{$h{$k}} = qw(1 2 4);
319for (@{$h{$k}}) { $s += $_; delete $h{$k} if ($_ == 2) }
320print "bogus\n" unless $s == 7;
321########
322my $a = 'outer';
323eval q[ my $a = 'inner'; eval q[ print "$a " ] ];
324eval { my $x = 'peace'; eval q[ print "$x\n" ] }
325EXPECT
326inner peace
774d564b
PP
327########
328-w
329$| = 1;
330sub foo {
331 print "In foo1\n";
332 eval 'sub foo { print "In foo2\n" }';
333 print "Exiting foo1\n";
334}
335foo;
336foo;
337EXPECT
338In foo1
339Subroutine foo redefined at (eval 1) line 1.
340Exiting foo1
341In foo2
342########
343$s = 0;
344map {#this newline here tickles the bug
345$s += $_} (1,2,4);
346print "eat flaming death\n" unless ($s == 7);
1ca7b98a 347########
a6d8037e 348sub foo { local $_ = shift; @_ = split; @_ }
1ca7b98a
CS
349@x = foo(' x y z ');
350print "you die joe!\n" unless "@x" eq 'x y z';
c277df42
IZ
351########
352/(?{"{"})/ # Check it outside of eval too
353EXPECT
7253e4e3 354Sequence (?{...}) not terminated or not {}-balanced in regex; marked by <-- HERE in m/(?{ <-- HERE "{"})/ at - line 1.
c277df42
IZ
355########
356/(?{"{"}})/ # Check it outside of eval too
357EXPECT
d98d5fff 358Unmatched right curly bracket at (re_eval 1) line 1, at end of line
c277df42 359syntax error at (re_eval 1) line 1, near ""{"}"
2cd61cdb 360Compilation failed in regexp at - line 1.
0da4822f 361########
ff689196 362BEGIN { @ARGV = qw(a b c d e) }
0da4822f
GS
363BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" }
364END { print "end <",shift,">\nargv <@ARGV>\n" }
365INIT { print "init <",shift,">\n" }
7d30b5c4 366CHECK { print "check <",shift,">\n" }
0da4822f 367EXPECT
ff689196 368argv <a b c d e>
0da4822f 369begin <a>
7d30b5c4 370check <b>
ff689196
GS
371init <c>
372end <d>
373argv <e>
4599a1de 374########
3500f679
RS
375-l
376# fdopen from a system descriptor to a system descriptor used to close
377# the former.
378open STDERR, '>&=STDOUT' or die $!;
75642110
NC
379select STDOUT; $| = 1; print fileno STDOUT or die $!;
380select STDERR; $| = 1; print fileno STDERR or die $!;
3500f679
RS
381EXPECT
3821
3832
384########
20408e3c
GS
385-w
386sub testme { my $a = "test"; { local $a = "new test"; print $a }}
387EXPECT
ccecb81f 388Can't localize lexical variable $a at - line 1.
20408e3c 389########
51ae5c03
JPC
390package X;
391sub ascalar { my $r; bless \$r }
392sub DESTROY { print "destroyed\n" };
393package main;
394*s = ascalar X;
395EXPECT
396destroyed
397########
398package X;
399sub anarray { bless [] }
400sub DESTROY { print "destroyed\n" };
401package main;
402*a = anarray X;
403EXPECT
404destroyed
405########
406package X;
407sub ahash { bless {} }
408sub DESTROY { print "destroyed\n" };
409package main;
410*h = ahash X;
411EXPECT
412destroyed
413########
414package X;
415sub aclosure { my $x; bless sub { ++$x } }
416sub DESTROY { print "destroyed\n" };
417package main;
418*c = aclosure X;
419EXPECT
420destroyed
421########
422package X;
423sub any { bless {} }
424my $f = "FH000"; # just to thwart any future optimisations
ded8aa31 425sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r }
51ae5c03
JPC
426sub DESTROY { print "destroyed\n" }
427package main;
428$x = any X; # to bump sv_objcount. IO objs aren't counted??
429*f = afh X;
430EXPECT
431destroyed
432destroyed
433########
ebf99b04
GS
434BEGIN {
435 $| = 1;
436 $SIG{__WARN__} = sub {
437 eval { print $_[0] };
438 die "bar\n";
439 };
440 warn "foo\n";
441}
442EXPECT
443foo
444bar
445BEGIN failed--compilation aborted at - line 8.
8feb4e9f
JH
446########
447package X;
448@ISA='Y';
449sub 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}
458sub DESTROY {
459 my $self = shift;
460 print "DESTROY", $self->foo;
461}
462package Y;
463sub 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}
472sub AUTOLOAD {
473 $AUTOLOAD =~ /::([^:]+)$/;
474 my $method = $1;
475 splice @_, 1, 0, $method;
476 goto &attribute;
477}
478package main;
479my $x = X->new(1);
480for (2..3) {
481 my $y = X->new($_);
482 print $y->foo;
483}
484print $x->foo;
485EXPECT
486new1new22DESTROY2new33DESTROY31DESTROY1
dfad63ad
HS
487########
488re();
489sub re {
14455d6c 490 my $re = join '', eval 'qr/(??{ $obj->method })/';
dfad63ad
HS
491 $re;
492}
493EXPECT
1aff0e91
GS
494########
495use strict;
496my $foo = "ZZZ\n";
497END { print $foo }
498EXPECT
499ZZZ
500########
501eval '
502use strict;
503my $foo = "ZZZ\n";
504END { print $foo }
505';
506EXPECT
507ZZZ
7399586d
HS
508########
509-w
510if (@ARGV) { print "" }
511else {
512 if ($x == 0) { print "" } else { print $x }
513}
514EXPECT
ccecb81f 515Use of uninitialized value $x in numeric eq (==) at - line 3.
1d76a5c3
GS
516########
517$x = sub {};
518foo();
519sub foo { eval { return }; }
520print "ok\n";
521EXPECT
522ok
07447971 523########
b0f2b690 524# moved to op/lc.t
07447971 525EXPECT
92d29cee
JH
526########
527sub f { my $a = 1; my $b = 2; my $c = 3; my $d = 4; next }
528my $x = "foo";
529{ f } continue { print $x, "\n" }
530EXPECT
531foo
6a7129a1
GS
532########
533sub C () { 1 }
534sub M { $_[0] = 2; }
535eval "C";
536M(C);
537EXPECT
538Modification of a read-only value attempted at - line 2.
00c29ff8
TH
539########
540print qw(ab a\b a\\b);
541EXPECT
542aba\ba\b
dd8482fc 543########
c71fccf1
JH
544# lexicals declared after the myeval() definition should not be visible
545# within it
546sub myeval { eval $_[0] }
547my $foo = "ok 2\n";
548myeval('sub foo { local $foo = "ok 1\n"; print $foo; }');
549die $@ if $@;
550foo();
551print $foo;
552EXPECT
553ok 1
554ok 2
555########
2090ab20
JH
556# lexicals outside an eval"" should be visible inside subroutine definitions
557# within it
558eval <<'EOT'; die $@ if $@;
559{
560 my $X = "ok\n";
561 eval 'sub Y { print $X }'; die $@ if $@;
562 Y();
563}
564EOT
565EXPECT
566ok
567########
bf12611a
HS
568# [ID 20001202.002] and change #8066 added 'at -e line 1';
569# reversed again as a result of [perl #17763]
b927783e
JH
570die qr(x)
571EXPECT
fb85c044 572(?^:x)
b927783e 573########
7ef822cd
JH
574# 20001210.003 mjd@plover.com
575format REMITOUT_TOP =
576FOO
577.
578
579format REMITOUT =
580BAR
581.
582
583# This loop causes a segv in 5.6.0
584for $lineno (1..61) {
585 write REMITOUT;
586}
587
588print "It's OK!";
589EXPECT
590It's OK!
cb55de95
JH
591########
592# Inaba Hiroto
593reset;
594if (0) {
595 if ("" =~ //) {
596 }
597}
598########
599# Nicholas Clark
600$ENV{TERM} = 0;
601reset;
602// if 0;
603########
604# Vadim Konovalov
605use strict;
606sub new_pmop($) {
607 my $pm = shift;
608 return eval "sub {shift=~/$pm/}";
609}
610new_pmop "abcdef"; reset;
611new_pmop "abcdef"; reset;
612new_pmop "abcdef"; reset;
613new_pmop "abcdef"; reset;
880649cd
JH
614########
615# David Dyck
616# coredump in 5.7.1
617close STDERR; die;
618EXPECT
dba9804b 619########
ccecb81f 620# core dump in 20000716.007
99799961 621-w
ccecb81f 622"x" =~ /(\G?x)?/;
99799961 623########
dba9804b
BS
624# Bug 20010515.004
625my @h = 1 .. 10;
626bad(@h);
627sub bad {
628 undef @h;
629 print "O";
630 print for @_;
631 print "K";
632}
633EXPECT
634OK
97b9a4cb
HS
635########
636# Bug 20010506.041
637"abcd\x{1234}" =~ /(a)(b[c])(d+)?/i and print "ok\n";
638EXPECT
639ok
0b490c9c 640########
08b362fd
JH
641my $foo = Bar->new();
642my @dst;
643END {
644 ($_ = "@dst") =~ s/\(0x.+?\)/(0x...)/;
645 print $_, "\n";
646}
647package Bar;
648sub new {
649 my Bar $self = bless [], Bar;
650 eval '$self';
651 return $self;
652}
653sub DESTROY {
654 push @dst, "$_[0]";
655}
656EXPECT
657Bar=ARRAY(0x...)
8bfdd7d9
HS
658######## (?{...}) compilation bounces on PL_rs
659-0
660{
661 /(?{ $x })/;
662 # {
663}
664BEGIN { print "ok\n" }
665EXPECT
666ok
80071be7
MS
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";
670print "ok" if ref $foo && !$$foo;
671EXPECT
672ok
15a59b2d
MS
673######## [ID 20011128.159] 'X' =~ /\X/ segfault in 5.6.1
674print "ok" if 'X' =~ /\X/;
675EXPECT
676ok
f9dc862f
HS
677######## segfault in 5.6.1 within peep()
678@a = (1..9);
679@b = sort { @c = sort { @d = sort { 0 } @a; @d; } @a; } @a;
680print join '', @a, "\n";
681EXPECT
682123456789
82686b01 683######## example from Camel 5, ch. 15, pp.406 (with my)
b97a373d 684# SKIP: ord "A" == 193 # EBCDIC
82686b01
JH
685use strict;
686use utf8;
687my $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
688$人++; # a child is born
689print $人, "\n";
690EXPECT
6913
692######## example from Camel 5, ch. 15, pp.406 (with our)
b97a373d 693# SKIP: ord "A" == 193 # EBCDIC
82686b01
JH
694use strict;
695use utf8;
696our $人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
697$人++; # a child is born
698print $人, "\n";
699EXPECT
7003
701######## example from Camel 5, ch. 15, pp.406 (with package vars)
b97a373d 702# SKIP: ord "A" == 193 # EBCDIC
82686b01
JH
703use utf8;
704$人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
705$人++; # a child is born
706print $人, "\n";
707EXPECT
7083
08cd7fd6
JH
709######## example from Camel 5, ch. 15, pp.406 (with use vars)
710# SKIP: ord "A" == 193 # EBCDIC
711use strict;
712use utf8;
713use vars qw($人);
714$人 = 2; # 0xe4 0xba 0xba: U+4eba, "human" in CJK ideograph
715$人++; # a child is born
716print $人, "\n";
717EXPECT
7183
650375fe
JH
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}();
726print $x;
727EXPECT
728ok 1
729######## [ID 20020623.009] nested eval/sub segfaults
730$eval = eval 'sub { eval "sub { %S }" }';
731$eval->({});
df68b396
JH
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";
740utf8::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:]]+)/;
745EXPECT
d12e50cf
JH
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;
751if ($name =~ /(\p{IsUpper}) (\p{IsUpper})/){
752 print "It's good! >$1< >$2<\n";
753} else {
754 print "It's not good...\n";
755}
756EXPECT
757It's good! >A< >B<
93f09d7b 758######## [perl #8760] strangeness with utf8 and warn
4f49a093
JH
759$_="foo";utf8::upgrade($_);/bar/i,warn$_;
760EXPECT
761foo at - line 1.
f444d496
GS
762######## glob() bug Mon, 01 Sep 2003 02:25:41 -0700 <200309010925.h819Pf0X011457@smtp3.ActiveState.com>
763-lw
1bb8785a
FC
764# Make sure the presence of the CORE::GLOBAL::glob typeglob does not affect
765# whether File::Glob::csh_glob is called.
ec6b7b2d
CB
766if ($^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}
771else {
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}
1bb8785a
FC
785EXPECT
786ok1
787ok2
c86ffc32
DM
788######## "#75146: 27e904532594b7fb (fix for #23810) introduces a #regression"
789use strict;
790
791unshift @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';
799package Credit;
800
801use NonsenseAndBalderdash;
802
8031;
804EOC
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
821eval {
822 my $credit = new Credit;
823};
824
825print "If you get here, you didn't crash\n";
826EXPECT
827If you get here, you didn't crash