Commit | Line | Data |
---|---|---|
2adfde11 GS |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | @INC = '.'; | |
6 | push @INC, '../lib'; | |
7 | } | |
8 | ||
9b3023bc | 9 | print "1..17\n"; |
2adfde11 GS |
10 | |
11 | # | |
12 | # This file tries to test builtin override using CORE::GLOBAL | |
13 | # | |
14 | my $dirsep = "/"; | |
15 | ||
16 | BEGIN { package Foo; *main::getlogin = sub { "kilroy"; } } | |
17 | ||
18 | print "not " unless getlogin eq "kilroy"; | |
19 | print "ok 1\n"; | |
20 | ||
21 | my $t = 42; | |
22 | BEGIN { *CORE::GLOBAL::time = sub () { $t; } } | |
23 | ||
24 | print "not " unless 45 == time + 3; | |
25 | print "ok 2\n"; | |
26 | ||
27 | # | |
28 | # require has special behaviour | |
29 | # | |
30 | my $r; | |
31 | BEGIN { *CORE::GLOBAL::require = sub { $r = shift; 1; } } | |
32 | ||
33 | require Foo; | |
34 | print "not " unless $r eq "Foo.pm"; | |
35 | print "ok 3\n"; | |
36 | ||
37 | require Foo::Bar; | |
38 | print "not " unless $r eq join($dirsep, "Foo", "Bar.pm"); | |
39 | print "ok 4\n"; | |
40 | ||
41 | require 'Foo'; | |
42 | print "not " unless $r eq "Foo"; | |
43 | print "ok 5\n"; | |
44 | ||
45 | require 5.6; | |
46 | print "not " unless $r eq "5.6"; | |
47 | print "ok 6\n"; | |
48 | ||
49 | require v5.6; | |
5c7bc39a | 50 | print "not " unless abs($r - 5.006) < 0.001 && $r eq "\x05\x06"; |
2adfde11 GS |
51 | print "ok 7\n"; |
52 | ||
53 | eval "use Foo"; | |
54 | print "not " unless $r eq "Foo.pm"; | |
55 | print "ok 8\n"; | |
56 | ||
57 | eval "use Foo::Bar"; | |
58 | print "not " unless $r eq join($dirsep, "Foo", "Bar.pm"); | |
59 | print "ok 9\n"; | |
60 | ||
61 | eval "use 5.6"; | |
62 | print "not " unless $r eq "5.6"; | |
63 | print "ok 10\n"; | |
b9f751c0 GS |
64 | |
65 | # localizing *CORE::GLOBAL::foo should revert to finding CORE::foo | |
66 | { | |
67 | local(*CORE::GLOBAL::require); | |
68 | $r = ''; | |
69 | eval "require NoNeXiSt;"; | |
ea071790 | 70 | print "not " if $r or $@ !~ /^Can't locate NoNeXiSt/i; |
b9f751c0 GS |
71 | print "ok 11\n"; |
72 | } | |
9b3023bc RGS |
73 | |
74 | # | |
75 | # readline() has special behaviour too | |
76 | # | |
77 | ||
78 | $r = 11; | |
79 | BEGIN { *CORE::GLOBAL::readline = sub (;*) { ++$r }; } | |
80 | print <FH> == 12 ? "ok 12\n" : "not ok 12\n"; | |
81 | print <$fh> == 13 ? "ok 13\n" : "not ok 13\n"; | |
82 | my $pad_fh; | |
83 | print <$pad_fh> == 14 ? "ok 14\n" : "not ok 14\n"; | |
84 | ||
85 | # Non-global readline() override | |
86 | BEGIN { *Rgs::readline = sub (;*) { --$r }; } | |
87 | package Rgs; | |
88 | print <FH> == 13 ? "ok 15\n" : "not ok 15\n"; | |
89 | print <$fh> == 12 ? "ok 16\n" : "not ok 16\n"; | |
90 | print <$pad_fh> == 11 ? "ok 17\n" : "not ok 17\n"; |