summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorFlorian Ragwitz <rafl@debian.org>2010-09-05 20:30:54 +0200
committerFlorian Ragwitz <rafl@debian.org>2010-09-16 15:53:51 +0200
commitcba0b53980b869e0b7ceaf81166f64dd51ca7c12 (patch)
tree8fa8c1318d55885a22b91adfc0ee7c4048cb1ff2
parentc99e91e919b4bb89bab7829a9026ee01b1fff2a1 (diff)
downloadperl-cba0b53980b869e0b7ceaf81166f64dd51ca7c12.tar.gz
Back out the mauve module and related changes
It's was intended as a temporary namespace only, and we really don't want to ship it in any release until we've figured out what it should really look like. This reverts commit 05c0d6bbe3ec5cc9af99d105b8648ad02ed7cc95, "add sv_reftype_len() and make sv_reftype() be a wrapper for it" commit 792477b9c2e4c75cb03d07bd6d25dc7e1fdf448e, "create the "mauve" temporary namespace for things like reftype" commit 8df6b97c1de8326d50ac9c8cae4bf716393b45bb, "mauve.t needs access to %Config, make sure it's available" commit cfe9162d0d593cd12a979c73df82c7509b324343, "use more efficient sv_reftype_len() interface" and commit 47b13905e23c2a72acdde8bb4669e25e5eaefec4 "add more tests to lib/mauve.t so it tests also that mauve::reftype can return "LVALUE"" There's a `mauve' branch still containing all the code for the temporary mauve namespace. That should be used to work on it until it's mostly ready to be released, and only then merged to blead. Alternatively, it should be deleted if another way to provide mauve's features in the core is found.
-rw-r--r--MANIFEST2
-rwxr-xr-xPorting/Maintainers.pl2
-rw-r--r--embed.fnc1
-rw-r--r--embed.h2
-rw-r--r--global.sym1
-rw-r--r--lib/mauve.pm161
-rw-r--r--lib/mauve.t380
-rw-r--r--pp.c5
-rw-r--r--proto.h7
-rw-r--r--sv.c169
-rw-r--r--universal.c110
11 files changed, 28 insertions, 812 deletions
diff --git a/MANIFEST b/MANIFEST
index 54927539e8..c19638e6b5 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3612,8 +3612,6 @@ lib/less.t See if less support works
lib/locale.pm For "use locale"
lib/locale.t See if locale support works
lib/look.pl A "look" equivalent
-lib/mauve.pm Temporary namespace for new built in "reftype" pseduo keyword (and friends)
-lib/mauve.t tests for "mauve" namespace for new built in "reftype" pseduo keyword (and friends)
lib/Net/hostent.pm By-name interface to Perl's builtin gethost*
lib/Net/hostent.t See if Net::hostent works
lib/Net/netent.pm By-name interface to Perl's builtin getnet*
diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index c27b6ebb9c..926af50a26 100755
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -914,6 +914,7 @@ use File::Glob qw(:case);
],
'UPSTREAM' => 'cpan',
},
+
'Memoize' =>
{
'MAINTAINER' => 'mjd',
@@ -1816,7 +1817,6 @@ use File::Glob qw(:case);
lib/less.{pm,t}
lib/locale.{pm,t}
lib/look.pl
- lib/mauve.{pm,t}
lib/open.{pm,t}
lib/open2.pl
lib/open3.pl
diff --git a/embed.fnc b/embed.fnc
index 0f666d7e9b..995f8f0e82 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1208,7 +1208,6 @@ Apd |char* |sv_pvbyten_force|NN SV *const sv|NULLOK STRLEN *const lp
Apd |char* |sv_recode_to_utf8 |NN SV* sv|NN SV *encoding
Apd |bool |sv_cat_decode |NN SV* dsv|NN SV *encoding|NN SV *ssv|NN int *offset \
|NN char* tstr|int tlen
-ApdR |const char* |sv_reftype_len |NN const SV *const sv|const int ob|NN STRLEN *const ret_len
ApdR |const char* |sv_reftype |NN const SV *const sv|const int ob
Apd |void |sv_replace |NN SV *const sv|NN SV *const nsv
Apd |void |sv_report_used
diff --git a/embed.h b/embed.h
index 9e43d480a0..e498de7390 100644
--- a/embed.h
+++ b/embed.h
@@ -1003,7 +1003,6 @@
#define sv_pvbyten_force Perl_sv_pvbyten_force
#define sv_recode_to_utf8 Perl_sv_recode_to_utf8
#define sv_cat_decode Perl_sv_cat_decode
-#define sv_reftype_len Perl_sv_reftype_len
#define sv_reftype Perl_sv_reftype
#define sv_replace Perl_sv_replace
#define sv_report_used Perl_sv_report_used
@@ -3459,7 +3458,6 @@
#define sv_pvbyten_force(a,b) Perl_sv_pvbyten_force(aTHX_ a,b)
#define sv_recode_to_utf8(a,b) Perl_sv_recode_to_utf8(aTHX_ a,b)
#define sv_cat_decode(a,b,c,d,e,f) Perl_sv_cat_decode(aTHX_ a,b,c,d,e,f)
-#define sv_reftype_len(a,b,c) Perl_sv_reftype_len(aTHX_ a,b,c)
#define sv_reftype(a,b) Perl_sv_reftype(aTHX_ a,b)
#define sv_replace(a,b) Perl_sv_replace(aTHX_ a,b)
#define sv_report_used() Perl_sv_report_used(aTHX)
diff --git a/global.sym b/global.sym
index 4ff4ea0fdd..4670985ffb 100644
--- a/global.sym
+++ b/global.sym
@@ -596,7 +596,6 @@ Perl_sv_pvutf8n_force
Perl_sv_pvbyten_force
Perl_sv_recode_to_utf8
Perl_sv_cat_decode
-Perl_sv_reftype_len
Perl_sv_reftype
Perl_sv_replace
Perl_sv_report_used
diff --git a/lib/mauve.pm b/lib/mauve.pm
deleted file mode 100644
index e94a412940..0000000000
--- a/lib/mauve.pm
+++ /dev/null
@@ -1,161 +0,0 @@
-package mauve;
-use base qw/Exporter/;
-@EXPORT_OK=qw(reftype refaddr blessed isweak weaken);
-1;
-# mauve routines are installed from universal.c
-__END__
-
-=head1 NAME
-
-mauve - utilities for introspecting properties of scalar variables
-
-=head1 SYNOPSIS
-
- # mauve routines are "always loaded"
- my $type = mauve::reftype($var);
- my $addr = mauve::refaddr($var);
- my $class = mauve::blessed($var);
-
- my $ref= \@foo;
- mauve::weaken($ref);
- my $isweak= mauve::isweak($ref);
-
- # import mauve routines into your namespace
- use mauve qw(reftype refaddr blessed weaken isweak);
-
-=head1 DESCRIPTION
-
-The C<mauve> namespace is a perl internals reserved namespace for utility
-routines relating to scalar variables. These routines are closely related
-to the like named routines in Scalar::Util except that they are always loaded
-and where it makes sense, return FALSE instead of 'undef'.
-
-=head2 reftype SCALAR
-
-Returns false if the argument is not a reference, otherwise returns the
-reference type, which will be one of the following values:
-
-=over 4
-
-=item VSTRING
-
-Has special v-string magic
-
-=item REF
-
-Is a reference to another ref (C<< $$ref >>)
-
-=item SCALAR
-
-Is a reference to a scalar (C<< $$scalar >>)
-
-=item LVALUE
-
-An lvalue reference - B<NOTE>, tied lvalues appear to be of type C<SCALAR>
-for backwards compatibility reasons
-
-=item ARRAY
-
-An array reference (C<< @$array >>)
-
-=item HASH
-
-A hash reference (C<< %$hash >>)
-
-=item CODE
-
-A subroutine reference (C<< $code->() >>)
-
-=item GLOB
-
-A reference to a glob (C<< *$glob >>)
-
-=item FORMAT
-
-A format reference (C<< *IO{FORMAT} >>)
-
-=item IO
-
-An IO reference (C<< *STDOUT{IO} >>)
-
-=item BIND
-
-A bind reference
-
-=item REGEXP
-
-An executable regular expression (C<< qr/../ >>)
-
-=item UNKNOWN
-
-This should never be seen
-
-=back
-
-=head2 refaddr SCALAR
-
-Returns false if the argument is not a reference, otherwise returns the
-address of the reference as an unsigned integer.
-
-=head2 blessed SCALAR
-
-Returns false if the argument is not a blessed reference, otherwise returns
-the package name the reference was blessed into.
-
-=head2 weaken REF
-
-REF will be turned into a weak reference. This means that it will not
-hold a reference count on the object it references. Also when the reference
-count on that object reaches zero, REF will be set to undef.
-
-This is useful for keeping copies of references , but you don't want to
-prevent the object being DESTROY-ed at its usual time.
-
- {
- my $var;
- $ref = \$var;
- weaken($ref); # Make $ref a weak reference
- }
- # $ref is now undef
-
-Note that if you take a copy of a scalar with a weakened reference,
-the copy will be a strong reference.
-
- my $var;
- my $foo = \$var;
- weaken($foo); # Make $foo a weak reference
- my $bar = $foo; # $bar is now a strong reference
-
-This may be less obvious in other situations, such as C<grep()>, for instance
-when grepping through a list of weakened references to objects that may have
-been destroyed already:
-
- @object = grep { defined } @object;
-
-This will indeed remove all references to destroyed objects, but the remaining
-references to objects will be strong, causing the remaining objects to never
-be destroyed because there is now always a strong reference to them in the
-@object array.
-
-=head2 isweak EXPR
-
-If EXPR is a scalar which is a weak reference the result is true.
-
- $ref = \$foo;
- $weak = isweak($ref); # false
- weaken($ref);
- $weak = isweak($ref); # true
-
-B<NOTE>: Copying a weak reference creates a normal, strong, reference.
-
- $copy = $ref;
- $weak = isweak($copy); # false
-
-=head1 SEE ALSO
-
-L<Scalar::Util>
-
-=cut
-
-
-
diff --git a/lib/mauve.t b/lib/mauve.t
deleted file mode 100644
index c956c07b6f..0000000000
--- a/lib/mauve.t
+++ /dev/null
@@ -1,380 +0,0 @@
-#!./perl
-
-use Test::More tests => 32 + 60 + 12 + 22;
-
-use mauve qw(refaddr reftype blessed weaken isweak);
-use vars qw($t $y $x *F $v $r $never_blessed);
-use Symbol qw(gensym);
-use Config;
-
-# Ensure we do not trigger any tied methods
-tie *F, 'MyTie';
-
-my $i = 1;
-foreach $v (undef, 10, 'string') {
- is(refaddr($v), !1, "not " . (defined($v) ? "'$v'" : "undef"));
-}
-
-foreach $r ({}, \$t, [], \*F, sub {}) {
- my $n = "refaddr $r";
- $n =~ /0x(\w+)/;
- my $addr = do { local $^W; hex $1 };
- my $before = ref($r);
- is( refaddr($r), $addr, $n);
- is( ref($r), $before, $n);
-
- my $obj = bless $r, 'FooBar';
- is( refaddr($r), $addr, "blessed with overload $n");
- is( ref($r), 'FooBar', $n);
-}
-
-{
- my $z = '77';
- my $y = \$z;
- my $a = '78';
- my $b = \$a;
- tie my %x, 'Hash3', {};
- $x{$y} = 22;
- $x{$b} = 23;
- my $xy = $x{$y};
- my $xb = $x{$b};
- ok(ref($x{$y}));
- ok(ref($x{$b}));
- ok(refaddr($xy) == refaddr($y));
- ok(refaddr($xb) == refaddr($b));
- ok(refaddr($x{$y}));
- ok(refaddr($x{$b}));
-}
-{
- my $z = bless {}, '0';
- ok(refaddr($z));
- @{"0::ISA"} = qw(FooBar);
- my $a = {};
- my $r = refaddr($a);
- $z = bless $a, '0';
- ok(refaddr($z) > 10);
- is(refaddr($z),$r,"foo");
-}
-{
-
- my $HAVE_RE = 5.011 <= $];
- my $RE = $HAVE_RE ? 'REGEXP' : 'SCALAR';
- my($m,@m,%m);
- format STDOUT = # do not indent the lone dot in next line
-.
- @test = (
- [ 0, !1, 1, 'number' ],
- [ 0, !1, 'A', 'string' ],
- [ 0, !1, *::t, 'glob' ],
- [ 1, HASH => {}, 'HASH ref' ],
- [ 1, HASH => \%::t, 'HASH ref' ],
- [ 1, HASH => \%m, 'HASH ref' ],
- [ 1, ARRAY => [], 'ARRAY ref' ],
- [ 1, ARRAY => \@::t, 'ARRAY ref' ],
- [ 1, ARRAY => \@m, 'ARRAY ref' ],
- [ 0, SCALAR => \1, 'SCALAR ref' ],
- [ 1, SCALAR => \$t, 'SCALAR ref' ],
- [ 1, SCALAR => \$m, 'SCALAR ref' ],
- [ 1, REF => \(\$t), 'REF ref' ],
- [ 1, REF => \[], 'REF ref' ],
- [ 1, LVALUE => \substr("",0), 'LVALUE ref' ],
- [ 0, VSTRING => \v1.0.0, 'VSTRING ref' ],
- [ 1, VSTRING => \(my $v = v1.0.0), 'VSTRING ref' ],
- [ 1, GLOB => \*F, 'tied GLOB ref' ],
- [ 1, GLOB => gensym, 'GLOB ref' ],
- [ 1, CODE => sub {}, 'CODE ref' ],
- [ 1, IO => *STDIN{IO}, 'IO ref' ],
- [ 1, FORMAT => *STDOUT{FORMAT}, 'FORMAT ref' ],
- [ 1, $RE => qr/x/, 'REGEXP' ],
- [ 0, !1, ${qr//}, 'derefed regex' ],
- );
-
- foreach $test (@test) {
- my($writable,$type,$what, $n) = @$test;
-
- SKIP: {
- if ($n =~ /derefed regex/i && !$HAVE_RE) {
- skip "regexes are not scalar references in perl < 5.011", 1;
- }
-
- is( reftype($what), $type, "reftype: $n");
- next unless $writable;
-
- bless $what, "ABC";
- is( reftype($what), $type, "reftype: blessed $n");
-
- bless $what, "0";
- is( reftype($what), $type, "reftype: blessed to false $n");
- }
- }
-}
-{
- is(blessed(undef),"", 'undef is not blessed');
- is(blessed(1),"", 'Numbers are not blessed');
- is(blessed('A'),"", 'Strings are not blessed');
- is(blessed({}),"", 'blessed: Unblessed HASH-ref');
- is(blessed([]),"", 'blessed: Unblessed ARRAY-ref');
- is(blessed(\$never_blessed),"", 'blessed: Unblessed SCALAR-ref');
-
- $x = bless [], "ABC::\0::\t::\n::ABC";
- is(blessed($x), "ABC::\0::\t::\n::ABC", 'blessed ARRAY-ref');
-
- $x = bless [], "ABC";
- is(blessed($x), "ABC", 'blessed ARRAY-ref');
-
- $x = bless {}, "DEF";
- is(blessed($x), "DEF", 'blessed HASH-ref');
-
- $x = bless {}, "0";
- cmp_ok(blessed($x), "eq", "0", 'blessed HASH-ref');
-
- {
- my $depth;
- {
- no warnings 'redefine';
- *UNIVERSAL::can = sub { die "Burp!" if ++$depth > 2; blessed(shift) };
- }
- $x = bless {}, "DEF";
- is(blessed($x), "DEF", 'recursion of UNIVERSAL::can');
- }
-
- {
- my $obj = bless [], "Broken";
- is( blessed($obj), "Broken", "blessed on broken isa() and can()" );
- }
-}
-{
- if (0) {
- require Devel::Peek;
- Devel::Peek->import('Dump');
- }
- else {
- *Dump = sub {};
- }
-
-
- if(1) {
-
- my ($y,$z);
-
-#
-# Case 1: two references, one is weakened, the other is then undef'ed.
-#
-
- {
- my $x = "foo";
- $y = \$x;
- $z = \$x;
- }
- print "# START\n";
- Dump($y); Dump($z);
-
- ok( ref($y) and ref($z));
-
- print "# WEAK:\n";
- weaken($y);
- Dump($y); Dump($z);
-
- ok( ref($y) and ref($z));
-
- print "# UNDZ:\n";
- undef($z);
- Dump($y); Dump($z);
-
- ok( not (defined($y) and defined($z)) );
-
- print "# UNDY:\n";
- undef($y);
- Dump($y); Dump($z);
-
- ok( not (defined($y) and defined($z)) );
-
- print "# FIN:\n";
- Dump($y); Dump($z);
-
-
-#
-# Case 2: one reference, which is weakened
-#
-
- print "# CASE 2:\n";
-
- {
- my $x = "foo";
- $y = \$x;
- }
-
- ok( ref($y) );
- print "# BW: \n";
- Dump($y);
- weaken($y);
- print "# AW: \n";
- Dump($y);
- ok( not defined $y );
-
- print "# EXITBLOCK\n";
- }
-
-#
-# Case 3: a circular structure
-#
-
- my $flag = 0;
- {
- my $y = bless {}, 'Dest';
- Dump($y);
- print "# 1: $y\n";
- $y->{Self} = $y;
- Dump($y);
- print "# 2: $y\n";
- $y->{Flag} = \$flag;
- print "# 3: $y\n";
- weaken($y->{Self});
- print "# WKED\n";
- ok( ref($y) );
- print "# VALS: HASH ",$y," SELF ",\$y->{Self}," Y ",\$y,
- " FLAG: ",\$y->{Flag},"\n";
- print "# VPRINT\n";
- }
- print "# OUT $flag\n";
- ok( $flag == 1 );
-
- print "# AFTER\n";
-
- undef $flag;
-
- print "# FLAGU\n";
-
-#
-# Case 4: a more complicated circular structure
-#
-
- $flag = 0;
- {
- my $y = bless {}, 'Dest';
- my $x = bless {}, 'Dest';
- $x->{Ref} = $y;
- $y->{Ref} = $x;
- $x->{Flag} = \$flag;
- $y->{Flag} = \$flag;
- weaken($x->{Ref});
- }
- ok( $flag == 2 );
-
-#
-# Case 5: deleting a weakref before the other one
-#
-
- my ($y,$z);
- {
- my $x = "foo";
- $y = \$x;
- $z = \$x;
- }
-
- print "# CASE5\n";
- Dump($y);
-
- weaken($y);
- Dump($y);
- undef($y);
-
- ok( not defined $y);
- ok( ref($z) );
-
-
-#
-# Case 6: test isweakref
-#
-
- $a = 5;
- ok(!isweak($a));
- $b = \$a;
- ok(!isweak($b));
- weaken($b);
- ok(isweak($b));
- $b = \$a;
- ok(!isweak($b));
-
- my $x = {};
- weaken($x->{Y} = \$a);
- ok(isweak($x->{Y}));
- ok(!isweak($x->{Z}));
-
-#
-# Case 7: test weaken on a read only ref
-#
-
- SKIP: {
- # Doesn't work for older perls, see bug [perl #24506]
- skip("Test does not work with perl < 5.8.3", 5) if $] < 5.008003;
-
- # in a MAD build, constants have refcnt 2, not 1
- skip("Test does not work with MAD", 5) if exists $Config{mad};
-
- $a = eval '\"hello"';
- ok(ref($a)) or print "# didn't get a ref from eval\n";
- $b = $a;
- eval{weaken($b)};
- # we didn't die
- ok($@ eq "") or print "# died with $@\n";
- ok(isweak($b));
- ok($$b eq "hello") or print "# b is '$$b'\n";
- $a="";
- ok(not $b) or print "# b didn't go away\n";
- }
-}
-
-package Broken;
-sub isa { die };
-sub can { die };
-
-package FooBar;
-
-use overload '0+' => sub { 10 },
- '+' => sub { 10 + $_[1] },
- '"' => sub { "10" };
-
-package MyTie;
-
-sub TIEHANDLE { bless {} }
-sub DESTROY {}
-
-sub AUTOLOAD {
- warn "$AUTOLOAD called";
- exit 1; # May be in an eval
-}
-
-package Hash3;
-
-use Scalar::Util qw(refaddr);
-
-sub TIEHASH
-{
- my $pkg = shift;
- return bless [ @_ ], $pkg;
-}
-sub FETCH
-{
- my $self = shift;
- my $key = shift;
- my ($underlying) = @$self;
- return $underlying->{refaddr($key)};
-}
-sub STORE
-{
- my $self = shift;
- my $key = shift;
- my $value = shift;
- my ($underlying) = @$self;
- return ($underlying->{refaddr($key)} = $key);
-}
-
-
-
-package Dest;
-
-sub DESTROY {
- print "# INCFLAG\n";
- ${$_[0]{Flag}} ++;
-}
diff --git a/pp.c b/pp.c
index 78ed2867ab..2ee604991c 100644
--- a/pp.c
+++ b/pp.c
@@ -559,7 +559,6 @@ PP(pp_ref)
dVAR; dSP; dTARGET;
const char *pv;
SV * const sv = POPs;
- STRLEN len;
if (sv)
SvGETMAGIC(sv);
@@ -567,8 +566,8 @@ PP(pp_ref)
if (!sv || !SvROK(sv))
RETPUSHNO;
- pv = sv_reftype_len(SvRV(sv),TRUE,&len);
- PUSHp(pv, len);
+ pv = sv_reftype(SvRV(sv),TRUE);
+ PUSHp(pv, strlen(pv));
RETURN;
}
diff --git a/proto.h b/proto.h
index e58169925e..4c7fb3d80c 100644
--- a/proto.h
+++ b/proto.h
@@ -3514,13 +3514,6 @@ PERL_CALLCONV bool Perl_sv_cat_decode(pTHX_ SV* dsv, SV *encoding, SV *ssv, int
#define PERL_ARGS_ASSERT_SV_CAT_DECODE \
assert(dsv); assert(encoding); assert(ssv); assert(offset); assert(tstr)
-PERL_CALLCONV const char* Perl_sv_reftype_len(pTHX_ const SV *const sv, const int ob, STRLEN *const ret_len)
- __attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_3);
-#define PERL_ARGS_ASSERT_SV_REFTYPE_LEN \
- assert(sv); assert(ret_len)
-
PERL_CALLCONV const char* Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_1);
diff --git a/sv.c b/sv.c
index b40fb45828..1f7c760d15 100644
--- a/sv.c
+++ b/sv.c
@@ -8612,112 +8612,23 @@ Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
}
/*
-=for apidoc sv_reftype_len
-
-Returns a string describing what type of item the SV is a reference to,
-storing the length of the string in *ret_len.
-
-If 'ob' is true and the item is an "object" returns the class name
-instead of the underlying type.
-
-Possible return values are:
-
-=over 4
-
-=item VSTRING
-
-Has special v-string magic
-
-=item REF
-
-Is a reference to another ref (C<< $$ref >>)
-
-=item SCALAR
-
-Is a reference to a scalar (C<< $$scalar >>)
-
-=item LVALUE
-
-An lvalue reference - B<NOTE>, tied lvalues appear to be of type C<SCALAR>
-for backwards compatibility reasons
-
-=item ARRAY
-
-An array reference (C<< @$array >>)
-
-=item HASH
-
-A hash reference (C<< %$hash >>)
-
-=item CODE
-
-A subroutine reference (C<< $code->() >>)
-
-=item GLOB
-
-A reference to a glob (C<< *$glob >>)
-
-=item FORMAT
-
-A format reference (C<< *IO{FORMAT} >>)
-
-=item IO
-
-An IO reference (C<< *STDOUT{IO} >>)
-
-=item BIND
-
-A bind reference
-
-=item REGEXP
-
-An executable regular expression (C<< qr/../ >>)
-
-=item UNKNOWN
-
-This should never be seen
+=for apidoc sv_reftype
-=back
+Returns a string describing what the SV is a reference to.
=cut
*/
-
const char *
-Perl_sv_reftype_len(pTHX_ const SV *const sv, const int ob, STRLEN *const ret_len)
+Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
{
- PERL_ARGS_ASSERT_SV_REFTYPE_LEN;
- assert(ret_len!=NULL);
+ PERL_ARGS_ASSERT_SV_REFTYPE;
- /* The fact that I don't need to downcast to char * everywhere, only in ?: (not used anymore)
+ /* The fact that I don't need to downcast to char * everywhere, only in ?:
inside return suggests a const propagation bug in g++. */
-
- /*
- * NOTE:
- *
- * This code is formatted so that the following command spits out a POD list of the
- * legal "reftypes" which is included above as well as in the lib/mauve.pm
-
- perl -MText::Wrap -le'local $/; $_= <>; while ( m!SV_REFTYPE_RETURN\("(\w+)"\);\s*[/][*]\s*(.*?)\s*[*][/]!gs) {
- $i=$1; ($t=$2)=~s/\s+/ /g; $o.=wrap("\n\n=item $i\n\n","",$t);} print "=over 4\n$o\n\n=back\n"' sv.c
-
- *
- * If you update this code please use the above to update the pod.
- *
- */
- /* we use this to make it cleaner to return the size and length at the same time,
- * and we use two aliases so we can use the above perl snippet to turn it into documentation
- * the ("" s "") trick guarantees we getting a string passed in (see perl.h for similar stuff)
- */
-#define SV_REFTYPE_RETURN(s) STMT_START { *ret_len= sizeof(s)-1; return ("" s ""); } STMT_END
-#define SV_BLESSED_RETURN(s) SV_REFTYPE_RETURN(s)
-
if (ob && SvOBJECT(sv)) {
char * const name = HvNAME_get(SvSTASH(sv));
- if (name) {
- *ret_len = HvNAMELEN_get(SvSTASH(sv));
- return name;
- } else SV_BLESSED_RETURN("__ANON__"); /* I don't see when this could happen - demerphq */
+ return name ? name : (char *) "__ANON__";
}
else {
switch (SvTYPE(sv)) {
@@ -8729,59 +8640,29 @@ Perl_sv_reftype_len(pTHX_ const SV *const sv, const int ob, STRLEN *const ret_le
case SVt_PVNV:
case SVt_PVMG:
if (SvVOK(sv))
- SV_REFTYPE_RETURN("VSTRING"); /* Has special v-string magic */
+ return "VSTRING";
if (SvROK(sv))
- SV_REFTYPE_RETURN("REF"); /* Is a reference to another ref (C<< $$ref >>) */
- else
- SV_REFTYPE_RETURN("SCALAR"); /* Is a reference to a scalar (C<< $$scalar >>) */
-
- case SVt_PVLV: if (SvROK(sv))
- SV_REFTYPE_RETURN("REF");
- else if (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
- /* tied lvalues appear to be scalars for back-compat reasons */
- SV_REFTYPE_RETURN("SCALAR");
- else
- SV_REFTYPE_RETURN("LVALUE"); /* An lvalue reference - B<NOTE>, tied lvalues
- appear to be of type C<SCALAR> for backwards
- compatibility reasons */
-
- case SVt_PVAV: SV_REFTYPE_RETURN("ARRAY"); /* An array reference (C<< @$array >>) */
- case SVt_PVHV: SV_REFTYPE_RETURN("HASH"); /* A hash reference (C<< %$hash >>) */
- case SVt_PVCV: SV_REFTYPE_RETURN("CODE"); /* A subroutine reference (C<< $code->() >>) */
- case SVt_PVGV: if(isGV_with_GP(sv))
- SV_REFTYPE_RETURN("GLOB"); /* A reference to a glob (C<< *$glob >>) */
+ return "REF";
else
- SV_REFTYPE_RETURN("SCALAR");
- case SVt_PVFM: SV_REFTYPE_RETURN("FORMAT"); /* A format reference (C<< *IO{FORMAT} >>) */
- case SVt_PVIO: SV_REFTYPE_RETURN("IO"); /* An IO reference (C<< *STDOUT{IO} >>) */
- case SVt_BIND: SV_REFTYPE_RETURN("BIND"); /* A bind reference */
- case SVt_REGEXP: SV_REFTYPE_RETURN("REGEXP"); /* An executable regular expression (C<< qr/../ >>) */
- default: SV_REFTYPE_RETURN("UNKNOWN"); /* This should never be seen */
+ return "SCALAR";
+
+ case SVt_PVLV: return (char *) (SvROK(sv) ? "REF"
+ /* tied lvalues should appear to be
+ * scalars for backwards compatitbility */
+ : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
+ ? "SCALAR" : "LVALUE");
+ case SVt_PVAV: return "ARRAY";
+ case SVt_PVHV: return "HASH";
+ case SVt_PVCV: return "CODE";
+ case SVt_PVGV: return (char *) (isGV_with_GP(sv)
+ ? "GLOB" : "SCALAR");
+ case SVt_PVFM: return "FORMAT";
+ case SVt_PVIO: return "IO";
+ case SVt_BIND: return "BIND";
+ case SVt_REGEXP: return "REGEXP";
+ default: return "UNKNOWN";
}
}
-#undef SV_BLESSED_RETURN
-#undef SV_REFTYPE_RETURN
-
-}
-
-/*
-=for apidoc sv_reftype
-
-Returns a string describing what type of item the SV is a reference to.
-
-If 'ob' is true and the item is an "object" returns the class name
-instead of the underlying type. Note in this form this routine is not
-recommended as you have no way to know the correct length of the class,
-and null is legal in a class name. Use Perl_sv_reftype_len instead.
-
-=cut
-*/
-
-const char *
-Perl_sv_reftype(pTHX_ const SV *const sv, const int ob){
- STRLEN len;
- PERL_ARGS_ASSERT_SV_REFTYPE;
- return sv_reftype_len(sv,ob,&len);
}
/*
diff --git a/universal.c b/universal.c
index 6df104eb13..fe53969bcd 100644
--- a/universal.c
+++ b/universal.c
@@ -1029,111 +1029,6 @@ XS(XS_Internals_HvREHASH) /* Subject to change */
Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
}
-XS(XS_mauve_reftype)
-{
- SV *sv;
- dVAR;
- dXSARGS;
- PERL_UNUSED_VAR(cv);
-
- if (items != 1)
- croak_xs_usage(cv, "sv");
-
- SP -= items;
- sv = (SV*)ST(0);
-
- if (SvMAGICAL(sv))
- mg_get(sv);
- if (!SvROK(sv)) {
- XSRETURN_NO;
- } else {
- STRLEN len;
- char *type= (char *)sv_reftype_len(SvRV(sv),FALSE,&len);
- XPUSHs(sv_2mortal(newSVpv(type,len)));
- }
-}
-
-XS(XS_mauve_refaddr)
-{
- SV *sv;
- dVAR;
- dXSARGS;
- PERL_UNUSED_VAR(cv);
-
- if (items != 1)
- croak_xs_usage(cv, "sv");
-
- SP -= items;
- sv = (SV*)ST(0);
-
- if (SvMAGICAL(sv))
- mg_get(sv);
- if (!SvROK(sv)) {
- XSRETURN_NO;
- } else {
- XPUSHs(sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))));
- }
-}
-
-XS(XS_mauve_blessed)
-{
- SV *sv;
- dVAR;
- dXSARGS;
- PERL_UNUSED_VAR(cv);
-
- if (items != 1)
- croak_xs_usage(cv, "sv");
-
- SP -= items;
- sv = (SV*)ST(0);
-
- if (SvMAGICAL(sv))
- mg_get(sv);
- if ( SvROK(sv) && SvOBJECT(SvRV(sv)) ) {
- STRLEN len;
- char *type= (char *)sv_reftype_len(SvRV(sv),TRUE,&len);
- XPUSHs(sv_2mortal(newSVpv(type,len)));
- } else {
- XPUSHs(sv_2mortal(newSVpv("",0)));
- }
-}
-
-XS(XS_mauve_weaken)
-{
- SV *sv;
- dVAR;
- dXSARGS;
- PERL_UNUSED_VAR(cv);
-
- if (items != 1)
- croak_xs_usage(cv, "sv");
-
- SP -= items;
- sv = (SV*)ST(0);
-
- if (SvMAGICAL(sv))
- mg_get(sv);
- sv_rvweaken(sv);
- XSRETURN_EMPTY;
-}
-
-XS(XS_mauve_isweak)
-{
- dVAR;
- dXSARGS;
- if (items != 1)
- croak_xs_usage(cv, "sv");
- {
- SV * sv = ST(0);
- if (SvMAGICAL(sv))
- mg_get(sv);
- ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
- XSRETURN(1);
- }
- XSRETURN(1);
-}
-
XS(XS_re_is_regexp)
{
dVAR;
@@ -1650,11 +1545,6 @@ struct xsub_details details[] = {
{"Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, NULL},
{"Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, NULL},
{"Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, NULL}
- ,{"mauve::reftype", XS_mauve_reftype, "$"}
- ,{"mauve::refaddr", XS_mauve_refaddr, "$"}
- ,{"mauve::blessed", XS_mauve_blessed, "$"}
- ,{"mauve::weaken", XS_mauve_weaken, "$"}
- ,{"mauve::isweak", XS_mauve_isweak, "$"}
};
void