UNIVERSAL.pm and import methods (tests)

Hugo van der Sanden <hv@crypt.compulink.co.uk> wrote
>                              I find this form:
> 
>   if (ref($from) && 
>       (UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) {
> 
> really ugly. Has it been determined that UNIVERSAL can't simply be fixed in
> a way that avoids propagating the import?

I agree it's not very pretty.   But my feeling is that this is something you
don't do very often.    The File:: modules are something of a special
case, because of all the GLOB vs ref GLOB vs FileHandle vs IO:: stuff.
The four examples displayed in my patch really ought to be wrapped up
in some central routine, perhaps in IO::Handle.

My original message suggested two alternative methods.

I think (3) Kludge it is too disgusting to contemplate, but it's easy
enough to do.    Perhaps someone can suggest a more elegant variant of the
theme.

I was originally in favour of (4) Hide it, but I've since observed
that the PODs are full of suggestions that you can add a method
to _all_ classes by defining UNIVERSAL::method.    Which pretty much rules
out hiding.

> I also still feel that $object->isa('UNIVERSAL') should be true for any
> blessed reference - I tried asking about this a few times before, but
> never received an answer. As it currently stands, it will be true only
> if UNIVERSAL has been explicitly added to the package's @ISA, which to
> my mind should have no effect at all.

How quaint!    I can't say I'd noticed that anomaly in my poking about.
The attached patch fixes that.    It also radically extends the tests
for UNIVERSAL.

(The new tests assume that my patch to UNIVERSAL.pm has been done.)

p5p-msgid: E0whfHh-0007bW-00@ursa.cus.cam.ac.uk

1 files changed, 57 insertions, 21 deletions

diff --git a/t/op/universal.t b/t/op/universal.t
index 03f0fbdd9d..a68e2b4dee 100755
--- a/t/op/universal.t
+++ b/t/op/universal.t
@@ -3,7 +3,12 @@
 # check UNIVERSAL
 #
 
-print "1..11\n";
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib' if -d '../lib';
+}
+
+print "1..70\n";
 
 $a = {};
 bless $a, "Bob";
@@ -21,35 +26,66 @@ package Alice;
 sub drink {}
 sub new { bless {} }
 
+$Alice::VERSION = 2.718;
+
 package main;
+
+my $i = 2;
+sub test { print "not " unless shift; print "ok $i\n"; $i++; }
+
 $a = new Alice;
 
-print "not " unless $a->isa("Alice");
-print "ok 2\n";
+test $a->isa("Alice");
 
-print "not " unless $a->isa("Bob");
-print "ok 3\n";
+test $a->isa("Bob");
+
+test $a->isa("Female");
+
+test $a->isa("Human");
+
+test ! $a->isa("Male");
+
+test $a->can("drink");
+
+test $a->can("eat");
+
+test ! $a->can("sleep");
+
+my $b = 'abc';
+my @refs = qw(SCALAR SCALAR     LVALUE      GLOB ARRAY HASH CODE);
+my @vals = (  \$b,   \3.14, \substr($b,1,1), \*b,  [],  {}, sub {} );
+for ($p=0; $p < @refs; $p++) {
+    for ($q=0; $q < @vals; $q++) {
+        test UNIVERSAL::isa($vals[$p], $refs[$q]) eq ($p==$q or $p+$q==1);
+    };
+};
+
+test ! UNIVERSAL::can(23, "can");
+
+test $a->can("VERSION");
+
+test $a->can("can");
+
+test (eval { $a->VERSION }) == 2.718;
+
+test ! (eval { $a->VERSION(2.719) }) &&
+         $@ =~ /^Alice version 2.719 required--this is only version 2.718 at /;
 
-print "not " unless $a->isa("Female");
-print "ok 4\n";
+test (eval { $a->VERSION(2.718) }) && ! $@;
 
-print "not " unless $a->isa("Human");
-print "ok 5\n";
+my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
+test $subs eq "VERSION can isa";
 
-print "not " if $a->isa("Male");
-print "ok 6\n";
+test $a->isa("UNIVERSAL");
 
-print "not " unless $a->can("drink");
-print "ok 7\n";
+eval "use UNIVERSAL";
 
-print "not " unless $a->can("eat");
-print "ok 8\n";
+test $a->isa("UNIVERSAL");
 
-print "not " if $a->can("sleep");
-print "ok 9\n";
+my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::; 
+test $sub2 eq "VERSION can import isa";
 
-print "not " unless UNIVERSAL::isa([], "ARRAY");
-print "ok 10\n";
+eval 'sub UNIVERSAL::sleep {}';
+test $a->can("sleep");
 
-print "not " unless UNIVERSAL::isa({}, "HASH");
-print "ok 11\n";
+test ! UNIVERSAL::can($b, "can");