diff --git a/lib/Lmo.pm b/lib/Lmo.pm new file mode 100644 index 00000000..55bd9bdb --- /dev/null +++ b/lib/Lmo.pm @@ -0,0 +1,363 @@ +# This program is copyright 2007-2011 Baron Schwartz, 2012 Percona Inc. +# Feedback and improvements are welcome. +# +# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED +# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF +# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. +# +# This program is free software; you can redistribute it and/or modify it under +# the terms of the GNU General Public License as published by the Free Software +# Foundation, version 2; OR the Perl Artistic License. On UNIX and similar +# systems, you can issue `man perlgpl' or `man perlartistic' to read these +# licenses. +# +# You should have received a copy of the GNU General Public License along with +# this program; if not, write to the Free Software Foundation, Inc., 59 Temple +# Place, Suite 330, Boston, MA 02111-1307 USA. +# ########################################################################### +# Lmo package +# ########################################################################### +# Package: Lmo +# Lmo provides a miniature object system in the style of Moose and Moo. +BEGIN { +$INC{"Lmo.pm"} = __FILE__; +package Lmo; +our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo. + +{ + # Gets the glob from a given string. + no strict 'refs'; + sub _glob_for { + return \*{shift()} + } + + # Gets the stash from a given string. + # A stash is a symbol table hash; rough explanation on + # http://perldoc.perl.org/perlguts.html#Stashes-and-Globs + # But the gist of it is that we can use a hash-like thing to + # refer to a class and modify it. + sub _stash_for { + return \%{ shift() . "::" }; + } +} + +use strict; +use warnings qw( FATAL all ); + +use Carp (); +use Scalar::Util qw(looks_like_number blessed); + +use Lmo::Meta; +use Lmo::Object; +use Lmo::Types; + +my %export_for; +sub import { + # Set warnings and strict for the caller. + warnings->import(qw(FATAL all)); + strict->import(); + + my $caller = scalar caller(); # Caller's package + my $caller_pkg = $caller . "::"; # Caller's package with :: at the end + my %exports = ( + extends => \&extends, + has => \&has, + ); + + # We keep this so code doing 'no Mo;' actually does a cleanup. + $export_for{$caller} = [ keys %exports ]; + + # Export has, extends and sosuch. + for my $keyword ( keys %exports ) { + *{ _glob_for "${caller}::$keyword" } = $exports{$keyword} + } + + # Set up our caller's ISA, unless they already set it manually themselves, + # in which case we assume they know what they are doing. + # XXX weird syntax here because we want to call the classes' extends at + # least once, to avoid warnings. + if ( !@{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] } ) { + @_ = "Lmo::Object"; + goto *{ _glob_for "${caller}::extends" }{CODE}; + } +}; + +sub extends { + my $caller = scalar caller(); + for my $class ( @_ ) { + _load_module($class); + } + _set_package_isa($caller, @_); + _set_inherited_metadata($caller); +} + +sub _load_module { + my ($class) = @_; + + # Try loading the class, but don't croak if we fail. + (my $file = $class) =~ s{::|'}{/}g; + $file .= '.pm'; + { local $@; eval { require "$file" } } # or warn $@; + return; +} + +sub has { + my $names = shift; + my $caller = scalar caller(); + + my $class_metadata = Lmo::Meta->metadata_for($caller); + + for my $attribute ( ref $names ? @$names : $names ) { + my %args = @_; + my $method = ($args{is} || '') eq 'ro' + ? sub { + Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller}::${attribute}") + if $#_; + return $_[0]{$attribute}; + } + : sub { + return $#_ + ? $_[0]{$attribute} = $_[1] + : $_[0]{$attribute}; + }; + + $class_metadata->{$attribute} = (); + + # isa => Constaint, + if ( my $type_check = $args{isa} ) { + my $check_name = $type_check; + + if ( my ($aggregate_type, $inner_type) = $type_check =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + $type_check = Lmo::Types::_nested_constraints($attribute, $aggregate_type, $inner_type); + } + + my $check_sub = sub { + my ($new_val) = @_; + Lmo::Types::check_type_constaints($attribute, $type_check, $check_name, $new_val); + }; + + $class_metadata->{$attribute}{isa} = [$check_name, $check_sub]; + my $orig_method = $method; + $method = sub { + $check_sub->($_[1]) if $#_; + goto &$orig_method; + }; + } + + # XXX TODO: Inline builder and default into the actual method, for speed. + # builder => '_builder_method', + if ( my $builder = $args{builder} ) { + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$builder + : goto &$original_method + }; + } + + # default => CodeRef, + if ( my $code = $args{default} ) { + Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef") + unless ref($code) eq 'CODE'; + my $original_method = $method; + $method = sub { + $#_ + ? goto &$original_method + : ! exists $_[0]{$attribute} + ? $_[0]{$attribute} = $_[0]->$code + : goto &$original_method + }; + } + + # does => 'Role', + if ( my $role = $args{does} ) { + my $original_method = $method; + $method = sub { + if ( $#_ ) { + Carp::confess(qq) + unless Scalar::Util::blessed($_[1]) && eval { $_[1]->does($role) } + } + goto &$original_method + }; + } + + # coerce => CodeRef, + if ( my $coercion = $args{coerce} ) { + $class_metadata->{$attribute}{coerce} = $coercion; + my $original_method = $method; + $method = sub { + if ( $#_ ) { + return $original_method->($_[0], $coercion->($_[1])) + } + goto &$original_method; + } + } + + # Actually put the attribute's accessor in the class + *{ _glob_for "${caller}::$attribute" } = $method; + + if ( $args{required} ) { + $class_metadata->{$attribute}{required} = 1; + } + + if ($args{clearer}) { + *{ _glob_for "${caller}::$args{clearer}" } + = sub { delete shift->{$attribute} } + } + + if ($args{predicate}) { + *{ _glob_for "${caller}::$args{predicate}" } + = sub { exists shift->{$attribute} } + } + + if ($args{handles}) { + _has_handles($caller, $attribute, \%args); + } + + if (exists $args{init_arg}) { + $class_metadata->{$attribute}{init_arg} = $args{init_arg}; + } + } +} + + + +# handles handles +sub _has_handles { + my ($caller, $attribute, $args) = @_; + my $handles = $args->{handles}; + + my $ref = ref $handles; + my $kv; + if ( $ref eq ref [] ) { + # handles => [ ... list of methods ... ], + $kv = { map { $_,$_ } @{$handles} }; + } + elsif ( $ref eq ref {} ) { + # handles => { 'method_to_install' => 'original_method' | [ 'original_method', ... curried arguments ... ], }, + $kv = $handles; + } + elsif ( $ref eq ref qr// ) { + # handles => qr/PAT/, + Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)") + unless $args->{isa}; + my $target_class = $args->{isa}; + $kv = { + map { $_, $_ } + grep { $_ =~ $handles } + grep { !exists $Lmo::Object::{$_} && $target_class->can($_) } + grep { $_ ne 'has' && $_ ne 'extends' } + keys %{ _stash_for $target_class } + }; + } + else { + Carp::confess("handles for $ref not yet implemented"); + } + + while ( my ($method, $target) = each %{$kv} ) { + my $name = _glob_for "${caller}::$method"; + Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation") + if defined &$name; + + # If we have an arrayref, they are currying some arguments. + my ($target, @curried_args) = ref($target) ? @$target : $target; + *$name = sub { + my $self = shift; + my $delegate_to = $self->$attribute(); + my $error = "Cannot delegate $method to $target because the value of $attribute"; + Carp::confess("$error is not defined") unless $delegate_to; + Carp::confess("$error is not an object (got '$delegate_to')") + unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target)); + return $delegate_to->$target(@curried_args, @_); + } + } +} + +# Sets a package's @ISA to the list passed in. Overwrites any previous values. +sub _set_package_isa { + my ($package, @new_isa) = @_; + my $package_isa = \*{ _glob_for "${package}::ISA" }; + # This somewhat weirder syntax is here to work around a Perl 5.10.0 bug; + # For whatever reason, some other variants weren't setting ISA. + @{*$package_isa} = @new_isa; +} + +# Each class has its own metadata. When a class inhyerits attributes, +# it should also inherit the attribute metadata. +sub _set_inherited_metadata { + my $class = shift; + my $class_metadata = Lmo::Meta->metadata_for($class); + my $linearized_isa = mro::get_linear_isa($class); + my %new_metadata; + + # Walk @ISA in reverse, grabbing the metadata for each + # class. Attributes with the same name defined in more + # specific classes override their parent's attributes. + for my $isa_class (reverse @$linearized_isa) { + my $isa_metadata = Lmo::Meta->metadata_for($isa_class); + %new_metadata = ( + %new_metadata, + %$isa_metadata, + ); + } + %$class_metadata = %new_metadata; +} + +sub unimport { + my $caller = scalar caller(); + my $stash = _stash_for( $caller ); + + delete $stash->{$_} for @{$export_for{$caller}}; +} + +sub Dumper { + require Data::Dumper; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Sortkeys = 0; + local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Terse = 1; + + Data::Dumper::Dumper(@_) +} + +BEGIN { + # mro is the method resolution order. The module itself is core in + # recent Perls; In older Perls it's available from MRO::Compat from + # CPAN, and in case that isn't available to us, we inline the barest + # funcionality. + if ($] >= 5.010) { + { local $@; require mro; } + } + else { + local $@; + eval { + require MRO::Compat; + } or do { + *mro::get_linear_isa = *mro::get_linear_isa_dfs = sub { + no strict 'refs'; + + my $classname = shift; + + my @lin = ($classname); + my %stored; + foreach my $parent (@{"$classname\::ISA"}) { + my $plin = mro::get_linear_isa_dfs($parent); + foreach (@$plin) { + next if exists $stored{$_}; + push(@lin, $_); + $stored{$_} = 1; + } + } + return \@lin; + }; + } + } +} + +} +1; +# ########################################################################### +# End Lmo package +# ########################################################################### diff --git a/lib/Lmo/Meta.pm b/lib/Lmo/Meta.pm new file mode 100644 index 00000000..a60a9af4 --- /dev/null +++ b/lib/Lmo/Meta.pm @@ -0,0 +1,57 @@ +use strict; +use warnings qw( FATAL all ); + +use Carp (); +use Scalar::Util qw(looks_like_number blessed); + +{ + package Lmo::Meta; + my %metadata_for; + + sub new { + shift; + return Lmo::Meta::Class->new(@_); + } + + sub metadata_for { + my $self = shift; + my ($class) = @_; + + return $metadata_for{$class} ||= {}; + } +} + +{ + package Lmo::Meta::Class; + + sub new { + my $class = shift; + return bless { @_ }, $class + } + + sub class { shift->{class} } + + sub attributes { + my $self = shift; + return keys %{Lmo::Meta->metadata_for($self->class)} + } + + sub attributes_for_new { + my $self = shift; + my @attributes; + + my $class_metadata = Lmo::Meta->metadata_for($self->class); + while ( my ($attr, $meta) = each %$class_metadata ) { + if ( exists $meta->{init_arg} ) { + push @attributes, $meta->{init_arg} + if defined $meta->{init_arg}; + } + else { + push @attributes, $attr; + } + } + return @attributes; + } +} + +1; diff --git a/lib/Lmo/Object.pm b/lib/Lmo/Object.pm new file mode 100644 index 00000000..d951e12f --- /dev/null +++ b/lib/Lmo/Object.pm @@ -0,0 +1,104 @@ +# Mo::Object is the parent of every Mo-derived object. Here's where new +# and BUILDARGS gets inherited from. +package Lmo::Object; + +use strict; +use warnings qw( FATAL all ); + +use Carp (); +use Scalar::Util qw(looks_like_number blessed); + +use Lmo::Meta; + +{ + # Gets the glob from a given string. + no strict 'refs'; + sub _glob_for { + return \*{shift()} + } +} + +sub new { + my $class = shift; + my $args = $class->BUILDARGS(@_); + + my $class_metadata = Lmo::Meta->metadata_for($class); + + my @args_to_delete; + while ( my ($attr, $meta) = each %$class_metadata ) { + next unless exists $meta->{init_arg}; + my $init_arg = $meta->{init_arg}; + + # If init_arg is defined, then we + if ( defined $init_arg ) { + $args->{$attr} = delete $args->{$init_arg}; + } + else { + push @args_to_delete, $attr; + } + } + + delete $args->{$_} for @args_to_delete; + + for my $attribute ( keys %$args ) { + # coerce + if ( my $coerce = $class_metadata->{$attribute}{coerce} ) { + $args->{$attribute} = $coerce->($args->{$attribute}); + } + # isa + if ( my $isa_check = $class_metadata->{$attribute}{isa} ) { + my ($check_name, $check_sub) = @$isa_check; + $check_sub->($args->{$attribute}); + } + } + + while ( my ($attribute, $meta) = each %$class_metadata ) { + next unless $meta->{required}; + Carp::confess("Attribute ($attribute) is required for $class") + if ! exists $args->{$attribute} + } + + my $self = bless $args, $class; + + # BUILD + my @build_subs; + my $linearized_isa = mro::get_linear_isa($class); + + for my $isa_class ( @$linearized_isa ) { + unshift @build_subs, *{ _glob_for "${isa_class}::BUILD" }{CODE}; + } + # If &class::BUILD exists, for every class in + # the linearized ISA, call it. + # XXX I _think_ that this uses exists correctly, since + # a class could define a stub for BUILD and then AUTOLOAD + # the body. Should check what Moose does. + my @args = %$args; + for my $sub (grep { defined($_) && exists &$_ } @build_subs) { + # @args must be defined outside of this loop, + # as changes to @_ in one BUILD should propagate to another + $sub->( $self, @args); + } + return $self; +} + +# Base BUILDARGS. +sub BUILDARGS { + shift; # No need for the classname + if ( @_ == 1 && ref($_[0]) ) { + Carp::confess("Single parameters to new() must be a HASH ref, not $_[0]") + unless ref($_[0]) eq ref({}); + return {%{$_[0]}} # We want a new reference, always + } + else { + return { @_ }; + } +} + +sub meta { + my $class = shift; + $class = Scalar::Util::blessed($class) || $class; + return Lmo::Meta->new(class => $class); +} + + +1; diff --git a/lib/Lmo/Types.pm b/lib/Lmo/Types.pm new file mode 100644 index 00000000..12d8b540 --- /dev/null +++ b/lib/Lmo/Types.pm @@ -0,0 +1,98 @@ +package Lmo::Types; + +use strict; +use warnings qw( FATAL all ); + +use Carp (); +use Scalar::Util qw(looks_like_number blessed); + +# Basic types for isa. If you want a new type, either add it here, +# or give isa a coderef. + +our %TYPES = ( + Bool => sub { !$_[0] || (defined $_[0] && looks_like_number($_[0]) && $_[0] == 1) }, + Num => sub { defined $_[0] && looks_like_number($_[0]) }, + Int => sub { defined $_[0] && looks_like_number($_[0]) && $_[0] == int($_[0]) }, + Str => sub { defined $_[0] }, + Object => sub { defined $_[0] && blessed($_[0]) }, + FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened }, + + map { + my $type = /R/ ? $_ : uc $_; + $_ . "Ref" => sub { ref $_[0] eq $type } + } qw(Array Code Hash Regexp Glob Scalar) +); + +sub check_type_constaints { + my ($attribute, $type_check, $check_name, $val) = @_; + ( ref($type_check) eq 'CODE' + ? $type_check->($val) + : (ref $val eq $type_check + || ($val && $val eq $type_check) + || (exists $TYPES{$type_check} && $TYPES{$type_check}->($val))) + ) + || Carp::confess( + qq + . qq + . (defined $val ? Lmo::Dumper($val) : 'undef') ) +} + +# Nested (or parametized) constraints look like this: ArrayRef[CONSTRAINT] or +# Maybe[CONSTRAINT]. This function returns a coderef that implements one of +# these. +sub _nested_constraints { + my ($attribute, $aggregate_type, $type) = @_; + + my $inner_types; + if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) { + # If the inner constraint -- the part within brackets -- is also a parametized + # constraint, then call this function recursively. + $inner_types = _nested_constraints($1, $2); + } + else { + # Otherwise, try checking if it's one of the built-in types. + $inner_types = $TYPES{$type}; + } + + if ( $aggregate_type eq 'ArrayRef' ) { + return sub { + my ($val) = @_; + return unless ref($val) eq ref([]); + + if ($inner_types) { + for my $value ( @{$val} ) { + return unless $inner_types->($value) + } + } + else { + # $inner_types isn't set, we are dealing with a class name. + for my $value ( @{$val} ) { + return unless $value && ($value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type))); + } + } + return 1; + }; + } + elsif ( $aggregate_type eq 'Maybe' ) { + return sub { + my ($value) = @_; + # For Maybe, undef is valid + return 1 if ! defined($value); + # Otherwise, defer to the inner type + if ($inner_types) { + return unless $inner_types->($value) + } + else { + return unless $value eq $type + || (Scalar::Util::blessed($value) && $value->isa($type)); + } + return 1; + } + } + else { + Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe"); + } +} + +1; diff --git a/t/lib/Mo/Bar.pm b/t/lib/Lmo/Bar.pm similarity index 77% rename from t/lib/Mo/Bar.pm rename to t/lib/Lmo/Bar.pm index 1a4a2410..91b7cc7b 100644 --- a/t/lib/Mo/Bar.pm +++ b/t/lib/Lmo/Bar.pm @@ -1,4 +1,4 @@ package Bar; -use Mo; +use Lmo; extends 'Foo'; 1; diff --git a/t/lib/Mo/Boo.pm b/t/lib/Lmo/Boo.pm similarity index 76% rename from t/lib/Mo/Boo.pm rename to t/lib/Lmo/Boo.pm index b6a716ee..8096c926 100644 --- a/t/lib/Mo/Boo.pm +++ b/t/lib/Lmo/Boo.pm @@ -1,5 +1,5 @@ package Boo; -use Mo; +use Lmo; has 'buff'; diff --git a/t/lib/Mo/Foo.pm b/t/lib/Lmo/Foo.pm similarity index 77% rename from t/lib/Mo/Foo.pm rename to t/lib/Lmo/Foo.pm index 728da69d..d2c896c8 100644 --- a/t/lib/Mo/Foo.pm +++ b/t/lib/Lmo/Foo.pm @@ -1,5 +1,5 @@ package Foo; -use Mo; +use Lmo; has 'stuff'; diff --git a/t/lib/Mo/build.t b/t/lib/Lmo/build.t similarity index 78% rename from t/lib/Mo/build.t rename to t/lib/Lmo/build.t index 1aa70c0b..2cc201fc 100644 --- a/t/lib/Mo/build.t +++ b/t/lib/Lmo/build.t @@ -14,31 +14,31 @@ use Test::More; $main::count = 1; package Foo; -use Mo 'build'; +use Lmo 'build'; has 'foo' => (is => 'rw'); sub BUILD { my $self = shift; - ::is_deeply(\@_, [qw(stuff 1)], "Foo's BUILD doesn't get the class name"); + ::is_deeply([sort @_], [sort qw(stuff 1)], "Foo's BUILD doesn't get the class name"); $self->foo($main::count++); } package Bar; -use Mo; +use Lmo; extends 'Foo'; has 'bar' => (is => 'rw'); package Baz; -use Mo; +use Lmo; extends 'Bar'; has 'baz' => (is => 'rw'); sub BUILD { my $self = shift; - ::is_deeply(\@_, [qw(stuff 1)], "Baz's BUILD doesn't get the class name"); + ::is_deeply([sort @_], [sort qw(stuff 1)], "Baz's BUILD doesn't get the class name"); $self->baz($main::count++); } package Gorch; -use Mo; +use Lmo; extends 'Baz'; has 'gorch' => (is => 'rw'); diff --git a/t/lib/Mo/buildargs.t b/t/lib/Lmo/buildargs.t similarity index 93% rename from t/lib/Mo/buildargs.t rename to t/lib/Lmo/buildargs.t index 403bd55d..ddc660da 100644 --- a/t/lib/Mo/buildargs.t +++ b/t/lib/Lmo/buildargs.t @@ -15,13 +15,13 @@ $main::count = 0; { package Nothing; - use Mo; + use Lmo; has nothing_special => ( is => 'rw' ); } ok(Nothing->can("BUILDARGS"), "Every class automatically gets buildargs"); package Foo; -use Mo; +use Lmo; has 'foo' => (is => 'rw'); sub BUILDARGS { my $class = shift; @@ -30,12 +30,12 @@ sub BUILDARGS { } package Bar; -use Mo; +use Lmo; extends 'Foo'; has 'bar' => (is => 'rw'); package Baz; -use Mo; +use Lmo; extends 'Bar'; has 'baz' => (is => 'rw'); sub BUILDARGS { @@ -45,7 +45,7 @@ sub BUILDARGS { } package Gorch; -use Mo; +use Lmo; extends 'Baz'; has 'gorch' => (is => 'rw'); @@ -53,7 +53,7 @@ package main; $main::count = 0; my $g = Foo->new; -is $main::count, 1, "A class with no explicit parent inherits SUPER::BUILDARGS from Mo::Object"; +is $main::count, 1, "A class with no explicit parent inherits SUPER::BUILDARGS from Lmo::Object"; $main::count = 0; $g = Gorch->new; diff --git a/t/lib/Mo/coerce.t b/t/lib/Lmo/coerce.t similarity index 98% rename from t/lib/Mo/coerce.t rename to t/lib/Lmo/coerce.t index 8af02b08..5aa1234f 100644 --- a/t/lib/Mo/coerce.t +++ b/t/lib/Lmo/coerce.t @@ -12,7 +12,7 @@ use English qw(-no_match_vars); use Test::More; package Foo::coerce; -use Mo; +use Lmo; has 'stuff' => (coerce => sub { uc $_[0] }); diff --git a/t/lib/Mo/extends.t b/t/lib/Lmo/extends.t similarity index 91% rename from t/lib/Mo/extends.t rename to t/lib/Lmo/extends.t index 30eb8731..a46ff3df 100644 --- a/t/lib/Mo/extends.t +++ b/t/lib/Lmo/extends.t @@ -11,7 +11,7 @@ use warnings FATAL => 'all'; use English qw(-no_match_vars); use Test::More; -use lib "$ENV{PERCONA_TOOLKIT_BRANCH}/t/lib/Mo"; +use lib "$ENV{PERCONA_TOOLKIT_BRANCH}/t/lib/Lmo"; use Bar; my $b = Bar->new; diff --git a/t/lib/Mo/handles.t b/t/lib/Lmo/handles.t similarity index 93% rename from t/lib/Mo/handles.t rename to t/lib/Lmo/handles.t index 653c396f..af6e822a 100644 --- a/t/lib/Mo/handles.t +++ b/t/lib/Lmo/handles.t @@ -21,14 +21,14 @@ use Test::More; { package Foo; - use Mo qw(is required handles default builder); + use Lmo qw(is required handles default builder); has 'bar' => (is => 'rw', default => sub { 10 }); sub baz { 42 } package Bar; - use Mo qw(is required handles default builder); + use Lmo qw(is required handles default builder); has 'foo' => ( is => 'rw', @@ -99,13 +99,13 @@ is($bar->foo_bar, 20, '... correctly curried a single argument'); { package Engine; - use Mo qw(is required handles default builder); + use Lmo qw(is required handles default builder); sub go { 'Engine::go' } sub stop { 'Engine::stop' } package Car; - use Mo qw(is required handles default builder); + use Lmo qw(is required handles default builder); has 'engine' => ( is => 'rw', @@ -137,14 +137,14 @@ is($car->stop, 'Engine::stop', '... got the right value from ->stop'); { package Baz; - use Mo qw(is required handles default builder); + use Lmo qw(is required handles default builder); sub foo { 'Baz::foo' } sub bar { 'Baz::bar' } sub boo { 'Baz::boo' } package Baz::Proxy1; - use Mo qw(is required handles default builder); + use Lmo qw(is required handles default builder); has 'baz' => ( is => 'ro', @@ -154,7 +154,7 @@ is($car->stop, 'Engine::stop', '... got the right value from ->stop'); ); package Baz::Proxy2; - use Mo qw(is required handles default builder); + use Lmo qw(is required handles default builder); has 'baz' => ( is => 'ro', @@ -164,7 +164,7 @@ is($car->stop, 'Engine::stop', '... got the right value from ->stop'); ); package Baz::Proxy3; - use Mo qw(is required handles default builder); + use Lmo qw(is required handles default builder); has 'baz' => ( is => 'ro', @@ -228,14 +228,14 @@ is($car->stop, 'Engine::stop', '... got the right value from ->stop'); requires 'bar'; package Foo::Baz; - use Mo qw(is required handles default builder); + use Lmo qw(is required handles default builder); sub foo { 'Foo::Baz::FOO' } sub bar { 'Foo::Baz::BAR' } sub baz { 'Foo::Baz::BAZ' } package Foo::Thing; - use Mo qw(is required handles default builder); + use Lmo qw(is required handles default builder); has 'thing' => ( is => 'rw', @@ -244,7 +244,7 @@ is($car->stop, 'Engine::stop', '... got the right value from ->stop'); ); package Foo::OtherThing; - use Mo qw(is required handles default builder); + use Lmo qw(is required handles default builder); use Moose::Util::TypeConstraints; has 'other_thing' => ( @@ -288,7 +288,7 @@ is($car->stop, 'Engine::stop', '... got the right value from ->stop'); { package Foo::Autoloaded; - use Mo qw(is required handles default builder); + use Lmo qw(is required handles default builder); sub AUTOLOAD { my $self = shift; @@ -304,7 +304,7 @@ is($car->stop, 'Engine::stop', '... got the right value from ->stop'); } package Bar::Autoloaded; - use Mo qw(is required handles default builder); + use Lmo qw(is required handles default builder); has 'foo' => ( is => 'rw', @@ -313,7 +313,7 @@ is($car->stop, 'Engine::stop', '... got the right value from ->stop'); ); package Baz::Autoloaded; - use Mo qw(is required handles default builder); + use Lmo qw(is required handles default builder); has 'foo' => ( is => 'rw', @@ -322,7 +322,7 @@ is($car->stop, 'Engine::stop', '... got the right value from ->stop'); ); package Goorch::Autoloaded; - use Mo qw(is required handles default builder); + use Lmo qw(is required handles default builder); eval { has 'foo' => ( @@ -447,7 +447,7 @@ is($car->stop, 'Engine::stop', '... got the right value from ->stop'); { package Delegator; - use Mo qw(is required handles default builder); + use Lmo qw(is required handles default builder); sub full { 1 } sub stub; diff --git a/t/lib/Mo/init_arg.t b/t/lib/Lmo/init_arg.t similarity index 95% rename from t/lib/Mo/init_arg.t rename to t/lib/Lmo/init_arg.t index b6fab8d4..2c136a0a 100644 --- a/t/lib/Mo/init_arg.t +++ b/t/lib/Lmo/init_arg.t @@ -15,7 +15,7 @@ use Test::More; { package Foo; - use Mo qw( is init_arg ); + use Lmo qw( is init_arg ); eval { has 'foo' => ( @@ -64,7 +64,7 @@ use Test::More; { package Foo2; - use Mo qw( is init_arg clearer default ); + use Lmo qw( is init_arg clearer default ); my $counter; eval { diff --git a/t/lib/Mo/is.t b/t/lib/Lmo/is.t similarity index 97% rename from t/lib/Mo/is.t rename to t/lib/Lmo/is.t index 84ea47d1..02f1a63c 100644 --- a/t/lib/Mo/is.t +++ b/t/lib/Lmo/is.t @@ -12,7 +12,7 @@ use English qw(-no_match_vars); use Test::More; package Foo::is; -use Mo qw(is); +use Lmo qw(is); has 'stuff' => (is => 'ro'); diff --git a/t/lib/Mo/isa.t b/t/lib/Lmo/isa.t similarity index 97% rename from t/lib/Mo/isa.t rename to t/lib/Lmo/isa.t index 426c2cb9..b52d67f9 100644 --- a/t/lib/Mo/isa.t +++ b/t/lib/Lmo/isa.t @@ -29,7 +29,7 @@ sub lives_ok (&;$) { } package Foo::isa; -use Mo qw(isa); +use Lmo qw(isa); my @types = qw(Bool Num Int Str ArrayRef CodeRef HashRef RegexpRef); my @refs = ([], sub { }, {}, qr( )); @@ -191,11 +191,11 @@ my $thisperl = $^X; if ($^O ne 'VMS') {$thisperl .= $Config{_exe} unless $thisperl =~ m/$Config{_exe}$/i;} -my $pm_test = "$PerconaTest::trunk/t/lib/Mo/isa_subtest.pm"; +my $pm_test = "$PerconaTest::trunk/t/lib/Lmo/isa_subtest.pm"; ok( scalar(IPC::Cmd::run(command => [$thisperl, $pm_test])), - "Mo types work with Scalar::Util::PP", + "Lmo types work with Scalar::Util::PP", ); done_testing; diff --git a/t/lib/Mo/isa_subtest.pm b/t/lib/Lmo/isa_subtest.pm similarity index 98% rename from t/lib/Mo/isa_subtest.pm rename to t/lib/Lmo/isa_subtest.pm index 4097f10b..4cdd29e3 100644 --- a/t/lib/Mo/isa_subtest.pm +++ b/t/lib/Lmo/isa_subtest.pm @@ -16,7 +16,7 @@ use warnings; { package isa_subtest; - use Mo; + use Lmo; has attr => ( is => 'rw', diff --git a/t/lib/Lmo/meta.t b/t/lib/Lmo/meta.t new file mode 100644 index 00000000..40106511 --- /dev/null +++ b/t/lib/Lmo/meta.t @@ -0,0 +1,83 @@ +#!/usr/bin/perl + +BEGIN { + die "The PERCONA_TOOLKIT_BRANCH environment variable is not set.\n" + unless $ENV{PERCONA_TOOLKIT_BRANCH} && -d $ENV{PERCONA_TOOLKIT_BRANCH}; + unshift @INC, "$ENV{PERCONA_TOOLKIT_BRANCH}/lib"; +}; + +use strict; +use warnings FATAL => 'all'; +use English qw(-no_match_vars); +use Test::More; + +sub throws_ok (&;$) { + my ( $code, $pat, $msg ) = @_; + eval { $code->(); }; + like ( $EVAL_ERROR, $pat, $msg ); +} + +{ + package Metatest; + use Lmo; + + has stuff => ( is => 'rw', required => 1 ); + has init_stuff1 => ( is => 'rw', init_arg => undef ); + has init_stuff2 => ( is => 'rw', init_arg => 'fancy_name' ); +} +{ +package Metatest::child; + use Lmo; + extends 'Metatest'; + + has more_stuff => ( is => 'rw' ); +} + +my $obj = Metatest->new( stuff => 100 ); + +can_ok($obj, 'meta'); + +my $meta = $obj->meta(); + +is_deeply( + [ sort $meta->attributes ], + [ sort qw(stuff init_stuff1 init_stuff2) ], + "->attributes works" +); + +is_deeply( + [ sort $meta->attributes_for_new ], + [ sort qw(stuff fancy_name) ], + "->attributes_for_new works" +); + +# Do these BEFORE initializing ::extends +my $meta2 = Metatest::child->meta(); +is_deeply( + [ sort $meta2->attributes ], + [ sort qw(stuff init_stuff1 init_stuff2 more_stuff) ], + "->attributes works on a child class" +); + +is_deeply( + [ sort $meta2->attributes_for_new ], + [ sort qw(stuff fancy_name more_stuff) ], + "->attributes_for_new works in a child class" +); + +my $meta3 = Metatest::child->new(stuff => 10)->meta(); +is_deeply( + [ sort $meta3->attributes ], + [ sort qw(stuff init_stuff1 init_stuff2 more_stuff) ], + "->attributes works on an initialized child class" +); + +is_deeply( + [ sort $meta3->attributes_for_new ], + [ sort qw(stuff fancy_name more_stuff) ], + "->attributes_for_new works in an initialized child class" +); + +throws_ok { Metatest::child->new() } qr/\QAttribute (stuff) is required for Metatest::child/; + +done_testing; diff --git a/t/lib/Mo/object.t b/t/lib/Lmo/object.t similarity index 90% rename from t/lib/Mo/object.t rename to t/lib/Lmo/object.t index 37a71ea4..c54266c9 100644 --- a/t/lib/Mo/object.t +++ b/t/lib/Lmo/object.t @@ -10,7 +10,7 @@ use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use Test::More; -use lib "$ENV{PERCONA_TOOLKIT_BRANCH}/t/lib/Mo"; +use lib "$ENV{PERCONA_TOOLKIT_BRANCH}/t/lib/Lmo"; { package Clean; use Foo; } diff --git a/t/lib/Mo/required.t b/t/lib/Lmo/required.t similarity index 86% rename from t/lib/Mo/required.t rename to t/lib/Lmo/required.t index b7319317..7ef93ff1 100644 --- a/t/lib/Mo/required.t +++ b/t/lib/Lmo/required.t @@ -13,14 +13,14 @@ use Test::More; #============ package Foo::required; -use Mo qw(required); +use Lmo qw(required); has 'stuff' => (required => 1); has 'stuff2' => (required => 1); has 'foo' => (); #============ package Foo::required_is; -use Mo qw(required); +use Lmo qw(required); has 'stuff' => (required => 1, is => 'ro'); #============ @@ -28,7 +28,7 @@ has 'stuff' => (required => 1, is => 'ro'); package main; my $f0 = eval { Foo::required->new(stuff2 => 'foobar') }; -like $@, qr/^\QAttribute (stuff) is required/, 'Mo dies when a required value is not provided'; +like $@, qr/^\QAttribute (stuff) is required/, 'Lmo dies when a required value is not provided'; my $f = Foo::required->new(stuff => 'fubar', stuff2 => 'foobar'); is $f->stuff, 'fubar', 'Object is correctly initialized when required values are provided'; diff --git a/t/lib/Mo/strict.t b/t/lib/Lmo/strict.t similarity index 87% rename from t/lib/Mo/strict.t rename to t/lib/Lmo/strict.t index eb98e4dd..9e3e0b5c 100644 --- a/t/lib/Mo/strict.t +++ b/t/lib/Lmo/strict.t @@ -11,9 +11,9 @@ use warnings FATAL => 'all'; use English qw(-no_match_vars); use Test::More; -eval 'package Foo; use Mo; $x = 1'; +eval 'package Foo; use Lmo; $x = 1'; like $@, qr/Global symbol "\$x" requires explicit package name/, - 'Mo is strict'; + 'Lmo is strict'; done_testing; diff --git a/t/lib/Mo/test.t b/t/lib/Lmo/test.t similarity index 85% rename from t/lib/Mo/test.t rename to t/lib/Lmo/test.t index 87682a31..0772900e 100644 --- a/t/lib/Mo/test.t +++ b/t/lib/Lmo/test.t @@ -13,18 +13,18 @@ use Test::More; #============ package Foo; -use Mo; +use Lmo; has 'this'; #============ package main; -ok defined(&Foo::has), 'Mo exports has'; -ok defined(&Foo::extends), 'Mo exports extends'; -ok not(defined(&Foo::new)), 'Mo does not export new'; -ok 'Foo'->isa('Mo::Object'), 'Foo isa Mo::Object'; -is "@Foo::ISA", "Mo::Object", '@Foo::ISA is Mo::Object'; +ok defined(&Foo::has), 'Lmo exports has'; +ok defined(&Foo::extends), 'Lmo exports extends'; +ok not(defined(&Foo::new)), 'Lmo does not export new'; +ok 'Foo'->isa('Lmo::Object'), 'Foo isa Lmo::Object'; +is "@Foo::ISA", "Lmo::Object", '@Foo::ISA is Lmo::Object'; ok 'Foo'->can('new'), 'Foo can new'; ok 'Foo'->can('this'), 'Foo can this'; @@ -50,7 +50,7 @@ ok not(defined($f->{this})), '{this} is not defined'; #============ package Bar; -use Mo 'builder', 'default'; +use Lmo 'builder', 'default'; extends 'Foo'; has 'that'; @@ -70,7 +70,7 @@ has guess => ( #============ package main; -ok 'Bar'->isa('Mo::Object'), 'Bar isa Mo::Object'; +ok 'Bar'->isa('Lmo::Object'), 'Bar isa Lmo::Object'; ok 'Bar'->isa('Foo'), 'Bar isa Foo'; is "@Bar::ISA", 'Foo', '@Bar::ISA is Foo'; ok 'Bar'->can('new'), 'Bar can new'; @@ -85,7 +85,7 @@ my $b = Bar->new( is ref($b), 'Bar', 'Object created'; ok $b->isa('Foo'), 'Inheritance works'; -ok $b->isa('Mo::Object'), 'Bar isa Mo::Object since Foo isa Mo::Object'; +ok $b->isa('Lmo::Object'), 'Bar isa Lmo::Object since Foo isa Lmo::Object'; is $b->this, 'thing', 'Read works in parent class'; is $b->that, 'thong', 'Read works in current class'; is ref($b->them), 'ARRAY', 'default works'; @@ -103,7 +103,7 @@ is $b->guess, 'me me me', 'default trumps builder'; #============ package Baz; -use Mo 'build'; +use Lmo 'build'; has 'foo'; @@ -114,7 +114,7 @@ sub BUILD { #============ package Maz; -use Mo; +use Lmo; extends 'Baz'; has 'bar';