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*
],
'UPSTREAM' => 'cpan',
},
+
'Memoize' =>
{
'MAINTAINER' => 'mjd',
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
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
#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
#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)
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
+++ /dev/null
-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
-
-
-
+++ /dev/null
-#!./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}} ++;
-}
dVAR; dSP; dTARGET;
const char *pv;
SV * const sv = POPs;
- STRLEN len;
if (sv)
SvGETMAGIC(sv);
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;
}
#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);
}
/*
-=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)) {
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);
}
/*
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;
{"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
https://perl5.git.perl.org / perl5.git / commitdiff