create the "mauve" temporary namespace for things like reftype

Scalar::Util::reftype(), refaddr() and blessed() are all a bit
less useful than they could be as they all return C<undef> when
their argument is not a reference. While this is logical, it also
means that using these routines has to be guarded, and normally
guarded in such a way that the internal logic is called twice.

Additionally these routines are quite commonly used and having to
load an additional DLL and XS code every program is inefficient.

Therefore we introduce the "mauve" namespace for to hold the "fixed"
equivalents, this namespace is /always/ loaded (like the 're' or 'utf8'
namespaces), and thus these routines can be accessed easily at any time.
We also provide a new module wrapper in t/lib which allows these
routines to be exported into other namespaces if the user so chooses.

At Jesse's request I have included weaken() and as it seemed logical to
do so I have also added isweak().

Once we have a good name for the namespace we can s/mauve/whatever/g

2 files changed, 517 insertions, 0 deletions

diff --git a/lib/mauve.pm b/lib/mauve.pm
new file mode 100644
index 0000000000..e94a412940
--- /dev/null
+++ b/lib/mauve.pm
@@ -0,0 +1,161 @@
+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
new file mode 100644
index 0000000000..5fc27602f7
--- /dev/null
+++ b/lib/mauve.t
@@ -0,0 +1,356 @@
+#!./perl
+
+use Test::More tests => 32 + 29 + 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);
+
+# 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 $RE = $] < 5.011 ? 'SCALAR' : 'REGEXP';
+    @test = (
+     [ !1, 1,		'number'	],
+     [ !1, 'A',		'string'	],
+     [ HASH   => {},	'HASH ref'	],
+     [ ARRAY  => [],	'ARRAY ref'	],
+     [ SCALAR => \$t,	'SCALAR ref'	],
+     [ REF    => \(\$t),	'REF ref'	],
+     [ GLOB   => \*F,	'tied GLOB ref'	],
+     [ GLOB   => gensym,	'GLOB ref'	],
+     [ CODE   => sub {},	'CODE ref'	],
+     [ IO     => *STDIN{IO},'IO ref'        ],
+     [ $RE    => qr/x/,     'REGEEXP'       ],
+    );
+
+    foreach $test (@test) {
+      my($type,$what, $n) = @$test;
+
+      is( reftype($what), $type, "reftype: $n");
+      next unless ref($what);
+
+      bless $what, "ABC";
+      is( reftype($what), $type, "reftype: $n");
+
+      bless $what, "0";
+      is( reftype($what), $type, "reftype: $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}} ++;
+}