diff options
| -rw-r--r-- | MANIFEST | 2 | ||||
| -rwxr-xr-x | Porting/Maintainers.pl | 2 | ||||
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | lib/mauve.pm | 161 | ||||
| -rw-r--r-- | lib/mauve.t | 380 | ||||
| -rw-r--r-- | pp.c | 5 | ||||
| -rw-r--r-- | proto.h | 7 | ||||
| -rw-r--r-- | sv.c | 169 | ||||
| -rw-r--r-- | universal.c | 110 |
11 files changed, 28 insertions, 812 deletions
@@ -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 @@ -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 @@ -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}} ++; -} @@ -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; } @@ -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); @@ -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 |