Check-ISA-0.04/000075500000000000000000000000001143470717100130675ustar00rootroot00000000000000Check-ISA-0.04/Changes000064400000000000000000000003261143470717100143630ustar00rootroot000000000000000.04 - introduce obj_does for semantic compatibility on 5.8 without performance loss. Duh. 0.03 - Improved with input from Adam Kennedy 0.02 - Test suite fixes for perls below 5.10 0.01 - Initial release Check-ISA-0.04/MANIFEST000064400000000000000000000004301143470717100142150ustar00rootroot00000000000000Changes lib/Check/ISA.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP t/01_basic.t t/02_moose.t t/03_asa.t META.yml Module meta-data (added by MakeMaker) SIGNATURE Public-key signature (added by MakeMaker) Check-ISA-0.04/MANIFEST.SKIP000064400000000000000000000011131143470717100147610ustar00rootroot00000000000000# Avoid version control files. \bRCS\b \bCVS\b \bSCCS\b ,v$ \B\.svn\b \b_darcs\b # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ # Avoid Devel::Cover files. \bcover_db\b ### DEFAULT MANIFEST.SKIP ENDS HERE #### \.DS_Store$ \.sw.$ (\w+-)*(\w+)-\d\.\d+(?:\.tar\.gz)?$ \.t\.log$ \.prove$ # XS shit \.(?:bs|c|o)$ Check-ISA-0.04/META.yml000064400000000000000000000006301143470717100143370ustar00rootroot00000000000000--- #YAML:1.0 name: Check-ISA version: 0.04 abstract: ~ license: ~ author: ~ generated_by: ExtUtils::MakeMaker version 6.44 distribution_type: module requires: Sub::Exporter: 0 Test::use::ok: 0 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.3.html version: 1.3 Check-ISA-0.04/Makefile.PL000064400000000000000000000004541143470717100150440ustar00rootroot00000000000000#!/usr/bin/perl -w use strict; use ExtUtils::MakeMaker; require 5.008; WriteMakefile( NAME => 'Check::ISA', VERSION_FROM => 'lib/Check/ISA.pm', INSTALLDIRS => 'site', SIGN => 1, PL_FILES => { }, PREREQ_PM => { 'Test::use::ok' => 0, 'Sub::Exporter' => 0, }, ); Check-ISA-0.04/SIGNATURE000064400000000000000000000023301143470717100143510ustar00rootroot00000000000000This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.55. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 96f13ea0102ac88990ebcaa22a2bbb42795b9010 Changes SHA1 b4ac9072eced4f71e32c6a656ac9da889a198a9a MANIFEST SHA1 e8482690dad0ff3aaa335aa5b8b650851e504871 MANIFEST.SKIP SHA1 fa886734f1ac824bdec8bbac3eec89ca343d6ae5 META.yml SHA1 9042468f8165f44dda525f81772639d072aa30c0 Makefile.PL SHA1 b405d9a605052702fbbd44be249bc9eca4ca26c4 lib/Check/ISA.pm SHA1 bfc0ab184cd121012912221994f134ea188d64e5 t/01_basic.t SHA1 82d651c1e8183d46c84e5e8893020f13efdfdaa5 t/02_moose.t SHA1 a0ee7cd70d863085bfa406c06e613317c2583f81 t/03_asa.t -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.7 (Darwin) iD8DBQFIieXOVCwRwOvSdBgRAiaHAKCirButPd/TG1ODReNbOcWtgSMGywCgl9LT CeIRN92a5xRMmCDK0GHvNEg= =P6Ke -----END PGP SIGNATURE----- Check-ISA-0.04/lib/000075500000000000000000000000001143470717100136355ustar00rootroot00000000000000Check-ISA-0.04/lib/Check/000075500000000000000000000000001143470717100146525ustar00rootroot00000000000000Check-ISA-0.04/lib/Check/ISA.pm000064400000000000000000000121721143470717100156270ustar00rootroot00000000000000#!/usr/bin/perl package Check::ISA; use strict; use warnings; use Scalar::Util qw(blessed); use Sub::Exporter -setup => { exports => [qw(obj obj_does inv inv_does obj_can inv_can)], groups => { default => [qw(obj obj_does inv)], }, }; use constant CAN_HAS_DOES => not not UNIVERSAL->can("DOES"); use warnings::register; our $VERSION = "0.04"; sub extract_io { my $glob = shift; # handle the case of a string like "STDIN" # STDIN->print is actually: # const(PV "STDIN") sM/BARE # method_named(PV "print") # so we need to lookup the glob if ( defined($glob) and !ref($glob) and length($glob) ) { no strict 'refs'; $glob = \*{$glob}; } # extract the IO if ( ref($glob) eq 'GLOB' ) { if ( defined ( my $io = *{$glob}{IO} ) ) { require IO::Handle; return $io; } } return; } sub obj ($;$); # predeclare, it's recursive sub obj ($;$) { my ( $object_or_filehandle, $class ) = @_; my $object = blessed($object_or_filehandle) ? $object_or_filehandle : extract_io($object_or_filehandle) || return; if ( defined $class ) { $object->isa($class) } else { return 1; # return $object? what if it's overloaded? } } sub obj_does ($;$) { my ( $object_or_filehandle, $class_or_role ) = @_; my $object = blessed($object_or_filehandle) ? $object_or_filehandle : extract_io($object_or_filehandle) || return; if ( defined $class_or_role ) { if ( CAN_HAS_DOES ) { # we can be faster in 5.10 $object->DOES($class_or_role); } else { my $method = $object->can("DOES") || "isa"; $object->$method($class_or_role); } } else { return 1; # return $object? what if it's overloaded? } } sub inv ($;$) { my ( $inv, $class_or_role ) = @_; if ( blessed($inv) ) { return obj_does($inv, $class_or_role); } else { # we check just for scalar keys on the stash because: # sub Foo::Bar::gorch {} # Foo->can("isa") # true # Bar->can("isa") # false # this means that 'Foo' is a valid invocant, but Bar is not if ( !ref($inv) and defined $inv and length($inv) and do { no strict 'refs'; scalar keys %{$inv . "::"} } ) { # it's considered a class name as far as gv_fetchmethod is concerned # even if the class def is empty if ( defined $class_or_role ) { if ( CAN_HAS_DOES ) { # we can be faster in 5.10 $inv->DOES($class_or_role); } else { my $method = $inv->can("DOES") || "isa"; $inv->$method($class_or_role); } } else { return 1; # $inv is always true, so not a problem, but that would be inconsistent } } else { return; } } } sub obj_can ($;$) { my ( $obj, $method ) = @_; (blessed($obj) ? $obj : extract_io($obj) || return)->can($method); } sub inv_can ($;$) { my ( $inv, $method ) = @_; obj_can($inv, $method) || inv($inv) && $inv->can($method); } __PACKAGE__ __END__ =pod =head1 NAME Check::ISA - DWIM, correct checking of an object's class =head1 SYNOPSIS use Check::ISA; if ( obj($foo, "SomeClass") ) { $foo->some_method; } # instead of one of these methods: UNIVERSAL::isa($foo, "SomeClass") # WRONG ref $obj eq "SomeClass"; # VERY WRONG $foo->isa("SomeClass") # May die local $@; eval { $foo->isa("SomeClass") } # too long =head1 DESCRIPTION This module provides several functions to assist in testing whether a value is an object, and if so asking about its class. =head1 FUNCTIONS =over 4 =item obj $thing, [ $class ] This function tests if C<$thing> is an object. If C<$class> is provided, it also tests tests whether C<< $thing->isa($class) >>. C<$thing> is considered an object if it's blessed, or if it's a C with a valid C slot (the C slot contains a L object which is the actual invocant). This corresponds directly to C. =item obj_does $thing, [ $class_or_role ] Just like C but uses L instead of L. L is just like C, except it's use is encouraged to query about an interface, as opposed to the object structure. If C is not overridden by th ebject, calling it is semantically identical to calling C. This is probably reccomended over C for interoperability, but can be slower on Perls before 5.10. Note that L =item inv $thing, [ $class_or_role ] Just like C, but also returns true for classes. Note that this method is slower, but is supposed to return true for any value you can call methods on (class, object, filehandle, etc). Look into L if you would like to be able to call methods on all values. =item obj_can $thing, $method =item inv_can $thing, $method Checks if C<$thing> is an object or class, and calls C on C<$thing> if appropriate. =back =head1 SEE ALSO L, L, L, L, L =head1 VERSION CONTROL This module is maintained using Darcs. You can get the latest version from L, and use C to commit changes. =head1 AUTHOR Yuval Kogman Enothingmuch@woobling.orgE =head1 COPYRIGHT Copyright (c) 2008 Yuval Kogman. All rights reserved This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Check-ISA-0.04/t/000075500000000000000000000000001143470717100133325ustar00rootroot00000000000000Check-ISA-0.04/t/01_basic.t000064400000000000000000000063531143470717100151070ustar00rootroot00000000000000#!/usr/bin/perl use strict; use warnings; use Test::More 'no_plan'; use ok 'Check::ISA' => qw(obj obj_does inv obj_can inv_can); { package Foo; sub new { bless {}, shift } package Bar; use base qw(Foo); package Gorch; use base qw(Foo); sub isa { my ( $self, $class ) = @_; $self->SUPER::isa($class) or $class eq 'Faked'; } package Zot; use base qw(Foo); sub DOES { my ( $self, $role ) = @_; $self->SUPER::DOES($role) or $role eq 'FakedRole'; } } ok( !inv("Class::Does::Not::Exist"), "a random string is not a class" ); ok( !inv(undef), "undef is not a class" ); ok( !inv(0), "0 is not a class" ); ok( !inv(1), "1 is not a class" ); ok( !inv("0"), "'0' is not a class" ); ok( !inv("00"), "'00' is not a class" ); ok( !inv("1"), "'1' is not a class" ); ok( !inv(""), "'' is not a class" ); ok( !inv("blah"), "'blah' is not a class" ); ok( !inv([]), "an array ref is not a class" ); ok( !inv({}), "a hash ref is not a class" ); ok( !inv(sub {}), "a subroutine is not a class" ); ok( !obj_can(undef, "foo"), "no foo method for undef" ); ok( !obj_can("blah", "foo"), "no foo method for string" ); ok( !obj_can("blah", "isa"), "no foo method for string" ); ok( !obj_can("", "foo"), "no foo method for empty" ); ok( !obj_can({}, "foo"), "no foo method for hash refs" ); ok( !inv_can("blah", "foo"), "inv_can on random class" ); ok( !inv_can("blah", "isa"), "no foo method for string" ); ok( !inv_can("Foo", "foo"), "inv_can on Foo for nonexistent method" ); no warnings 'once'; ok( !obj(\*RANDOMGLOB), "a globref without an IO is not an object"); ok( obj(\*STDIN), "a globref with an IO is an object" ); ok( obj("STDIN"), "a filehandle name is an object" ); ok( obj_can(\*STDIN, "print"), "STDIN can print" ); ok( obj_can("STDIN", "print"), "'STDIN' can print" ); ok( inv_can(\*STDIN, "print"), "STDIN can print" ); ok( inv_can("STDIN", "print"), "'STDIN' can print" ); ok( obj(Foo->new), "Foo->new is an obj" ); ok( obj(Foo->new, "Foo"), "of class Foo" ); ok( inv(Foo->new, "Foo"), "inv works too" ); is( obj_can(Foo->new, "new"), \&Foo::new, "obj_can on obj" ); ok( !obj_can("Foo", "new"), "obj_can on non obj" ); is( inv_can(Foo->new, "new"), \&Foo::new, "inv_can on obj" ); is( inv_can("Foo", "new"), \&Foo::new, "inv_can on on obj" ); ok( !obj("Foo"), "the class is not an object" ); ok( !obj("Foo", "Foo"), "the class is not an object" ); ok( inv("Foo"), "Foo is a class" ); ok( inv("Foo", "Foo"), "class is itself" ); ok( !obj("Bar"), "Bar is not an object" ); ok( inv("Bar"), "Bar is an invocant" ); ok( inv("Bar", "Bar"), "Bar is a Bar" ); ok( inv("Bar", "Foo"), "Bar is a Foo" ); ok( inv("Gorch", "Faked"), "faked isa" ); ok( obj(Gorch->new, "Faked"), "for instance too" ); ok( inv("Gorch", "Foo"), "SUPER isa" ); ok( obj(Gorch->new, "Foo"), "for instance too" ); ok( !inv("Gorch", "Blah"), "false case" ); ok( !obj(Gorch->new, "Blah"), "for instance too" ); SKIP: { plan skip "No DOES in this version of Perl", 6 unless UNIVERSAL->can("DOES"); ok( inv("Zot", "FakedRole"), "faked DOES" ); ok( obj_does(Zot->new, "FakedRole"), "for instance" ); ok( inv("Zot", "Foo"), "DOES also answers isa" ); ok( obj_does(Zot->new, "Foo"), "for instance" ); ok( !inv("Zot", "OiVey"), "false case" ); ok( !obj_does(Zot->new, "Blah"), "for instance too" ); } Check-ISA-0.04/t/02_moose.t000064400000000000000000000034171143470717100151470ustar00rootroot00000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { plan skip_all => "Moose is required for this test" unless eval { require Moose }; plan tests => 25; } { package Foo; use Moose; package Bar; use Moose::Role; package Gorch; use Moose; extends qw(Foo); with qw(Bar); } use ok 'Check::ISA' => qw(obj obj_does inv); ok( obj(Foo->new), "Foo->new is an obj" ); ok( obj(Foo->new, "Foo"), "of class Foo" ); ok( obj(Foo->new, "Moose::Object"), "and Moose::Object" ); ok( inv(Foo->new, "Foo"), "inv works too" ); ok( !obj("Foo"), "the class is not an object" ); ok( !obj("Foo", "Foo"), "the class is not an object" ); ok( inv("Foo"), "Foo is a class" ); ok( inv("Foo", "Foo"), "class is itself" ); ok( inv("Foo", "Moose::Object"), "class is Moose::Object" ); ok( obj(Gorch->new), "Gorch->new is an obj" ); ok( obj(Gorch->new, "Gorch"), "of class Gorch" ); ok( obj(Gorch->new, "Foo"), "and class Foo" ); ok( obj(Gorch->new, "Moose::Object"), "and Moose::Object" ); SKIP: { skip "Moose 0.52 required for roles", 3 unless eval { Moose->VERSION("0.52") }; ok( Gorch->new->does("Bar"), "does Bar" ); ok( Gorch->new->DOES("Bar"), "DOES Bar" ); ok( obj_does(Gorch->new, "Bar"), "does Bar in obj test" ); } ok( inv(Gorch->new, "Gorch"), "inv works too" ); ok( !obj("Gorch"), "the class is not an object" ); ok( !obj("Gorch", "Gorch"), "the class is not an object" ); ok( inv("Gorch"), "Gorch is a class" ); ok( inv("Gorch", "Gorch"), "class is itself" ); ok( inv("Gorch", "Foo"), "class is Foo" ); ok( inv("Gorch", "Moose::Object"), "class is Moose::Object" ); SKIP: { plan skip "No DOES in this version of Perl", 1 unless UNIVERSAL->can("DOES"); skip "Moose 0.52 required for roles", 1 unless eval { Moose->VERSION("0.52") }; ok( inv("Gorch", "Bar"), "class does Bar" ); } Check-ISA-0.04/t/03_asa.t000064400000000000000000000007401143470717100145660ustar00rootroot00000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { plan skip_all => "asa is required for this test" unless eval { require asa }; plan tests => 3; } { package My::WereDuck; use asa 'Duck'; sub new { bless {}, shift } sub quack { return "Hi! errr... Quack!"; } } use ok 'Check::ISA' => qw(obj inv); ok( inv("My::WereDuck", "Duck"), "asa's ->isa is respected as a class method" ); ok( obj(My::WereDuck->new, "Duck"), "and as an instance method" );