| 1 | #!./perl |
| 2 | |
| 3 | print "1..7\n"; |
| 4 | my $test = 0; |
| 5 | |
| 6 | sub is { |
| 7 | my ($got, $expect, $name) = @_; |
| 8 | $test = $test + 1; |
| 9 | if (defined $got && $got eq $expect) { |
| 10 | print "ok $test - $name\n"; |
| 11 | return 1; |
| 12 | } |
| 13 | |
| 14 | print "not ok $test - $name\n"; |
| 15 | my @caller = caller(0); |
| 16 | print "# Failed test at $caller[1] line $caller[2]\n"; |
| 17 | if (defined $got) { |
| 18 | print "# Got '$got'\n"; |
| 19 | } else { |
| 20 | print "# Got undef\n"; |
| 21 | } |
| 22 | print "# Expected $expect\n"; |
| 23 | return; |
| 24 | } |
| 25 | |
| 26 | { |
| 27 | package TieAll; |
| 28 | # tie, track, and report what calls are made |
| 29 | my @calls; |
| 30 | sub AUTOLOAD { |
| 31 | for ($AUTOLOAD =~ /TieAll::(.*)/) { |
| 32 | if (/TIE/) { return bless {} } |
| 33 | elsif (/calls/) { return join ',', splice @calls } |
| 34 | else { |
| 35 | push @calls, $_; |
| 36 | # FETCHSIZE doesn't like undef |
| 37 | # if FIRSTKEY, see if NEXTKEY is also called |
| 38 | return 1 if /FETCHSIZE|FIRSTKEY/; |
| 39 | return; |
| 40 | } |
| 41 | } |
| 42 | } |
| 43 | } |
| 44 | |
| 45 | tie $x, 'TieAll'; |
| 46 | tie @x, 'TieAll'; |
| 47 | tie %x, 'TieAll'; |
| 48 | |
| 49 | {our $x;} |
| 50 | is(TieAll->calls, '', 'our $x has no runtime effect'); |
| 51 | |
| 52 | {our ($x);} |
| 53 | is(TieAll->calls, '', 'our ($x) has no runtime effect'); |
| 54 | |
| 55 | {our %x;} |
| 56 | is(TieAll->calls, '', 'our %x has no runtime effect'); |
| 57 | |
| 58 | {our (%x);} |
| 59 | is(TieAll->calls, '', 'our (%x) has no runtime effect'); |
| 60 | |
| 61 | {our @x;} |
| 62 | is(TieAll->calls, '', 'our @x has no runtime effect'); |
| 63 | |
| 64 | {our (@x);} |
| 65 | is(TieAll->calls, '', 'our (@x) has no runtime effect'); |
| 66 | |
| 67 | |
| 68 | $y = 1; |
| 69 | { |
| 70 | my $y = 2; |
| 71 | { |
| 72 | our $y = $y; |
| 73 | is($y, 2, 'our shouldnt be visible until introduced') |
| 74 | } |
| 75 | } |