| Subject: | Patch that add supports for Perl types |
Attached a patch that adds support for Perl types.
Regards
Christian Hansen
| Subject: | Params-Coerce-0.13.patch |
Only in .: Params-Coerce-0.13.patch
diff -ru ../Params-Coerce-0.13/lib/Params/Coerce.pm ./lib/Params/Coerce.pm
--- ../Params-Coerce-0.13/lib/Params/Coerce.pm Fri Jun 10 14:44:51 2005
+++ ./lib/Params/Coerce.pm Fri Mar 17 11:28:36 2006
@@ -215,11 +215,12 @@
=cut
use strict;
-use Carp ();
-use Scalar::Util ();
-use Params::Util '_IDENTIFIER',
- '_INSTANCE',
- '_CLASS';
+use Carp ();
+use Class::Inspector ();
+use Scalar::Util ();
+use Params::Util '_IDENTIFIER',
+ '_INSTANCE',
+ '_CLASS';
# Load Overhead: 52k
@@ -231,7 +232,11 @@
# The hint cache
my %hints = ();
+# Special types
+my %SPECIAL = map { $_ => 1 } qw( ARRAY CODE HASH SCALAR Regexp );
+# Loaded classes cache
+my %LOADED = %SPECIAL;
@@ -269,9 +274,9 @@
_function_exists($pkg, $method) and Carp::croak "Cannot create '${pkg}::$method'. It already exists";
# Make sure the class is loaded
- unless ( _loaded($want) ) {
+ unless ( $LOADED{$want} ||= Class::Inspector->loaded($want) ) {
eval "require $want";
- croak($@) if $@;
+ Carp::croak($@) if $@;
}
# Create the method in our caller
@@ -301,7 +306,9 @@
sub coerce($$) {
# Check what they want properly first
my $want = _CLASS($_[0]) or Carp::croak("Illegal class name '$_[0]'");
- _loaded($want) or Carp::croak("Tried to coerce to unloaded class '$want'");
+
+ $LOADED{$want} ||= Class::Inspector->loaded($want)
+ or Carp::croak("Tried to coerce to unloaded class '$want'");
# Now call the real function
_coerce($want, $_[1]);
@@ -316,11 +323,16 @@
# Internal version with less checks. Should ONLY be called once
# the first argument is FULLY validated.
sub _coerce {
- my $want = shift;
- my $have = Scalar::Util::blessed($_[0]) ? shift : return undef;
-
+ my $want = shift;
+ my $have = ref $_[0] ? shift : return undef;
+ my $blessed = 0;
# In the simplest case it is already what we need
- return $have if $have->isa($want);
+ if ( Scalar::Util::blessed($have) ) {
+ return $have if !$SPECIAL{$want} && $have->isa($want);
+ $blessed++;
+ } else {
+ return $have if ref $have eq $want;
+ }
# Is there a coercion hint for this combination
my $key = ref($have) . ',' . $want;
@@ -332,7 +344,7 @@
my $type = substr($hint, 0, 1, '');
if ( $type eq '>' ) {
# Direct Push
- $have = $have->$hint();
+ $have = $blessed ? $have->$hint() : ref($have)->$hint($have);
} elsif ( $type eq '<' ) {
# Direct Pull
$have = $want->$hint($have);
@@ -346,8 +358,12 @@
Carp::croak("Unknown coercion hint '$type$hint'");
}
- # Did we get what we wanted?
- _INSTANCE($have, $want);
+ # Did we get what we wanted?
+ if ( $SPECIAL{$want} ) {
+ return _REFTYPE($have, $want);
+ } else {
+ return _INSTANCE($have, $want);
+ }
}
# Try to work out how to get from one class to the other class
@@ -382,19 +398,14 @@
#####################################################################
# Support Functions
-# Is a class loaded.
-sub _loaded {
- no strict 'refs';
- foreach ( keys %{"$_[0]::"} ) {
- return 1 unless substr($_, -2, 2) eq '::';
- }
- '';
-}
-
# Does a function exist.
sub _function_exists {
no strict 'refs';
defined &{"$_[0]::$_[1]"};
+}
+
+sub _REFTYPE {
+ return ( Scalar::Util::reftype($_[0]) || '' ) eq $_[1] ? $_[0] : undef;
}
1;
diff -ru ../Params-Coerce-0.13/t/02_support.t ./t/02_support.t
--- ../Params-Coerce-0.13/t/02_support.t Fri Jun 10 14:44:51 2005
+++ ./t/02_support.t Fri Mar 17 11:29:22 2006
@@ -15,7 +15,7 @@
}
}
-use Test::More tests => 5;
+use Test::More tests => 3;
use Params::Coerce ();
@@ -24,10 +24,6 @@
#####################################################################
# Begin testing support methods
-
-# Test _loaded
-ok( Params::Coerce::_loaded('Params::Coerce'), '_loaded returns true for Params::Coerce' );
-ok( ! Params::Coerce::_loaded('Params::Coerce::Bad'), '_loaded returns false for Params::Coerce::Bad' );
# Test _function_exists
ok( Params::Coerce::_function_exists('Params::Coerce', '_function_exists'), '_function_exists sees itself' );
diff -ru ../Params-Coerce-0.13/t/03_usage.t ./t/03_usage.t
--- ../Params-Coerce-0.13/t/03_usage.t Fri Jun 10 14:44:51 2005
+++ ./t/03_usage.t Fri Mar 17 11:19:03 2006
@@ -15,7 +15,7 @@
}
}
-use Test::More tests => 34;
+use Test::More tests => 40;
use Params::Coerce;
@@ -98,7 +98,21 @@
}
-
+{
+ my $Foo = Params::Coerce::coerce 'Foo', {};
+ my $Hash = Params::Coerce::coerce 'HASH', $Foo;
+ isa_ok( $Foo, 'Foo' );
+ isa_ok( $Hash, 'HASH' );
+}
+
+{
+ my $Bar = Params::Coerce::coerce 'Bar', { x => 'y' };
+ my $Hash = Params::Coerce::coerce 'HASH', $Bar;
+ isa_ok( $Bar, 'Bar' );
+ isa_ok( $Hash, 'HASH' );
+ cmp_ok( $Bar->{x}, 'eq', 'y' );
+ cmp_ok( $Hash->{x}, 'eq', 'y' );
+}
@@ -110,7 +124,7 @@
use Params::Coerce 'from';
sub new {
- bless { }, shift;
+ bless {}, shift;
}
package Foo;
@@ -119,8 +133,20 @@
bless {}, shift;
}
-sub __as_Bar { Bar->new }
-sub __from_Bar { Foo->new }
+sub __as_Bar { Bar->new }
+sub __from_Bar { Foo->new }
+sub __as_HASH { {} }
+sub __from_HASH { Foo->new }
+
+package HASH;
+
+sub __as_Bar {
+ return bless( { %{ $_[1] } }, 'Bar' );
+}
+
+sub __from_Bar {
+ return { %{ $_[1] } };
+}
package Foo::Bar::Usage1;