ALT Linux Sisyphus - Пакет perl-Check-ISA

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<GLOB> with a
valid C<IO> slot (the C<IO> slot contains a L<FileHandle> object which is the
actual invocant). This corresponds directly to C<gv_fetchmethod>.

=item obj_does $thing, [ $class_or_role ]

Just like C<obj> but uses L<UNIVERSAL/DOES> instead of L<UNIVERSAL/isa>.

L<UNIVERSAL/DOES> is just like C<isa>, except it's use is encouraged to query
about an interface, as opposed to the object structure. If C<DOES> is not
overridden by th ebject, calling it is semantically identical to calling
C<isa>.

This is probably reccomended over C<obj> for interoperability, but can be
slower on Perls before 5.10.

Note that L<UNIVERSAL/DOES>

=item inv $thing, [ $class_or_role ]

Just like C<obj_does>, 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<autobox> 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<can> on C<$thing> if
appropriate.

=back

=head1 SEE ALSO

L<UNIVERSAL>, L<Params::Util>, L<autobox>, L<Moose>, L<asa>

=head1 VERSION CONTROL

This module is maintained using Darcs. You can get the latest version from
L<http://nothingmuch.woobling.org/code>, and use C<darcs send> to commit
changes.

=head1 AUTHOR

Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>

=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" );