From 81689caa70f1ebdcb0b17a51c3e0742ee11ec130 Mon Sep 17 00:00:00 2001 From: Hugo van der Sanden Date: Mon, 7 Aug 2000 17:59:38 +0100 Subject: [PATCH] Make bless(REF, REF) a fatal error, add bless tests. Subject: [PATCH bleadperl-6530] bless, REF, and bless(REF, REF) Message-Id: <200008071559.QAA29541@crypt.compulink.co.uk> p4raw-id: //depot/perl@6539 --- MANIFEST | 1 + pod/perldiag.pod | 18 +++++++++ pp.c | 8 +++- sv.c | 5 ++- t/op/bless.t | 116 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 146 insertions(+), 2 deletions(-) create mode 100644 t/op/bless.t diff --git a/MANIFEST b/MANIFEST index 96eec9c..add7787 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1398,6 +1398,7 @@ t/op/assignwarn.t See if OP= operators warn correctly for undef targets t/op/attrs.t See if attributes on declarations work t/op/auto.t See if autoincrement et all work t/op/avhv.t See if pseudo-hashes work +t/op/bless.t See if bless works t/op/bop.t See if bitops work t/op/chars.t See if character escapes work t/op/chop.t See if chop works diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 3699b6e..fd082a1 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -182,6 +182,24 @@ spots. This is now heavily deprecated. must either both be scalars or both be lists. Otherwise Perl won't know which context to supply to the right side. +=item Attempt to bless into a reference + +(F) The CLASSNAME argument to the bless() operator is expected to be +the name of the package to bless the resulting object into. You've +supplied instead a reference to something: perhaps you wrote + + bless $self, $proto; + +when you intended + + bless $self, ref($proto) || $proto; + +If you actually want to bless into the stringified version +of the reference supplied, you need to stringify it yourself, for +example by: + + bless $self, "$proto"; + =item Attempt to free non-arena SV: 0x%lx (P internal) All SV objects are supposed to be allocated from arenas diff --git a/pp.c b/pp.c index 1621df5..c6bb0a5 100644 --- a/pp.c +++ b/pp.c @@ -561,7 +561,13 @@ PP(pp_bless) else { SV *ssv = POPs; STRLEN len; - char *ptr = SvPV(ssv,len); + char *ptr; + + if (ssv && SvGMAGICAL(ssv)) + mg_get(ssv); + if (SvROK(ssv)) + Perl_croak(aTHX_ "Attempt to bless into a reference"); + ptr = SvPV(ssv,len); if (ckWARN(WARN_MISC) && len == 0) Perl_warner(aTHX_ WARN_MISC, "Explicit blessing to '' (assuming package main)"); diff --git a/sv.c b/sv.c index 20b387c..382805f 100644 --- a/sv.c +++ b/sv.c @@ -2182,7 +2182,10 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) case SVt_PV: case SVt_PVIV: case SVt_PVNV: - case SVt_PVBM: s = "SCALAR"; break; + case SVt_PVBM: if (SvROK(sv)) + s = "REF"; + else + s = "SCALAR"; break; case SVt_PVLV: s = "LVALUE"; break; case SVt_PVAV: s = "ARRAY"; break; case SVt_PVHV: s = "HASH"; break; diff --git a/t/op/bless.t b/t/op/bless.t new file mode 100644 index 0000000..3d5d85d --- /dev/null +++ b/t/op/bless.t @@ -0,0 +1,116 @@ +#!./perl + +print "1..29\n"; + +BEGIN { + chdir 't' if -d 't'; + unshift @INC, '../lib' if -d '../lib'; +} + +sub expected { + my($object, $package, $type) = @_; + return "" if ( + ref($object) eq $package + && "$object" =~ /^\Q$package\E=(\w+)\(0x([0-9a-f]+)\)$/ + && $1 eq $type + && hex($2) == $object + ); + print "# $object $package $type\n"; + return "not "; +} + +# test blessing simple types + +$a1 = bless {}, "A"; +print expected($a1, "A", "HASH"), "ok 1\n"; +$b1 = bless [], "B"; +print expected($b1, "B", "ARRAY"), "ok 2\n"; +$c1 = bless \(map "$_", "test"), "C"; +print expected($c1, "C", "SCALAR"), "ok 3\n"; +$d1 = bless \*test, "D"; +print expected($d1, "D", "GLOB"), "ok 4\n"; +$e1 = bless sub { 1 }, "E"; +print expected($e1, "E", "CODE"), "ok 5\n"; +$f1 = bless \[], "F"; +print expected($f1, "F", "REF"), "ok 6\n"; +$g1 = bless \substr("test", 1, 2), "G"; +print expected($g1, "G", "LVALUE"), "ok 7\n"; + +# blessing ref to object doesn't modify object + +print expected(bless(\$a1, "F"), "F", "REF"), "ok 8\n"; +print expected($a1, "A", "HASH"), "ok 9\n"; + +# reblessing does modify object + +$a2 = bless $a1, "A2"; +print expected($a1, "A2", "HASH"), "ok 10\n"; + +# local and my +{ + local $a1 = bless $a1, "A3"; # should rebless outer $a1 + local $b1 = bless [], "B3"; + my $c1 = bless $c1, "C3"; # should rebless outer $c1 + my $d1 = bless \*test2, "D3"; + print expected($a1, "A3", "HASH"), "ok 11\n"; + print expected($b1, "B3", "ARRAY"), "ok 12\n"; + print expected($c1, "C3", "SCALAR"), "ok 13\n"; + print expected($d1, "D3", "GLOB"), "ok 14\n"; +} +print expected($a1, "A3", "HASH"), "ok 15\n"; +print expected($b1, "B", "ARRAY"), "ok 16\n"; +print expected($c1, "C3", "SCALAR"), "ok 17\n"; +print expected($d1, "D", "GLOB"), "ok 18\n"; + +# class is magic +"E" =~ /(.)/; +print expected(bless({}, $1), "E", "HASH"), "ok 19\n"; +{ + local $! = 1; + my $string = "$!"; + $! = 2; # attempt to avoid cached string + $! = 1; + print expected(bless({}, $!), $string, "HASH"), "ok 20\n"; + +# ref is ref to magic + { + { + package F; + sub test { ${$_[0]} eq $string or print "not " } + } + $! = 2; + $f1 = bless \$!, "F"; + $! = 1; + $f1->test; + print "ok 21\n"; + } +} + +# ref is magic +### example of magic variable that is a reference?? + +# no class, or empty string (with a warning), or undef (with two) +print expected(bless([]), 'main', "ARRAY"), "ok 22\n"; +{ + local $SIG{__WARN__} = sub { push @w, join '', @_ }; + local $^W = 1; + + $m = bless []; + print expected($m, 'main', "ARRAY"), "ok 23\n"; + print @w ? "not ok 24\t# @w\n" : "ok 24\n"; + + @w = (); + $m = bless [], ''; + print expected($m, 'main', "ARRAY"), "ok 25\n"; + print @w != 1 ? "not ok 26\t# @w\n" : "ok 26\n"; + + @w = (); + $m = bless [], undef; + print expected($m, 'main', "ARRAY"), "ok 27\n"; + print @w != 2 ? "not ok 28\t# @w\n" : "ok 28\n"; +} + +# class is a ref +$a1 = bless {}, "A4"; +$b1 = eval { bless {}, $a1 }; +print $@ ? "ok 29\n" : "not ok 29\t# $b1\n"; -- 2.7.4