X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse.pm;h=6c09a7705462d99ea364512654c0724e79e97034;hp=e03e12a7d7dac90e27cb944a3386f3e192394123;hb=87ca293be7ca0041bbb86ad9609a498fb2010f4f;hpb=a81cc7b83f688ff21284b599a81e14a44bcdf401 diff --git a/lib/Mouse.pm b/lib/Mouse.pm index e03e12a..6c09a77 100644 --- a/lib/Mouse.pm +++ b/lib/Mouse.pm @@ -4,32 +4,45 @@ use warnings; use 5.006; use base 'Exporter'; -our $VERSION = '0.30'; +our $VERSION = '0.33_01'; use Carp 'confess'; use Scalar::Util 'blessed'; -use Mouse::Util; -use Mouse::Meta::Attribute; +use Mouse::Util qw(load_class is_class_loaded not_supported); + +use Mouse::Meta::Module; use Mouse::Meta::Class; +use Mouse::Meta::Role; +use Mouse::Meta::Attribute; use Mouse::Object; -use Mouse::Util::TypeConstraints; +use Mouse::Util::TypeConstraints (); -our @EXPORT = qw(extends has before after around override super blessed confess with); +our @EXPORT = qw( + extends with + has + before after around + override super + augment inner + + blessed confess +); our %is_removable = map{ $_ => undef } @EXPORT; delete $is_removable{blessed}; delete $is_removable{confess}; -sub extends { Mouse::Meta::Class->initialize(caller)->superclasses(@_) } +sub extends { Mouse::Meta::Class->initialize(scalar caller)->superclasses(@_) } sub has { - my $meta = Mouse::Meta::Class->initialize(caller); - $meta->add_attribute(@_); + my $meta = Mouse::Meta::Class->initialize(scalar caller); + my $name = shift; + + $meta->add_attribute($_ => @_) for ref($name) ? @{$name} : $name; } sub before { - my $meta = Mouse::Meta::Class->initialize(caller); + my $meta = Mouse::Meta::Class->initialize(scalar caller); my $code = pop; @@ -39,7 +52,7 @@ sub before { } sub after { - my $meta = Mouse::Meta::Class->initialize(caller); + my $meta = Mouse::Meta::Class->initialize(scalar caller); my $code = pop; @@ -49,7 +62,7 @@ sub after { } sub around { - my $meta = Mouse::Meta::Class->initialize(caller); + my $meta = Mouse::Meta::Class->initialize(scalar caller); my $code = pop; @@ -59,7 +72,7 @@ sub around { } sub with { - Mouse::Util::apply_all_roles((caller)[0], @_); + Mouse::Util::apply_all_roles(scalar(caller), @_); } our $SUPER_PACKAGE; @@ -92,41 +105,33 @@ sub override { }); } -sub init_meta { - # This used to be called as a function. This hack preserves - # backwards compatibility. - if ( $_[0] ne __PACKAGE__ ) { - return __PACKAGE__->init_meta( - for_class => $_[0], - base_class => $_[1], - metaclass => $_[2], - ); - } +sub inner { not_supported } +sub augment{ not_supported } +sub init_meta { shift; my %args = @_; my $class = $args{for_class} - or Carp::croak( - "Cannot call init_meta without specifying a for_class"); + or confess("Cannot call init_meta without specifying a for_class"); my $base_class = $args{base_class} || 'Mouse::Object'; my $metaclass = $args{metaclass} || 'Mouse::Meta::Class'; - Carp::croak("The Metaclass $metaclass must be a subclass of Mouse::Meta::Class.") + confess("The Metaclass $metaclass must be a subclass of Mouse::Meta::Class.") unless $metaclass->isa('Mouse::Meta::Class'); - + # make a subtype for each Mouse class - class_type($class) - unless find_type_constraint($class); + Mouse::Util::TypeConstraints::class_type($class) + unless Mouse::Util::TypeConstraints::find_type_constraint($class); my $meta = $metaclass->initialize($class); - $meta->superclasses($base_class) - unless $meta->superclasses; $meta->add_method(meta => sub{ - return Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]); + return $metaclass->initialize(ref($_[0]) || $_[0]); }); + $meta->superclasses($base_class) + unless $meta->superclasses; return $meta; } @@ -154,7 +159,7 @@ sub import { return; } - Mouse->init_meta( + $class->init_meta( for_class => $caller, ); @@ -188,61 +193,6 @@ sub unimport { } } -sub load_class { - my $class = shift; - - if (!Mouse::Util::is_valid_class_name($class)) { - my $display = defined($class) ? $class : 'undef'; - confess "Invalid class name ($display)"; - } - - return 1 if is_class_loaded($class); - - (my $file = "$class.pm") =~ s{::}{/}g; - - eval { CORE::require($file) }; - confess "Could not load class ($class) because : $@" if $@; - - return 1; -} - -my %is_class_loaded_cache; -sub is_class_loaded { - my $class = shift; - - return 0 if ref($class) || !defined($class) || !length($class); - - return 1 if exists $is_class_loaded_cache{$class}; - - # walk the symbol table tree to avoid autovififying - # \*{${main::}{"Foo::"}} == \*main::Foo:: - - my $pack = \*::; - foreach my $part (split('::', $class)) { - return 0 unless exists ${$$pack}{"${part}::"}; - $pack = \*{${$$pack}{"${part}::"}}; - } - - # check for $VERSION or @ISA - return ++$is_class_loaded_cache{$class} if exists ${$$pack}{VERSION} - && defined *{${$$pack}{VERSION}}{SCALAR}; - return ++$is_class_loaded_cache{$class} if exists ${$$pack}{ISA} - && defined *{${$$pack}{ISA}}{ARRAY}; - - # check for any method - foreach ( keys %{$$pack} ) { - next if substr($_, -2, 2) eq '::'; - return ++$is_class_loaded_cache{$class} if defined *{${$$pack}{$_}}{CODE}; - } - - # fail - return 0; -} - -sub class_of { - return Mouse::Meta::Class::class_of($_[0]); -} - 1; __END__ @@ -509,6 +459,8 @@ Yappo wu-lee +Goro Fuji (gfx) C<< >> + with plenty of code borrowed from L and L =head1 BUGS