This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
9d393264a17b9e97b555723478ff2936a2fa3b0e
[perl5.git] / t / op / bless.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require './test.pl';
7 }
8
9 plan (111);
10
11 sub expected {
12     my($object, $package, $type) = @_;
13     print "# $object $package $type\n";
14     is(ref($object), $package);
15     my $r = qr/^\Q$package\E=(\w+)\(0x([0-9a-f]+)\)$/;
16     like("$object", $r);
17     if ("$object" =~ $r) {
18         is($1, $type);
19         # in 64-bit platforms hex warns for 32+ -bit values
20         cmp_ok(do {no warnings 'portable'; hex($2)}, '==', $object);
21     }
22     else {
23         fail(); fail();
24     }
25 }
26
27 # test blessing simple types
28
29 $a1 = bless {}, "A";
30 expected($a1, "A", "HASH");
31 $b1 = bless [], "B";
32 expected($b1, "B", "ARRAY");
33 $c1 = bless \(map "$_", "test"), "C";
34 expected($c1, "C", "SCALAR");
35 our $test = "foo"; $d1 = bless \*test, "D";
36 expected($d1, "D", "GLOB");
37 $e1 = bless sub { 1 }, "E";
38 expected($e1, "E", "CODE");
39 $f1 = bless \[], "F";
40 expected($f1, "F", "REF");
41 $g1 = bless \substr("test", 1, 2), "G";
42 expected($g1, "G", "LVALUE");
43
44 # blessing ref to object doesn't modify object
45
46 expected(bless(\$a1, "F"), "F", "REF");
47 expected($a1, "A", "HASH");
48
49 # reblessing does modify object
50
51 bless $a1, "A2";
52 expected($a1, "A2", "HASH");
53
54 # local and my
55 {
56     local $a1 = bless $a1, "A3";        # should rebless outer $a1
57     local $b1 = bless [], "B3";
58     my $c1 = bless $c1, "C3";           # should rebless outer $c1
59     our $test2 = ""; my $d1 = bless \*test2, "D3";
60     expected($a1, "A3", "HASH");
61     expected($b1, "B3", "ARRAY");
62     expected($c1, "C3", "SCALAR");
63     expected($d1, "D3", "GLOB");
64 }
65 expected($a1, "A3", "HASH");
66 expected($b1, "B", "ARRAY");
67 expected($c1, "C3", "SCALAR");
68 expected($d1, "D", "GLOB");
69
70 # class is magic
71 "E" =~ /(.)/;
72 expected(bless({}, $1), "E", "HASH");
73 {
74     local $! = 1;
75     my $string = "$!";
76     $! = 2;     # attempt to avoid cached string
77     $! = 1;
78     expected(bless({}, $!), $string, "HASH");
79
80 # ref is ref to magic
81     {
82         {
83             package F;
84             sub test { main::is(${$_[0]}, $string) }
85         }
86         $! = 2;
87         $f1 = bless \$!, "F";
88         $! = 1;
89         $f1->test;
90     }
91 }
92
93 # ref is magic
94 ### example of magic variable that is a reference??
95
96 # no class, or empty string (with a warning), or undef (with two)
97 expected(bless([]), 'main', "ARRAY");
98 {
99     local $SIG{__WARN__} = sub { push @w, join '', @_ };
100     use warnings;
101
102     $m = bless [];
103     expected($m, 'main', "ARRAY");
104     is (scalar @w, 0);
105
106     @w = ();
107     $m = bless [], '';
108     expected($m, 'main', "ARRAY");
109     is (scalar @w, 1);
110
111     @w = ();
112     $m = bless [], undef;
113     expected($m, 'main', "ARRAY");
114     is (scalar @w, 2);
115 }
116
117 # class is a ref
118 $a1 = bless {}, "A4";
119 $b1 = eval { bless {}, $a1 };
120 isnt ($@, '', "class is a ref");
121
122 # class is an overloaded ref
123 {
124     package H4;
125     use overload '""' => sub { "C4" };
126 }
127 $h1 = bless {}, "H4";
128 $c4 = eval { bless \$test, $h1 };
129 is ($@, '', "class is an overloaded ref");
130 expected($c4, 'C4', "SCALAR");
131
132 {
133     my %h = 1..2;
134     my($k) = keys %h; 
135     my $x=\$k;
136     bless $x, 'pam';
137     is(ref $x, 'pam');
138
139     my $a = bless \(keys %h), 'zap';
140     is(ref $a, 'zap');
141 }
142
143 bless [], "main::";
144 ok(1, 'blessing into main:: does not crash'); # [perl #87388]
145
146 sub _117941 { package _117941; bless [] }
147 delete $::{"_117941::"};
148 eval { _117941() };
149 like $@, qr/^Attempt to bless into a freed package at /,
150         'bless with one arg when current stash is freed';
151
152 for(__PACKAGE__) {
153     eval { bless \$_ };
154     like $@, qr/^Modification of a read-only value attempted/,
155          'read-only COWs cannot be blessed';
156 }