r2682 - in /packages/libuniversal-can-perl: ./ branches/
branches/upstream/
branches/upstream/current/ branches/upstream/current/lib/
branches/upstream/current/lib/UNIVERSAL/ branches/upstream/current/t/
branches/upstream/current/t/developer/ branches/upstream/current/t/lib/
branches/upstream/current/t/lib/Test/ tags/
eloy at users.alioth.debian.org
eloy at users.alioth.debian.org
Sat May 6 13:36:06 UTC 2006
Author: eloy
Date: Sat May 6 13:36:05 2006
New Revision: 2682
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=2682
Log:
[svn-inject] Installing original source of libuniversal-can-perl
Added:
packages/libuniversal-can-perl/
packages/libuniversal-can-perl/branches/
packages/libuniversal-can-perl/branches/upstream/
packages/libuniversal-can-perl/branches/upstream/current/
packages/libuniversal-can-perl/branches/upstream/current/Build.PL
packages/libuniversal-can-perl/branches/upstream/current/Changes
packages/libuniversal-can-perl/branches/upstream/current/MANIFEST
packages/libuniversal-can-perl/branches/upstream/current/META.yml
packages/libuniversal-can-perl/branches/upstream/current/Makefile.PL
packages/libuniversal-can-perl/branches/upstream/current/README
packages/libuniversal-can-perl/branches/upstream/current/SIGNATURE
packages/libuniversal-can-perl/branches/upstream/current/lib/
packages/libuniversal-can-perl/branches/upstream/current/lib/UNIVERSAL/
packages/libuniversal-can-perl/branches/upstream/current/lib/UNIVERSAL/can.pm
packages/libuniversal-can-perl/branches/upstream/current/t/
packages/libuniversal-can-perl/branches/upstream/current/t/00-load.t
packages/libuniversal-can-perl/branches/upstream/current/t/always_warn.t
packages/libuniversal-can-perl/branches/upstream/current/t/bad-input.t
packages/libuniversal-can-perl/branches/upstream/current/t/class.t
packages/libuniversal-can-perl/branches/upstream/current/t/developer/
packages/libuniversal-can-perl/branches/upstream/current/t/developer/0-signature.t
packages/libuniversal-can-perl/branches/upstream/current/t/developer/pod-coverage.t
packages/libuniversal-can-perl/branches/upstream/current/t/developer/pod.t
packages/libuniversal-can-perl/branches/upstream/current/t/lib/
packages/libuniversal-can-perl/branches/upstream/current/t/lib/Test/
packages/libuniversal-can-perl/branches/upstream/current/t/lib/Test/SmallWarn.pm
packages/libuniversal-can-perl/branches/upstream/current/t/object.t
packages/libuniversal-can-perl/tags/
Added: packages/libuniversal-can-perl/branches/upstream/current/Build.PL
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libuniversal-can-perl/branches/upstream/current/Build.PL?rev=2682&op=file
==============================================================================
--- packages/libuniversal-can-perl/branches/upstream/current/Build.PL (added)
+++ packages/libuniversal-can-perl/branches/upstream/current/Build.PL Sat May 6 13:36:05 2006
@@ -1,0 +1,52 @@
+#! perl
+
+use Module::Build;
+
+my $class = Module::Build->subclass(
+ class => 'Module::Build::FilterTests',
+ code => <<'END_HERE',
+
+ use File::Glob;
+ use File::Spec::Functions;
+
+ sub ACTION_disttest
+ {
+ my $self = shift;
+ local $ENV{PERL_RUN_ALL_TESTS} = 1;
+ $self->SUPER::ACTION_disttest( @_ );
+ }
+
+ sub find_test_files
+ {
+ my $self = shift;
+ my $tests = $self->SUPER::find_test_files( @_ );
+
+ return $tests unless $ENV{PERL_RUN_ALL_TESTS};
+
+ my $test_pattern = catfile(qw( t developer *.t ) );
+ unshift @$tests, File::Glob::bsd_glob( $test_pattern );
+ return $tests;
+ }
+END_HERE
+);
+
+my $builder = $class->new(
+ module_name => 'UNIVERSAL::can',
+ license => 'perl',
+ dist_author => 'chromatic <chromatic at wgz.org>',
+ dist_version_from => 'lib/UNIVERSAL/can.pm',
+ requires =>
+ {
+ 'perl' => '5.6.0',
+ 'Scalar::Util' => '',
+ },
+ build_requires =>
+ {
+ 'Test::Simple' => '0.60',
+ },
+ add_to_cleanup => [ 'UNIVERSAL-can-*' ],
+ create_makefile_pl => 'traditional',
+ sign => 1,
+);
+
+$builder->create_build_script();
Added: packages/libuniversal-can-perl/branches/upstream/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libuniversal-can-perl/branches/upstream/current/Changes?rev=2682&op=file
==============================================================================
--- packages/libuniversal-can-perl/branches/upstream/current/Changes (added)
+++ packages/libuniversal-can-perl/branches/upstream/current/Changes Sat May 6 13:36:05 2006
@@ -1,0 +1,33 @@
+Revision history for UNIVERSAL::can
+
+1.12 Sat Apr 1 06:13:33 UTC 2006
+ - really made Test::Warn optional
+ - moved developer tests to t/developer/
+
+1.11 Fri Feb 10 01:55:59 UTC 2006
+ - made can() export *optional*, as it can break things...
+ - fixed invocant check to use existing code and avoid infinite
+ UNIVERSAL::isa loop
+
+1.10 Fri Feb 10 01:17:56 UTC 2006
+ - worked around weirdness with Test::Warn in the tests
+ - fixed the invalid invocant bug reported by Mark Clements
+ - fixed the tests to test for that bug too...
+ - made the export of can() actually work
+ - added the -always_warn flag to catch all dodgy uses of UNIVERSAL::can()
+
+1.03 Fri Jan 13 04:46:59 UTC 2006
+ - mark minimum dependency on Perl 5.6 (reported by Adam Kennedy)
+ - test for Really Bad Input (also suggested by Adam Kennedy)
+ - fixed invalid input bugs
+
+1.02 Wed Jan 11 00:58:57 UTC 2006
+ - don't eat $@ in can() (RT #17008, reported by martin at hybyte dot com)
+
+1.01 Wed Dec 14 00:19:22 UTC 2005
+ - check for uninitialized invocant (patch from Stevan Little)
+ - squelch unnecessary warnings (wow, a typo!)
+ - added a bit more advice to the documentation
+
+1.00 Sun Jul 3 21:38:47 UTC 2005
+ - First version, released on an unsuspecting world.
Added: packages/libuniversal-can-perl/branches/upstream/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libuniversal-can-perl/branches/upstream/current/MANIFEST?rev=2682&op=file
==============================================================================
--- packages/libuniversal-can-perl/branches/upstream/current/MANIFEST (added)
+++ packages/libuniversal-can-perl/branches/upstream/current/MANIFEST Sat May 6 13:36:05 2006
@@ -1,0 +1,17 @@
+Build.PL
+Changes
+MANIFEST
+META.yml # Will be created by "make dist"
+README
+lib/UNIVERSAL/can.pm
+t/lib/Test/SmallWarn.pm
+t/00-load.t
+t/always_warn.t
+t/bad-input.t
+t/class.t
+t/developer/0-signature.t
+t/developer/pod-coverage.t
+t/developer/pod.t
+t/object.t
+Makefile.PL # Do you feel retro?
+SIGNATURE Added here by Module::Build
Added: packages/libuniversal-can-perl/branches/upstream/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libuniversal-can-perl/branches/upstream/current/META.yml?rev=2682&op=file
==============================================================================
--- packages/libuniversal-can-perl/branches/upstream/current/META.yml (added)
+++ packages/libuniversal-can-perl/branches/upstream/current/META.yml Sat May 6 13:36:05 2006
@@ -1,0 +1,22 @@
+---
+name: UNIVERSAL-can
+version: 1.12
+author:
+ - 'chromatic <chromatic at wgz.org>'
+abstract: Hack around people calling UNIVERSAL::can() as a function
+license: perl
+resources:
+ license: http://dev.perl.org/licenses/
+requires:
+ Scalar::Util: ''
+ perl: 5.6.0
+build_requires:
+ Test::Simple: 0.60
+provides:
+ UNIVERSAL::can:
+ file: lib/UNIVERSAL/can.pm
+ version: 1.12
+generated_by: Module::Build version 0.2709
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.2.html
+ version: 1.2
Added: packages/libuniversal-can-perl/branches/upstream/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libuniversal-can-perl/branches/upstream/current/Makefile.PL?rev=2682&op=file
==============================================================================
--- packages/libuniversal-can-perl/branches/upstream/current/Makefile.PL (added)
+++ packages/libuniversal-can-perl/branches/upstream/current/Makefile.PL Sat May 6 13:36:05 2006
@@ -1,0 +1,15 @@
+# Note: this file was auto-generated by Module::Build::Compat version 0.03
+use ExtUtils::MakeMaker;
+WriteMakefile
+(
+ 'NAME' => 'UNIVERSAL::can',
+ 'VERSION_FROM' => 'lib/UNIVERSAL/can.pm',
+ 'PREREQ_PM' => {
+ 'Scalar::Util' => '',
+ 'Test::Simple' => '0.60'
+ },
+ 'INSTALLDIRS' => 'site',
+ 'EXE_FILES' => [],
+ 'PL_FILES' => {}
+ )
+;
Added: packages/libuniversal-can-perl/branches/upstream/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libuniversal-can-perl/branches/upstream/current/README?rev=2682&op=file
==============================================================================
--- packages/libuniversal-can-perl/branches/upstream/current/README (added)
+++ packages/libuniversal-can-perl/branches/upstream/current/README Sat May 6 13:36:05 2006
@@ -1,0 +1,25 @@
+UNIVERSAL::can
+--------------
+
+Version 1.12, Sat Apr 1 06:14:06 UTC 2006
+
+This module attempts to work around people calling UNIVERSAL::can() as a
+function, which it is not.
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+ perl Build.PL
+ perl ./Build
+ perl ./Build test
+ perl ./Build install
+
+There is also a Makefile.PL, but I don't use it.
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2005 - 2006 chromatic
+
+This library is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
Added: packages/libuniversal-can-perl/branches/upstream/current/SIGNATURE
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libuniversal-can-perl/branches/upstream/current/SIGNATURE?rev=2682&op=file
==============================================================================
--- packages/libuniversal-can-perl/branches/upstream/current/SIGNATURE (added)
+++ packages/libuniversal-can-perl/branches/upstream/current/SIGNATURE Sat May 6 13:36:05 2006
@@ -1,0 +1,39 @@
+This file contains message digests of all files listed in MANIFEST,
+signed via the Module::Signature module, version 0.53.
+
+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 04c704ba343fa479109f644f905e5d3d7a68c02a Build.PL
+SHA1 c4a945018eff11c0cc86e130b6dc92754715a165 Changes
+SHA1 7c3369c8223dcb6f633ef0e9269601c88e3ae134 MANIFEST
+SHA1 673cfad3adf3c07d8e9db1f9be1bc313a5558eeb META.yml
+SHA1 9fdc6c75b6c97f7910b02f6681b1ae5684dc38fe Makefile.PL
+SHA1 281d29d5d89d9654f6bbfb885ef7a471b7b4d271 README
+SHA1 04b661abd8f9cc6e64aeaa8e8c673df295d528b3 lib/UNIVERSAL/can.pm
+SHA1 b42c30224a2c2d38fb8763cb3ccf6ce72e99d2d2 t/00-load.t
+SHA1 d002b983ef8c52000497b452f1f5cc3efdfb6c0d t/always_warn.t
+SHA1 d330e00404d24a7012161dddf04d480f11d7b884 t/bad-input.t
+SHA1 3cd19d593956c0bc25aa0c4b8527cf10c9f5c90a t/class.t
+SHA1 e7fbd29bd994639e82a480ca7668208c84faf780 t/developer/0-signature.t
+SHA1 c9986c0674bd6a37f3f5cdb3250d857f0935cf86 t/developer/pod-coverage.t
+SHA1 0190346d7072d458c8a10a45c19f86db641dcc48 t/developer/pod.t
+SHA1 1e547bdc8dde8e1b004574d7124b088861a000b9 t/lib/Test/SmallWarn.pm
+SHA1 31586100c72a5a776210cd0b186c66e525a0bba7 t/object.t
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.4.2.2 (GNU/Linux)
+
+iD8DBQFELhqMqX/z6NoU2UoRAuSOAJsH+ZyQ7IulphUC5BhvZTg3n2FOywCfTYhu
+lU3ZVaobedEDcj/pEgKmzfo=
+=oduQ
+-----END PGP SIGNATURE-----
Added: packages/libuniversal-can-perl/branches/upstream/current/lib/UNIVERSAL/can.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libuniversal-can-perl/branches/upstream/current/lib/UNIVERSAL/can.pm?rev=2682&op=file
==============================================================================
--- packages/libuniversal-can-perl/branches/upstream/current/lib/UNIVERSAL/can.pm (added)
+++ packages/libuniversal-can-perl/branches/upstream/current/lib/UNIVERSAL/can.pm Sat May 6 13:36:05 2006
@@ -1,0 +1,194 @@
+package UNIVERSAL::can;
+
+use strict;
+use warnings;
+
+use 5.006;
+
+use vars qw( $VERSION $recursing );
+$VERSION = '1.12';
+
+use Scalar::Util 'blessed';
+use warnings::register;
+
+my $orig;
+use vars '$always_warn';
+
+BEGIN
+{
+ $orig = \&UNIVERSAL::can;
+
+ no warnings 'redefine';
+ *UNIVERSAL::can = \&can;
+}
+
+sub import
+{
+ my $class = shift;
+ for my $import (@_)
+ {
+ $always_warn = 1 if $import eq '-always_warn';
+ no strict 'refs';
+ *{ caller() . '::can' } = \&can if $import eq 'can';
+ }
+}
+
+sub can
+{
+ # can't call this on undef
+ return _report_warning() unless defined $_[0];
+
+ # don't get into a loop here
+ goto &$orig if $recursing;
+
+ # call an overridden can() if it exists
+ local $@;
+ my $can = eval { $_[0]->$orig('can') || 0 };
+
+ # but not if it inherited this one
+ goto &$orig if $can == \&UNIVERSAL::can;
+
+ # make sure the invocant is useful
+ unless ( _is_invocant( $_[0] ) )
+ {
+ _report_warning();
+ goto &$orig;
+ }
+
+ # redirect to an overridden can, making sure not to recurse and warning
+ local $recursing = 1;
+ my $invocant = shift;
+
+ _report_warning();
+ return $invocant->can(@_);
+}
+
+sub _report_warning
+{
+ if ( $always_warn || warnings::enabled() )
+ {
+ my $calling_sub = ( caller(2) )[3] || '';
+ warnings::warn("Called UNIVERSAL::can() as a function, not a method")
+ if $calling_sub !~ /::can$/;
+ }
+
+ return;
+}
+
+sub _is_invocant
+{
+ my $potential = shift;
+ return unless length $potential;
+ return 1 if blessed($potential);
+
+ my $symtable = \%::;
+ my $found = 1;
+
+ for my $symbol ( split( /::/, $potential ) )
+ {
+ $symbol .= '::';
+ unless ( exists $symtable->{$symbol} )
+ {
+ $found = 0;
+ last;
+ }
+
+ $symtable = $symtable->{$symbol};
+ }
+
+ return $found;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+UNIVERSAL::can - Hack around people calling UNIVERSAL::can() as a function
+
+=head1 VERSION
+
+Version 1.01
+
+=head1 SYNOPSIS
+
+To use this module, simply:
+
+ use UNIVERSAL::can;
+
+=head1 DESCRIPTION
+
+The UNIVERSAL class provides a few default methods so that all objects can use
+them. Object orientation allows programmers to override these methods in
+subclasses to provide more specific and appropriate behavior.
+
+Some authors call methods in the UNIVERSAL class on potential invocants as
+functions, bypassing any possible overriding. This is wrong and you should not
+do it. Unfortunately, not everyone heeds this warning and their bad code can
+break your good code.
+
+This module replaces C<UNIVERSAL::can()> with a method that checks to see if
+the first argument is a valid invocant (whether an object -- a blessed referent
+-- or the name of a class). If so, and if the invocant's class has its own
+C<can()> method, it calls that as a method. Otherwise, everything works as you
+might expect.
+
+If someone attempts to call C<UNIVERSAL::can()> as a function, this module will
+emit a lexical warning (see L<perllexwarn>) to that effect. You can disable it
+with C<no warnings;> or C<no warnings 'UNIVERSAL::isa';>, but don't do that;
+fix the code instead.
+
+Some people argue that you must call C<UNIVERSAL::can()> as a function because
+you don't know if your proposed invocant is a valid invocant. That's silly.
+Use C<blessed()> from L<Scalar::Util> if you want to check that the potential
+invocant is an object or call the method anyway in an C<eval> block and check
+for failure.
+
+Just don't break working code.
+
+=head1 EXPORT
+
+This module can I<optionally> export a C<can()> subroutine that works exactly
+as described. It's a convenient shortcut for you. This actually works in
+version 1.11.
+
+Also, if you pass the C<-always_warn> flag on the import line, this module will
+warn about all incorrect uses of C<UNIVERSAL::can()>. This can help you change your code to be correct.
+
+=head2 can()
+
+The C<can()> method takes two arguments, a potential invocant and the name of a
+method that that invocant may be able to call. It attempts to divine whether
+the invocant is an object or a valid class name, whether there is an overridden
+C<can()> method for it, and then calls that. Otherwise, it calls
+C<UNIVERSAL::can()> directly, as if nothing had happened.
+
+=head1 AUTHOR
+
+chromatic, C<< <chromatic at wgz.org> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-universal-can at rt.cpan.org>,
+or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=UNIVERSAL-can>. This will
+contact me, hold onto patches so I don't drop them, and will notify you of
+progress on your request as I make changes.
+
+=head1 ACKNOWLEDGEMENTS
+
+Inspired by L<UNIVERSAL::isa> by Yuval Kogman, Autrijus Tang, and myself.
+
+Adam Kennedy has tirelessly made me tired by reporting potential bugs and
+suggesting ideas that found actual bugs.
+
+Mark Clements helped to track down an invalid invocant bug.
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (c) 2005 - 2006 chromatic. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
Added: packages/libuniversal-can-perl/branches/upstream/current/t/00-load.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libuniversal-can-perl/branches/upstream/current/t/00-load.t?rev=2682&op=file
==============================================================================
--- packages/libuniversal-can-perl/branches/upstream/current/t/00-load.t (added)
+++ packages/libuniversal-can-perl/branches/upstream/current/t/00-load.t Sat May 6 13:36:05 2006
@@ -1,0 +1,13 @@
+use Test::More tests => 3;
+
+use_ok( 'UNIVERSAL::can' );
+
+diag( "Testing UNIVERSAL::can $UNIVERSAL::can::VERSION, Perl $], $^X" );
+
+ok( ! defined &main::can, 'UNIVERSAL::can() should not export can()' );
+
+package not_main;
+
+use UNIVERSAL::can 'can';
+
+::ok( defined ¬_main::can, '.. but should export it when requested' );
Added: packages/libuniversal-can-perl/branches/upstream/current/t/always_warn.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libuniversal-can-perl/branches/upstream/current/t/always_warn.t?rev=2682&op=file
==============================================================================
--- packages/libuniversal-can-perl/branches/upstream/current/t/always_warn.t (added)
+++ packages/libuniversal-can-perl/branches/upstream/current/t/always_warn.t Sat May 6 13:36:05 2006
@@ -1,0 +1,32 @@
+#!perl
+
+use strict;
+use warnings;
+
+use lib 't/lib';
+
+use Test::More tests => 2;
+use Test::SmallWarn;
+
+# must happen here to register warnings category
+BEGIN { use_ok( 'UNIVERSAL::can', '-always_warn' ) };
+
+{
+ package Demo;
+
+ sub new { bless {}, shift }
+
+ sub can
+ {
+ my ($self, $method) = @_;
+ return $self->SUPER::can( $method );
+ }
+}
+
+my $demo = Demo->new( 'Demo' );
+{
+ no warnings;
+ warning_like { UNIVERSAL::can( $demo, 'new' ) }
+ qr/Called UNIVERSAL::can/,
+ '-always_warn flag should make module always warn';
+}
Added: packages/libuniversal-can-perl/branches/upstream/current/t/bad-input.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libuniversal-can-perl/branches/upstream/current/t/bad-input.t?rev=2682&op=file
==============================================================================
--- packages/libuniversal-can-perl/branches/upstream/current/t/bad-input.t (added)
+++ packages/libuniversal-can-perl/branches/upstream/current/t/bad-input.t Sat May 6 13:36:05 2006
@@ -1,0 +1,70 @@
+#!perl
+
+use strict;
+use warnings;
+
+use lib 't/lib';
+
+# add all sorts of bad input that might get crazy results
+my @inputs;
+
+BEGIN
+{
+ @inputs =
+ (
+ undef, '', \'', {}, [], 0, sub {}, do { local *FH; *FH }, -1, 0.003, '.'
+ );
+}
+
+# don't hardcode the test number, but do check for premature death
+use Test::More tests => ( @inputs * 2 ) + 1;
+use Test::SmallWarn;
+
+# enable lexical warnings from module at compile time
+BEGIN { use_ok( 'UNIVERSAL::can' ) }
+
+=pod
+
+This test is for the issue discussed in the PM post:
+
+http://www.perlmonks.org/index.pl?node_id=516372
+
+The errors which were reported were:
+
+ Use of uninitialized value in split at
+ /usr/local/share/perl/5.8.4/UNIVERSAL/can.pm line 51.
+ Called UNIVERSAL::can() as a function, not a method at
+ /usr/local/share/perl/5.8.4/Class/DBI.pm line 265
+ Can't call method "can" on an undefined value at
+ /usr/local/share/perl/5.8.4/UNIVERSAL/can.pm line 40.
+
+Class::DBI line 265 is:
+
+255 > my @pk_values = $self->_attrs($self->primary_columns);
+265 > UNIVERSAL::can($_ => 'id') and $_ = $_->id for @pk_values;
+
+In all likeliness Class::DBI line 265 really should be:
+
+ eval { $_->can( $_ => 'id') } and $_ = $_->id
+ for grep { defined $_ } @pk_values;
+
+or something similar to prevent sending an undefined value to UNIVERSAL::can.
+
+However, in the interest of making this module as useful as possible, it should
+check for bad input and DWIM in those cases.
+
+=cut
+
+# this is a little ugly because nesting the warning test within the exception
+# test didn't do The Right Thing
+for my $bad ( @inputs )
+{
+ my $bad_name = defined $bad ? $bad : '(undef)';
+
+ my $flag;
+
+ warning_like { $flag = eval { UNIVERSAL::can( $bad, 'id' ); 1 } }
+ qr/^Called UNIVERSAL\:\:can\(\) as a function\, not a method/,
+ "test received exactly one warning for bad input '$bad_name'";
+ ok( $flag, '... and did not throw an exception' );
+}
Added: packages/libuniversal-can-perl/branches/upstream/current/t/class.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libuniversal-can-perl/branches/upstream/current/t/class.t?rev=2682&op=file
==============================================================================
--- packages/libuniversal-can-perl/branches/upstream/current/t/class.t (added)
+++ packages/libuniversal-can-perl/branches/upstream/current/t/class.t Sat May 6 13:36:05 2006
@@ -1,0 +1,135 @@
+#!perl
+
+use strict;
+use warnings;
+
+use lib 't/lib';
+
+use Test::More tests => 16;
+use Test::SmallWarn;
+
+# must happen here to register warnings category
+BEGIN { use_ok( 'UNIVERSAL::can' ) };
+
+{
+ package Logger;
+
+ use Scalar::Util 'blessed';
+
+ use vars '$AUTOLOAD';
+
+ sub new
+ {
+ my ($class, $object) = @_;
+ bless { object => $object, calls => [] }, $class;
+ }
+
+ sub object
+ {
+ my $self = shift;
+ return $self->{object} if blessed( $self );
+ return $self;
+ }
+
+ sub calls
+ {
+ my $self = shift;
+ return $self->{calls};
+ }
+
+ sub can
+ {
+ my ($self, $name) = @_;
+ my $object = $self->object();
+ return $self->SUPER::can( $name ) if $object->isa( __PACKAGE__ );
+ my $wrapped_method = $self->object->can( $name );
+ }
+
+ sub DESTROY {}
+
+ sub AUTOLOAD
+ {
+ my $self = shift;
+ my ($method) = $AUTOLOAD =~ /::(\w+)$/;
+ return unless my $coderef = $self->object->can( $method );
+
+ push @{ $self->calls() }, $method;
+ $self->object->$coderef( @_ );
+ }
+
+ package Logged;
+
+ sub new
+ {
+ my $class = shift;
+ bless \$class, $class;
+ }
+
+ sub foo
+ {
+ my $self = shift;
+ return 'foo'; }
+
+ package Liar;
+
+ use vars '$AUTOLOAD';
+
+ sub can
+ {
+ my $self = shift;
+ return Logger->can( shift );
+ }
+
+ sub DESTROY {}
+
+ sub AUTOLOAD
+ {
+ my $self = shift;
+ my ($method) = $AUTOLOAD =~ /::(\w+)$/;
+ return Logger->$method( @_ );
+ }
+}
+
+my $logger = Logger->new( 'Logged' );
+
+my $can_new = $logger->can( 'new' );
+my $can_foo = $logger->can( 'foo' );
+ok( defined $can_new, 'can() should return true for defined class methods' );
+ok( defined &$can_new, '... returning a code reference' );
+is( $can_foo, \&Logged::foo, '... the correct code reference' );
+
+my $uncan_foo;
+warning_like { $uncan_foo = UNIVERSAL::can( $logger, 'foo' ) }
+ qr/Called UNIVERSAL::can\(\) as a function, not a method at t.class.t/,
+ 'calling UNIVERSAL::can() as function on invocant should warn';
+ok( defined $uncan_foo, 'UNIVERSAL::can() should return true then too' );
+ok( defined &$uncan_foo, '... returning a code reference' );
+is( $uncan_foo, \&Logged::foo, '... the correct code reference' );
+
+my $can_calls = Logger->can( 'calls' );
+ok( defined $can_calls,
+ 'can() should return true for methods called as class methods' );
+my $can_falls = Logger->can( 'falls' );
+ok( ! defined $can_falls,
+ '... and false for nonexistant methods' );
+
+my $uncan_liar;
+warning_like { $uncan_liar = UNIVERSAL::can( 'Liar', 'new' ) }
+ qr/Called UNIVERSAL::can\(\) as a function, not a method at t.class.t/,
+ 'calling UNIVERSAL::can() as function on class name invocant should warn';
+
+{
+ no warnings;
+ warnings_are { $uncan_liar = UNIVERSAL::can( 'Liar', 'new' ) }
+ [], '... but only with warnings enabled';
+}
+
+{
+ no warnings 'UNIVERSAL::can';
+ warnings_are { $uncan_liar = UNIVERSAL::can( 'Liar', 'new' ) }
+ [], '... and not with warnings diabled for UNIVERSAL::can';
+}
+
+ok( defined $uncan_liar, 'can() should return true for class can() method' );
+ok( defined &$uncan_liar, '... returning a code reference' );
+is( $uncan_liar, \&Logger::new, '... the correct code reference' );
Added: packages/libuniversal-can-perl/branches/upstream/current/t/developer/0-signature.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libuniversal-can-perl/branches/upstream/current/t/developer/0-signature.t?rev=2682&op=file
==============================================================================
--- packages/libuniversal-can-perl/branches/upstream/current/t/developer/0-signature.t (added)
+++ packages/libuniversal-can-perl/branches/upstream/current/t/developer/0-signature.t Sat May 6 13:36:05 2006
@@ -1,0 +1,20 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+
+SKIP: {
+ if (eval { require Module::Signature; 1 }) {
+ ok(Module::Signature::verify() == Module::Signature::SIGNATURE_OK()
+ => "Valid signature" );
+ }
+ else {
+ diag("Next time around, consider installing Module::Signature,\n".
+ "so you can verify the integrity of this distribution.\n");
+ skip("Module::Signature not installed", 1)
+ }
+}
+
+__END__
Added: packages/libuniversal-can-perl/branches/upstream/current/t/developer/pod-coverage.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libuniversal-can-perl/branches/upstream/current/t/developer/pod-coverage.t?rev=2682&op=file
==============================================================================
--- packages/libuniversal-can-perl/branches/upstream/current/t/developer/pod-coverage.t (added)
+++ packages/libuniversal-can-perl/branches/upstream/current/t/developer/pod-coverage.t Sat May 6 13:36:05 2006
@@ -1,0 +1,7 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage"
+ if $@;
+all_pod_coverage_ok();
Added: packages/libuniversal-can-perl/branches/upstream/current/t/developer/pod.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libuniversal-can-perl/branches/upstream/current/t/developer/pod.t?rev=2682&op=file
==============================================================================
--- packages/libuniversal-can-perl/branches/upstream/current/t/developer/pod.t (added)
+++ packages/libuniversal-can-perl/branches/upstream/current/t/developer/pod.t Sat May 6 13:36:05 2006
@@ -1,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
+all_pod_files_ok();
Added: packages/libuniversal-can-perl/branches/upstream/current/t/lib/Test/SmallWarn.pm
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libuniversal-can-perl/branches/upstream/current/t/lib/Test/SmallWarn.pm?rev=2682&op=file
==============================================================================
--- packages/libuniversal-can-perl/branches/upstream/current/t/lib/Test/SmallWarn.pm (added)
+++ packages/libuniversal-can-perl/branches/upstream/current/t/lib/Test/SmallWarn.pm Sat May 6 13:36:05 2006
@@ -1,0 +1,39 @@
+package Test::SmallWarn;
+
+use strict;
+use warnings;
+
+use Test::More;
+
+sub import
+{
+ my $caller = caller();
+
+ no strict 'refs';
+ *{ $caller . '::warning_like' } = \&warning_like;
+ *{ $caller . '::warnings_are' } = \&warnings_are;
+}
+
+sub warning_like (&$;$)
+{
+ my ($code, $regex, $description) = @_;
+
+ my $warning = '' ;
+ local $SIG{__WARN__} = sub { $warning .= shift };
+
+ $code->();
+ like( $warning, $regex, $description );
+}
+
+sub warnings_are (&$;$)
+{
+ my ($code, $expected, $description) = @_;
+
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, shift };
+
+ $code->();
+ is( "@warnings", "@$expected", $description );
+}
+
+1;
Added: packages/libuniversal-can-perl/branches/upstream/current/t/object.t
URL: http://svn.debian.org/wsvn/pkg-perl/packages/libuniversal-can-perl/branches/upstream/current/t/object.t?rev=2682&op=file
==============================================================================
--- packages/libuniversal-can-perl/branches/upstream/current/t/object.t (added)
+++ packages/libuniversal-can-perl/branches/upstream/current/t/object.t Sat May 6 13:36:05 2006
@@ -1,0 +1,65 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 6;
+
+# enable lexical warnings from module at compile time
+BEGIN { use_ok( 'UNIVERSAL::can' ) }
+
+{
+ package Foo;
+
+ use vars '$AUTOLOAD';
+ use Scalar::Util 'blessed';
+
+ sub new
+ {
+ my ($class, %args) = @_;
+
+ while (my ($name, $value) = each %args)
+ {
+ $args{$name} = sub { return $value };
+ }
+
+ bless \%args, $class;
+ }
+
+ sub can
+ {
+ my ($self, $name) = @_;
+ return $self->SUPER::can( $name ) unless blessed( $self );
+ return $self->{$name} if exists $self->{$name};
+ return $self->SUPER::can( $name );
+ }
+
+ sub DESTROY {}
+
+ sub AUTOLOAD
+ {
+ my $self = shift;
+ my ($method) = $AUTOLOAD =~ /::(\w+)$/;
+ return unless exists $self->{$method};
+ return $self->{$method}->( @_ );
+ }
+}
+
+my $foo = Foo->new( foo => 'it is foo', bar => 'it is not foo' );
+
+my ($can_foo, $can_baz);
+
+eval { die "Failure\n" };
+{
+ no warnings 'UNIVERSAL::can';
+ $can_foo = UNIVERSAL::can( $foo, 'foo' );
+ $can_baz = UNIVERSAL::can( $foo, 'baz' );
+}
+
+ok( defined $can_foo,
+ 'UNIVERSAL::can() should return a true value, if possible' );
+ok( defined &$can_foo, '... a code ref, if possible' );
+ok( ! defined $can_baz, '... or undef if not' );
+
+is( $can_foo->(), 'it is foo', '... the proper code ref' );
+is( $@, "Failure\n", '... not eating any exceptions already thrown' );
More information about the Pkg-perl-cvs-commits
mailing list