From: Matt S Trout Date: Thu, 29 Mar 2012 17:31:03 +0000 (+0000) Subject: annihilate Moo since this is going to be the Role-Tiny repo now X-Git-Tag: v1.000000~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5ef4ffe7ced48716152998d3bacc801a3800ce2a;p=gitmo%2FRole-Tiny.git annihilate Moo since this is going to be the Role-Tiny repo now --- diff --git a/Changes b/Changes index f6e66fb..e7a0a2f 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,5 @@ +Changes below this line are from when Role::Tiny was still bundled with Moo: + - Fix a bug where coercions weren't called on lazy default/builder returns - Switch Moo::Utils to using Module::Runtime, and add the 5.8 %INC leakage fix into Role::Tiny's _load_module to provide partial parity diff --git a/Makefile.PL b/Makefile.PL index 7a550c4..6be1ce8 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -9,36 +9,15 @@ my %BUILD_DEPS = ( 'Test::Fatal' => 0.003, ); -my %RUN_DEPS = ( - 'Class::Method::Modifiers' => 1.07, - 'strictures' => 1.001001, - 'Module::Runtime' => 0.013, -); - # have to do this since old EUMM dev releases miss the eval $VERSION line my $mymeta_works = do { no warnings; $ExtUtils::MakeMaker::VERSION >= 6.5707 }; -my $mymeta = do { no warnings; $ExtUtils::MakeMaker::VERSION >= 6.5702 }; WriteMakefile( - NAME => 'Moo', - VERSION_FROM => 'lib/Moo.pm', + NAME => 'Role-Tiny', + VERSION_FROM => 'lib/Role/Tiny.pm', PREREQ_PM => { - %RUN_DEPS, ($] >= 5.010 ? () : ('MRO::Compat' => 0)), ($mymeta_works ? () : (%BUILD_DEPS)), }, - ($mymeta_works - ? ( # BUILD_REQUIRES makes MYMETA right, requires stops META being wrong - BUILD_REQUIRES => \%BUILD_DEPS, - META_ADD => { requires => \%RUN_DEPS } - ) - : ( # META_ADD both to get META right - only Makefile written - META_ADD => { - requires => \%RUN_DEPS, - build_requires => \%BUILD_DEPS, - } - ) - ), - ($mymeta && !$mymeta_works ? (NO_MYMETA => 1) : ()), - LICENSE => 'perl', + $mymeta_works ? (BUILD_REQUIRES => \%BUILD_DEPS) : (), ); diff --git a/benchmark/class_factory b/benchmark/class_factory deleted file mode 100644 index af4b9e7..0000000 --- a/benchmark/class_factory +++ /dev/null @@ -1,144 +0,0 @@ -use strictures 1; - -use Benchmark qw/:hireswallclock cmpthese/; -use Getopt::Long::Descriptive; - -use Config; -$ENV{PERL5LIB} = join ($Config{path_sep}, @INC); - - -my ($opts, $usage); -BEGIN { - ($opts, $usage) = describe_options( - '%c: %o' => - [ 'help|h' => 'Print usage message and exit' ], - [ 'classes|c:i' => 'How many classes to create per benchmark cycle (def 10)', { default => 10 } ], - [ 'accessors|a:i' => 'How many accessors/attributes of each type to create per class (def 10)', { default => 10 } ], - [ 'subprocess|startup|s' => 'Run the code in a subprocess to benchmark actual time spent on compilation' ], - [ 'pregenerate|p:i' => 'How many bench-runs to pre-generate for compilation in case --subprocess is not used (def 1000)', { default => 1000} ], - [ 'run|r' => 'Use each accessor at runtime (get/set/get cycle)' ], - [ 'unique|u' => 'Make accessor names globally unique (instead of just per class)' ], - [ 'bench|b:s' => 'Which benchmarks to run (all|xs|pp)', { default => 'all', regex => qr/^(?:all|xs|pp)$/ } ], - { getopt_conf => [qw/gnu_getopt bundling_override no_ignore_case/] }, - ); - - # can not change this runtime, thus in-block - $ENV{MOUSE_PUREPERL} = 1 if $opts->{bench} eq 'pp'; - - my @missing; - for (qw/ - Moose - Moo - Mouse - /) { - eval "require $_" or push @missing, $_; - } - - if (@missing) { - die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n", - join ("\n", @missing); - } -} - -use Method::Generate::Accessor; # need to pre-load for the XS shut-off to work - -$usage->die if $opts->{help}; - -$opts->{pregenerate} = 1 if $opts->{subprocess}; - -my $counters; -my $tasks = {}; - -my $attrs_to_bench = { - plain => q|is => 'rw'|, - lazy_default => q|is => 'rw', lazy => 1, default => sub { {} }|, - lazy_default_qsub => q|is => 'rw', lazy => 1, default => Sub::Quote::quote_sub q{ {} }|, -}; - -for (keys %$attrs_to_bench) { - if ($opts->{bench} =~ /all|pp/) { - { - local $Method::Generate::Accessor::CAN_HAZ_XS = 0; - _add_moosey_has (moo => 'Moo', $_); - } - - _add_moosey_has (moose => 'Moose', $_); - _add_moosey_has (mouse => 'Mouse', $_) - if $ENV{MOUSE_PUREPERL}; - } - - if ($opts->{bench} =~ /all|xs/) { - { - local $Method::Generate::Accessor::CAN_HAZ_XS = 1; - _add_moosey_has (moo_XS => 'Moo', $_); - } - _add_moosey_has (mouse_XS => 'Mouse', $_) - unless $ENV{MOUSE_PUREPERL}; - } -} - -# run each task once, prime whatever caches there may be -$_->() for values %$tasks; - -# Actual Benchmarking -for (1, 2) { - print "Perl $], take $_:\n"; - - # if forking must run for certain number of cycles, cputime doesn't work - foreach my $type (sort keys %$attrs_to_bench) { - print "Benchming ${type}:\n"; - my %these = map { (split ' ', $_)[0] => $tasks->{$_} } - grep /${type}$/, keys %$tasks; - cmpthese ( $opts->{subprocess} ? 15 : -1 , \%these ); - } - print "\n"; -} - -exit 0; # the end - -sub _add_moosey_has { - my ($name, $base, $attr_type) = @_; - - my @to_eval; - - for (1 .. $opts->{pregenerate} ) { - my $perl = 'use Sub::Quote;'; - - for ( 1.. $opts->{classes} ) { - my $class = "Bench::${base}_" . ++$counters->{class}; - $perl .= "package $class; use $base;"; - - my @attr_names; - for ( 1.. $opts->{accessors} ) { - my $attr = "attribute_${attr_type}" . ++$counters->{acc}; - push @attr_names, $attr; - $perl .= "has $attr => ($attrs_to_bench->{$attr_type});"; - } - - $perl .= '__PACKAGE__->meta->make_immutable;' - if $name !~ /^moo(_XS)?$/; - - $counters->{accessors} = 0 - unless $opts->{unique}; - - if ($opts->{run}) { - $perl .= "\$::obj = $class->new;"; - $perl .= "\$::foo = \$::obj->$_; \$::obj->$_(1); \$::foo = \$::obj->$_;" - for @attr_names; - } - } - - push @to_eval, $perl; - } - - $tasks->{"$name $attr_type"} = $opts->{subprocess} - ? sub { - open (my $subproc, '|-', $^X, '-'); - print $subproc $to_eval[0]; - close $subproc; - } - : sub { - eval shift @to_eval; - } - ; -} diff --git a/benchmark/object_factory b/benchmark/object_factory deleted file mode 100644 index c539c14..0000000 --- a/benchmark/object_factory +++ /dev/null @@ -1,156 +0,0 @@ -use strictures 1; - -use Benchmark qw/:hireswallclock cmpthese/; -use Getopt::Long::Descriptive; - -use Config; - -my $attrs_to_bench = { - plain => q|is => 'rw' |, - ro => q|is => 'ro' |, - default => q|is => 'rw', default => sub { {} } |, - lazy_default => q|is => 'rw', lazy => 1, default => sub { {} } |, - lazy_default_qsub => q|is => 'rw', lazy => 1, default => Sub::Quote::quote_sub q{ {} } |, -}; - -my $cycles = { - 1 => 'get', - 2 => 'get/set/get', -}; - -my ($opts, $usage) = describe_options( - '%c: %o' => - [ 'help|h' => 'Print usage message and exit' ], - [ 'bench|b:s' => 'Which benchmarks to run (all|xs|pp)', { default => 'all', regex => qr/^(?:all|xs|pp)$/ } ], - [ 'lib|l:s@' => 'Bench against specific lib(s), runs same benches against multiple targets, excluding non-moo benches' ], - [ 'attr|a:s@' => 'Which attributes to benchmark (must be defined in-file)' ], - [ 'cycle|c:i' => 'Which cycle to run 1 - get, 2 - get/set/get (def 1)', { default => 1 } ], - [ 'iterations|i:i' => 'How many iterations in each bench run (def 1000)', { default => 1000 } ], - [ 'totalruns|total|t:i' => 'How many times to rerun the whole benchmark (def 1)', { default => 1 } ], - [ 'reuse|r' => 'Reuse the object between attribute usage runs' ], - { getopt_conf => [qw/gnu_getopt bundling_override no_ignore_case/] }, -); - -$usage->die if $opts->{help}; - -if ($opts->{attr}) { - my %to_bench = map { $_ => 1 } map { split /\s*,\s*/, $_ } @{$opts->{attr}}; - - for (keys %to_bench) { - die "No such attr '$_'\n" unless $attrs_to_bench->{$_}; - } - - for (keys %$attrs_to_bench) { - delete $attrs_to_bench->{$_} unless $to_bench{$_}; - } -} - -my @libs = map { split /\s*:\s*/, $_ } @{$opts->{lib}} - if ($opts->{lib}); - -if (@libs) { - my $myself = $$; - - for my $lib (@libs) { - $ENV{PERL5LIB} = join ($Config{path_sep}, $lib, @INC); - - my $pid = fork(); - die "Unable to fork: $!" unless defined $pid; - - if ($pid) { - wait; - } - else { - print "Benchmarking with $lib\n"; - last; - } - } - - exit 0 if $$ == $myself; -} - -require Method::Generate::Accessor; # need to pre-load for the XS shut-off to work - -my $class_types; - -if ($opts->{bench} =~ /all|pp/) { - { - local $Method::Generate::Accessor::CAN_HAZ_XS = 0; - _add_moosey_has (moo => 'Moo'); - } - - _add_moosey_has (moose => 'Moose') unless @libs; - _add_moosey_has (mouse => 'Mousse') unless @libs; -} - -if ($opts->{bench} =~ /all|xs/) { - if (! $Method::Generate::Accessor::CAN_HAZ_XS) - { - die "Requested XS benchmarks but XS isn't available in Method::Generate::Accessor"; - } - - _add_moosey_has (moo_XS => 'Moo'); - _add_moosey_has (mouse_XS => 'Mouse') unless @libs; -} - - -# Actual Benchmarking -for (1 .. $opts->{totalruns} ) { - print "Perl $], take $_:\n"; - - my $objects; - - for my $use_attrs (0, 1) { - for my $attr (keys %$attrs_to_bench) { - printf "\n\nBenching %s ( %s )\n====================\n", - $attr, - $use_attrs - ? sprintf '%s%s cycle', ($opts->{reuse} ? '' : 'new() and ' ), $cycles->{$opts->{cycle}} - : 'new() only' - , - ; - - cmpthese ( -1, { map { - my $type = $_; - "${type}->$attr" => sub { - $objects->{$type} = $class_types->{$type}->new - unless ( $use_attrs && $opts->{reuse} ); - - for (1 .. $opts->{iterations} ) { - if ($opts->{cycle} == 1) { - my $init = $objects->{$type}->$attr; - } - elsif ($opts->{cycle} == 2) { - my $init = $objects->{$type}->$attr; - $objects->{$type}->$attr('foo') unless $attr eq 'ro'; - my $set = $objects->{$type}->$attr; - } - } - }; - } keys %$class_types } ); - } - } - - print "\n\n\n"; -} - -exit 0; # the end - -sub _add_moosey_has { - my ($name, $base) = @_; - - my $class = "Bench::${name}"; - - my $perl = "package $class; use $base;"; - - for my $attr (keys %$attrs_to_bench) { - $perl .= "has $attr => ($attrs_to_bench->{$attr});"; - - $class_types->{$name} = $class; - } - - $perl .= 'eval { __PACKAGE__->meta->make_immutable };'; - - eval $perl; - die $@ if $@; -} diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm deleted file mode 100644 index ce84f62..0000000 --- a/lib/Method/Generate/Accessor.pm +++ /dev/null @@ -1,442 +0,0 @@ -package Method::Generate::Accessor; - -use strictures 1; -use Moo::_Utils; -use base qw(Moo::Object); -use Sub::Quote; -use B 'perlstring'; -BEGIN { - our $CAN_HAZ_XS = - !$ENV{MOO_XS_DISABLE} - && - _maybe_load_module('Class::XSAccessor') - && - (eval { Class::XSAccessor->VERSION('1.07') }) - ; -} - -sub generate_method { - my ($self, $into, $name, $spec, $quote_opts) = @_; - die "Must have an is" unless my $is = $spec->{is}; - if ($is eq 'ro') { - $spec->{reader} = $name unless exists $spec->{reader}; - } elsif ($is eq 'rw') { - $spec->{accessor} = $name unless exists $spec->{accessor}; - } elsif ($is eq 'lazy') { - $spec->{init_arg} = undef unless exists $spec->{init_arg}; - $spec->{reader} = $name unless exists $spec->{reader}; - $spec->{lazy} = 1; - $spec->{builder} ||= '_build_'.$name unless $spec->{default}; - } elsif ($is ne 'bare') { - die "Unknown is ${is}"; - } - my %methods; - if (my $reader = $spec->{reader}) { - if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) { - $methods{$reader} = $self->_generate_xs( - getters => $into, $reader, $name - ); - } else { - $self->{captures} = {}; - $methods{$reader} = - quote_sub "${into}::${reader}" - => ' die "'.$reader.' is a read-only accessor" if @_ > 1;'."\n" - .$self->_generate_get($name, $spec) - => delete $self->{captures} - ; - } - } - if (my $accessor = $spec->{accessor}) { - if ( - our $CAN_HAZ_XS - && $self->is_simple_get($name, $spec) - && $self->is_simple_set($name, $spec) - ) { - $methods{$accessor} = $self->_generate_xs( - accessors => $into, $accessor, $name - ); - } else { - $self->{captures} = {}; - $methods{$accessor} = - quote_sub "${into}::${accessor}" - => $self->_generate_getset($name, $spec) - => delete $self->{captures} - ; - } - } - if (my $writer = $spec->{writer}) { - if ( - our $CAN_HAZ_XS - && $self->is_simple_set($name, $spec) - ) { - $methods{$writer} = $self->_generate_xs( - setters => $into, $writer, $name - ); - } else { - $self->{captures} = {}; - $methods{$writer} = - quote_sub "${into}::${writer}" - => $self->_generate_set($name, $spec) - => delete $self->{captures} - ; - } - } - if (my $pred = $spec->{predicate}) { - $methods{$pred} = - quote_sub "${into}::${pred}" => - ' '.$self->_generate_simple_has('$_[0]', $name)."\n" - ; - } - if (my $cl = $spec->{clearer}) { - $methods{$cl} = - quote_sub "${into}::${cl}" => - " delete \$_[0]->{${\perlstring $name}}\n" - ; - } - if (my $hspec = $spec->{handles}) { - my $asserter = $spec->{asserter} ||= '_assert_'.$name; - my @specs = do { - if (ref($hspec) eq 'ARRAY') { - map [ $_ => $_ ], @$hspec; - } elsif (ref($hspec) eq 'HASH') { - map [ $_ => ref($hspec->{$_}) ? @{$hspec->{$_}} : $hspec->{$_} ], - keys %$hspec; - } elsif (!ref($hspec)) { - map [ $_ => $_ ], Role::Tiny->methods_provided_by($hspec); - } else { - die "You gave me a handles of ${hspec} and I have no idea why"; - } - }; - foreach my $spec (@specs) { - my ($proxy, $target, @args) = @$spec; - $self->{captures} = {}; - $methods{$proxy} = - quote_sub "${into}::${proxy}" => - $self->_generate_delegation($asserter, $target, \@args), - delete $self->{captures} - ; - } - } - if (my $asserter = $spec->{asserter}) { - $self->{captures} = {}; - $methods{$asserter} = - quote_sub "${into}::${asserter}" => - 'do { '.$self->_generate_get($name, $spec).qq! }||die "Attempted to access '${name}' but it is not set"!, - delete $self->{captures} - ; - } - \%methods; -} - -sub is_simple_attribute { - my ($self, $name, $spec) = @_; - # clearer doesn't have to be listed because it doesn't - # affect whether defined/exists makes a difference - !grep $spec->{$_}, - qw(lazy default builder coerce isa trigger predicate weak_ref); -} - -sub is_simple_get { - my ($self, $name, $spec) = @_; - !($spec->{lazy} and ($spec->{default} or $spec->{builder})); -} - -sub is_simple_set { - my ($self, $name, $spec) = @_; - !grep $spec->{$_}, qw(coerce isa trigger weak_ref); -} - -sub has_eager_default { - my ($self, $name, $spec) = @_; - (!$spec->{lazy} and ($spec->{default} or $spec->{builder})); -} - -sub _generate_get { - my ($self, $name, $spec) = @_; - my $simple = $self->_generate_simple_get('$_[0]', $name); - if ($self->is_simple_get($name, $spec)) { - $simple; - } else { - 'do { '.$self->_generate_use_default( - '$_[0]', $name, $spec, - $self->_generate_simple_has('$_[0]', $name), - ).'; '.$simple.' }'; - } -} - -sub _generate_simple_has { - my ($self, $me, $name) = @_; - "exists ${me}->{${\perlstring $name}}"; -} - -sub generate_get_default { - my $self = shift; - $self->{captures} = {}; - my $code = $self->_generate_get_default(@_); - ($code, delete $self->{captures}); -} - -sub _generate_use_default { - my ($self, $me, $name, $spec, $test) = @_; - my $get_value = $self->_generate_get_default($me, $name, $spec); - if ($spec->{coerce}) { - $get_value = $self->_generate_coerce( - $name, $get_value, - $spec->{coerce} - ) - } - $self->_generate_simple_set( - $me, $name, $spec, $get_value - ).' unless '.$test; -} - -sub _generate_get_default { - my ($self, $me, $name, $spec) = @_; - $spec->{default} - ? $self->_generate_call_code($name, 'default', $me, $spec->{default}) - : "${me}->${\$spec->{builder}}" -} - -sub generate_simple_get { - my ($self, @args) = @_; - $self->_generate_simple_get(@args); -} - -sub _generate_simple_get { - my ($self, $me, $name) = @_; - my $name_str = perlstring $name; - "${me}->{${name_str}}"; -} - -sub _generate_set { - my ($self, $name, $spec) = @_; - if ($self->is_simple_set($name, $spec)) { - $self->_generate_simple_set('$_[0]', $name, $spec, '$_[1]'); - } else { - my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)}; - my $simple = $self->_generate_simple_set('$self', $name, $spec, '$value'); - my $code = "do { my (\$self, \$value) = \@_;\n"; - if ($coerce) { - $code .= - " \$value = " - .$self->_generate_coerce($name, '$value', $coerce).";\n"; - } - if ($isa_check) { - $code .= - " ".$self->_generate_isa_check($name, '$value', $isa_check).";\n"; - } - if ($trigger) { - my $fire = $self->_generate_trigger($name, '$self', '$value', $trigger); - $code .= - " ".$simple.";\n ".$fire.";\n" - ." \$value;\n"; - } else { - $code .= " ".$simple.";\n"; - } - $code .= " }"; - $code; - } -} - -sub generate_coerce { - my $self = shift; - $self->{captures} = {}; - my $code = $self->_generate_coerce(@_); - ($code, delete $self->{captures}); -} - -sub _generate_coerce { - my ($self, $name, $value, $coerce) = @_; - $self->_generate_call_code($name, 'coerce', "${value}", $coerce); -} - -sub generate_trigger { - my $self = shift; - $self->{captures} = {}; - my $code = $self->_generate_trigger(@_); - ($code, delete $self->{captures}); -} - -sub _generate_trigger { - my ($self, $name, $obj, $value, $trigger) = @_; - $self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger); -} - -sub generate_isa_check { - my ($self, @args) = @_; - $self->{captures} = {}; - my $code = $self->_generate_isa_check(@args); - ($code, delete $self->{captures}); -} - -sub _generate_isa_check { - my ($self, $name, $value, $check) = @_; - $self->_generate_call_code($name, 'isa_check', $value, $check); -} - -sub _generate_call_code { - my ($self, $name, $type, $values, $sub) = @_; - if (my $quoted = quoted_from_sub($sub)) { - my $code = $quoted->[1]; - my $at_ = '@_ = ('.$values.');'; - if (my $captures = $quoted->[2]) { - my $cap_name = qq{\$${type}_captures_for_${name}}; - $self->{captures}->{$cap_name} = \$captures; - Sub::Quote::inlinify( - $code, $values, Sub::Quote::capture_unroll($cap_name, $captures, 6) - ); - } else { - Sub::Quote::inlinify($code, $values); - } - } else { - my $cap_name = qq{\$${type}_for_${name}}; - $self->{captures}->{$cap_name} = \$sub; - "${cap_name}->(${values})"; - } -} - -sub generate_populate_set { - my $self = shift; - $self->{captures} = {}; - my $code = $self->_generate_populate_set(@_); - ($code, delete $self->{captures}); -} - -sub _generate_populate_set { - my ($self, $me, $name, $spec, $source, $test) = @_; - if ($self->has_eager_default($name, $spec)) { - my $get_indent = ' ' x ($spec->{isa} ? 6 : 4); - my $get_default = $self->_generate_get_default( - '$new', $_, $spec - ); - my $get_value = - defined($spec->{init_arg}) - ? "(\n${get_indent} ${test}\n${get_indent} ? ${source}\n${get_indent} : " - .$get_default - ."\n${get_indent})" - : $get_default; - if ($spec->{coerce}) { - $get_value = $self->_generate_coerce( - $name, $get_value, - $spec->{coerce} - ) - } - ($spec->{isa} - ? " {\n my \$value = ".$get_value.";\n " - .$self->_generate_isa_check( - $name, '$value', $spec->{isa} - ).";\n" - .' '.$self->_generate_simple_set($me, $name, $spec, '$value').";\n" - ." }\n" - : ' '.$self->_generate_simple_set($me, $name, $spec, $get_value).";\n" - ) - .($spec->{trigger} - ? ' ' - .$self->_generate_trigger( - $name, $me, $self->_generate_simple_get($me, $name), - $spec->{trigger} - )." if ${test};\n" - : '' - ); - } else { - " if (${test}) {\n" - .($spec->{coerce} - ? " $source = " - .$self->_generate_coerce( - $name, $source, - $spec->{coerce} - ).";\n" - : "" - ) - .($spec->{isa} - ? " " - .$self->_generate_isa_check( - $name, $source, $spec->{isa} - ).";\n" - : "" - ) - ." ".$self->_generate_simple_set($me, $name, $spec, $source).";\n" - .($spec->{trigger} - ? " " - .$self->_generate_trigger( - $name, $me, $self->_generate_simple_get($me, $name), - $spec->{trigger} - ).";\n" - : "" - ) - ." }\n"; - } -} - -sub generate_multi_set { - my ($self, $me, $to_set, $from) = @_; - "\@{${me}}{qw(${\join ' ', @$to_set})} = $from"; -} - -sub _generate_simple_set { - my ($self, $me, $name, $spec, $value) = @_; - my $name_str = perlstring $name; - my $simple = "${me}->{${name_str}} = ${value}"; - - if ($spec->{weak_ref}) { - require Scalar::Util; - - # Perl < 5.8.3 can't weaken refs to readonly vars - # (e.g. string constants). This *can* be solved by: - # - #Internals::SetReadWrite($foo); - #Scalar::Util::weaken ($foo); - #Internals::SetReadOnly($foo); - # - # but requires XS and is just too damn crazy - # so simply throw a better exception - Moo::_Utils::lt_5_8_3() ? <<"EOC" : "Scalar::Util::weaken(${simple})"; - - eval { Scalar::Util::weaken($simple); 1 } or do { - if( \$@ =~ /Modification of a read-only value attempted/) { - require Carp; - Carp::croak( sprintf ( - 'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3', - $name_str, - ) ); - } else { - die \$@; - } - }; -EOC - } else { - $simple; - } -} - -sub _generate_getset { - my ($self, $name, $spec) = @_; - q{(@_ > 1}."\n ? ".$self->_generate_set($name, $spec) - ."\n : ".$self->_generate_get($name, $spec)."\n )"; -} - -sub _generate_delegation { - my ($self, $asserter, $target, $args) = @_; - my $arg_string = do { - if (@$args) { - # I could, I reckon, linearise out non-refs here using perlstring - # plus something to check for numbers but I'm unsure if it's worth it - $self->{captures}{'@curries'} = $args; - '@curries, @_'; - } else { - '@_'; - } - }; - "shift->${asserter}->${target}(${arg_string});"; -} - -sub _generate_xs { - my ($self, $type, $into, $name, $slot) = @_; - Class::XSAccessor->import( - class => $into, - $type => { $name => $slot } - ); - $into->can($name); -} - -1; diff --git a/lib/Method/Generate/BuildAll.pm b/lib/Method/Generate/BuildAll.pm deleted file mode 100644 index 1d6b5ad..0000000 --- a/lib/Method/Generate/BuildAll.pm +++ /dev/null @@ -1,34 +0,0 @@ -package Method::Generate::BuildAll; - -use strictures 1; -use base qw(Moo::Object); -use Sub::Quote; -use Moo::_Utils; -use B 'perlstring'; - -sub generate_method { - my ($self, $into) = @_; - quote_sub "${into}::BUILDALL", join '', - $self->_handle_subbuild($into), - qq{ my \$self = shift;\n}, - $self->buildall_body_for($into, '$self', '@_'), - qq{ return \$self\n}; -} - -sub _handle_subbuild { - my ($self, $into) = @_; - ' if (ref($_[0]) ne '.perlstring($into).') {'."\n". - ' return shift->Moo::Object::BUILDALL(@_)'.";\n". - ' }'."\n"; -} - -sub buildall_body_for { - my ($self, $into, $me, $args) = @_; - my @builds = - grep *{_getglob($_)}{CODE}, - map "${_}::BUILD", - reverse @{Moo::_Utils::_get_linear_isa($into)}; - join '', map qq{ ${me}->${_}(${args});\n}, @builds; -} - -1; diff --git a/lib/Method/Generate/Constructor.pm b/lib/Method/Generate/Constructor.pm deleted file mode 100644 index 33e6a08..0000000 --- a/lib/Method/Generate/Constructor.pm +++ /dev/null @@ -1,207 +0,0 @@ -package Method::Generate::Constructor; - -use strictures 1; -use Sub::Quote; -use base qw(Moo::Object); -use Sub::Defer; -use B 'perlstring'; - -sub register_attribute_specs { - my ($self, %spec) = @_; - @{$self->{attribute_specs}||={}}{keys %spec} = values %spec; - $self; -} - -sub all_attribute_specs { - $_[0]->{attribute_specs} -} - -sub accessor_generator { - $_[0]->{accessor_generator} -} - -sub construction_string { - my ($self) = @_; - $self->{construction_string} or 'bless({}, $class);' -} - -sub install_delayed { - my ($self) = @_; - my $package = $self->{package}; - defer_sub "${package}::new" => sub { - unquote_sub $self->generate_method( - $package, 'new', $self->{attribute_specs}, { no_install => 1 } - ) - }; - $self; -} - -sub generate_method { - my ($self, $into, $name, $spec, $quote_opts) = @_; - foreach my $no_init (grep !exists($spec->{$_}{init_arg}), keys %$spec) { - $spec->{$no_init}{init_arg} = $no_init; - } - local $self->{captures} = {}; - my $body = ' my $class = shift;'."\n" - .' $class = ref($class) if ref($class);'."\n"; - $body .= $self->_handle_subconstructor($into, $name); - my $into_buildargs = $into->can('BUILDARGS'); - if ( $into_buildargs && $into_buildargs != \&Moo::Object::BUILDARGS ) { - $body .= $self->_generate_args_via_buildargs; - } else { - $body .= $self->_generate_args; - } - $body .= $self->_check_required($spec); - $body .= ' my $new = '.$self->construction_string.";\n"; - $body .= $self->_assign_new($spec); - if ($into->can('BUILD')) { - require Method::Generate::BuildAll; - $body .= Method::Generate::BuildAll->new->buildall_body_for( - $into, '$new', '$args' - ); - } - $body .= ' return $new;'."\n"; - if ($into->can('DEMOLISH')) { - require Method::Generate::DemolishAll; - Method::Generate::DemolishAll->new->generate_method($into); - } - quote_sub - "${into}::${name}" => $body, - $self->{captures}, $quote_opts||{} - ; -} - -sub _handle_subconstructor { - my ($self, $into, $name) = @_; - if (my $gen = $self->{subconstructor_generator}) { - ' if ($class ne '.perlstring($into).') {'."\n". - ' '.$gen.";\n". - ' return $class->'.$name.'(@_)'.";\n". - ' }'."\n"; - } else { - '' - } -} - -sub _cap_call { - my ($self, $code, $captures) = @_; - @{$self->{captures}}{keys %$captures} = values %$captures if $captures; - $code; -} - -sub _generate_args_via_buildargs { - my ($self) = @_; - q{ my $args = $class->BUILDARGS(@_);}."\n"; -} - -# inlined from Moo::Object - update that first. -sub _generate_args { - my ($self) = @_; - return <<'_EOA'; - my $args; - if ( scalar @_ == 1 ) { - unless ( defined $_[0] && ref $_[0] eq 'HASH' ) { - die "Single parameters to new() must be a HASH ref" - ." data => ". $_[0] ."\n"; - } - $args = { %{ $_[0] } }; - } - elsif ( @_ % 2 ) { - die "The new() method for $class expects a hash reference or a key/value list." - . " You passed an odd number of arguments\n"; - } - else { - $args = {@_}; - } -_EOA - -} - -sub _assign_new { - my ($self, $spec) = @_; - my (@init, @slots, %test); - my $ag = $self->accessor_generator; - NAME: foreach my $name (sort keys %$spec) { - my $attr_spec = $spec->{$name}; - unless ($ag->is_simple_attribute($name, $attr_spec)) { - next NAME unless defined($attr_spec->{init_arg}) - or $ag->has_eager_default($name, $attr_spec); - $test{$name} = $attr_spec->{init_arg}; - next NAME; - } - next NAME unless defined(my $i = $attr_spec->{init_arg}); - push @init, $i; - push @slots, $name; - } - return '' unless @init or %test; - join '', ( - @init - ? ' '.$self->_cap_call($ag->generate_multi_set( - '$new', [ @slots ], '@{$args}{qw('.join(' ',@init).')}' - )).";\n" - : '' - ), map { - my $arg_key = perlstring($test{$_}); - my $test = "exists \$args->{$arg_key}"; - my $source = "\$args->{$arg_key}"; - my $attr_spec = $spec->{$_}; - $self->_cap_call($ag->generate_populate_set( - '$new', $_, $attr_spec, $source, $test - )); - } sort keys %test; -} - -sub _check_required { - my ($self, $spec) = @_; - my @required_init = - map $spec->{$_}{init_arg}, - grep $spec->{$_}{required}, - sort keys %$spec; - return '' unless @required_init; - ' if (my @missing = grep !exists $args->{$_}, qw(' - .join(' ',@required_init).')) {'."\n" - .q{ die "Missing required arguments: ".join(', ', sort @missing);}."\n" - ." }\n"; -} - -sub _check_isa { - my ($self, $spec) = @_; - my $acc = $self->accessor_generator; - my $captures = $self->{captures}; - my $check = ''; - foreach my $name (sort keys %$spec) { - my ($init, $isa) = @{$spec->{$name}}{qw(init_arg isa)}; - next unless $init and $isa; - my $init_str = perlstring($init); - my ($code, $add_captures) = $acc->generate_isa_check( - $name, "\$args->{${init_str}}", $isa - ); - @{$captures}{keys %$add_captures} = values %$add_captures; - $check .= " ${code}".( - (not($spec->{lazy}) and ($spec->{default} or $spec->{builder}) - ? ";\n" - : "if exists \$args->{${init_str}};\n" - ) - ); - } - return $check; -} - -sub _fire_triggers { - my ($self, $spec) = @_; - my $acc = $self->accessor_generator; - my $captures = $self->{captures}; - my $fire = ''; - foreach my $name (sort keys %$spec) { - my ($init, $trigger) = @{$spec->{$name}}{qw(init_arg trigger)}; - next unless $init && $trigger; - my ($code, $add_captures) = $acc->generate_trigger( - $name, '$new', $acc->generate_simple_get('$new', $name), $trigger - ); - @{$captures}{keys %$add_captures} = values %$add_captures; - $fire .= " ${code} if exists \$args->{${\perlstring $init}};\n"; - } - return $fire; -} - -1; diff --git a/lib/Method/Generate/DemolishAll.pm b/lib/Method/Generate/DemolishAll.pm deleted file mode 100644 index 0ad1f58..0000000 --- a/lib/Method/Generate/DemolishAll.pm +++ /dev/null @@ -1,49 +0,0 @@ -package Method::Generate::DemolishAll; - -use strictures 1; -use base qw(Moo::Object); -use Sub::Quote; -use Moo::_Utils; -use B qw(perlstring); - -sub generate_method { - my ($self, $into) = @_; - quote_sub "${into}::DEMOLISHALL", join '', - $self->_handle_subdemolish($into), - qq{ my \$self = shift;\n}, - $self->demolishall_body_for($into, '$self', '@_'), - qq{ return \$self\n}; - quote_sub "${into}::DESTROY", join '', - q! my $self = shift; - my $e = do { - local $?; - local $@; - require Moo::_Utils; - eval { - $self->DEMOLISHALL($Moo::_Utils::_in_global_destruction); - }; - $@; - }; - - no warnings 'misc'; - die $e if $e; # rethrow - !; -} - -sub demolishall_body_for { - my ($self, $into, $me, $args) = @_; - my @demolishers = - grep *{_getglob($_)}{CODE}, - map "${_}::DEMOLISH", - @{Moo::_Utils::_get_linear_isa($into)}; - join '', map qq{ ${me}->${_}(${args});\n}, @demolishers; -} - -sub _handle_subdemolish { - my ($self, $into) = @_; - ' if (ref($_[0]) ne '.perlstring($into).') {'."\n". - ' return shift->Moo::Object::DEMOLISHALL(@_)'.";\n". - ' }'."\n"; -} - -1; diff --git a/lib/Method/Inliner.pm b/lib/Method/Inliner.pm deleted file mode 100644 index b047ace..0000000 --- a/lib/Method/Inliner.pm +++ /dev/null @@ -1,53 +0,0 @@ -package Method::Inliner; - -use strictures 1; -use Text::Balanced qw(extract_bracketed); -use Sub::Quote (); - -sub slurp { do { local (@ARGV, $/) = $_[0]; <> } } -sub splat { - open my $out, '>', $_[1] or die "can't open $_[1]: $!"; - print $out $_[0] or die "couldn't write to $_[1]: $!"; -} - -sub inlinify { - my $file = $_[0]; - my @chunks = split /(^sub.*?^}$)/sm, slurp $file; - warn join "\n--\n", @chunks; - my %code; - foreach my $chunk (@chunks) { - if (my ($name, $body) = - $chunk =~ /^sub (\S+) {\n(.*)\n}$/s - ) { - $code{$name} = $body; - } - } - foreach my $chunk (@chunks) { - my ($me) = $chunk =~ /^sub.*{\n my \((\$\w+).*\) = \@_;\n/ or next; - my $meq = quotemeta $me; - #warn $meq, $chunk; - my $copy = $chunk; - my ($fixed, $rest); - while ($copy =~ s/^(.*?)${meq}->(\S+)(?=\()//s) { - my ($front, $name) = ($1, $2); - ((my $body), $rest) = extract_bracketed($copy, '()'); - warn "spotted ${name} - ${body}"; - if ($code{$name}) { - warn "replacing"; - s/^\(//, s/\)$// for $body; - $body = "${me}, ".$body; - $fixed .= $front.Sub::Quote::inlinify($code{$name}, $body); - } else { - $fixed .= $front.$me.'->'.$name.$body; - } - #warn $fixed; warn $rest; - $copy = $rest; - } - $fixed .= $rest if $fixed; - warn $fixed if $fixed; - $chunk = $fixed if $fixed; - } - print join '', @chunks; -} - -1; diff --git a/lib/Moo.pm b/lib/Moo.pm deleted file mode 100644 index d769b72..0000000 --- a/lib/Moo.pm +++ /dev/null @@ -1,553 +0,0 @@ -package Moo; - -use strictures 1; -use Moo::_Utils; -use B 'perlstring'; - -our $VERSION = '0.009013'; # 0.9.13 -$VERSION = eval $VERSION; - -our %MAKERS; - -sub import { - my $target = caller; - my $class = shift; - strictures->import; - return if $MAKERS{$target}; # already exported into this package - *{_getglob("${target}::extends")} = sub { - _load_module($_) for @_; - # Can't do *{...} = \@_ or 5.10.0's mro.pm stops seeing @ISA - @{*{_getglob("${target}::ISA")}{ARRAY}} = @_; - }; - *{_getglob("${target}::with")} = sub { - require Moo::Role; - die "Only one role supported at a time by with" if @_ > 1; - Moo::Role->apply_role_to_package($target, $_[0]); - }; - $MAKERS{$target} = {}; - *{_getglob("${target}::has")} = sub { - my ($name, %spec) = @_; - ($MAKERS{$target}{accessor} ||= do { - require Method::Generate::Accessor; - Method::Generate::Accessor->new - })->generate_method($target, $name, \%spec); - $class->_constructor_maker_for($target) - ->register_attribute_specs($name, \%spec); - }; - foreach my $type (qw(before after around)) { - *{_getglob "${target}::${type}"} = sub { - require Class::Method::Modifiers; - _install_modifier($target, $type, @_); - }; - } - { - no strict 'refs'; - @{"${target}::ISA"} = do { - require Moo::Object; ('Moo::Object'); - } unless @{"${target}::ISA"}; - } -} - -sub _constructor_maker_for { - my ($class, $target, $select_super) = @_; - return unless $MAKERS{$target}; - $MAKERS{$target}{constructor} ||= do { - require Method::Generate::Constructor; - require Sub::Defer; - my ($moo_constructor, $con); - - if ($select_super && $MAKERS{$select_super}) { - $moo_constructor = 1; - $con = $MAKERS{$select_super}{constructor}; - } else { - my $t_new = $target->can('new'); - if ($t_new) { - if ($t_new == Moo::Object->can('new')) { - $moo_constructor = 1; - } elsif (my $defer_target = (Sub::Defer::defer_info($t_new)||[])->[0]) { - my ($pkg) = ($defer_target =~ /^(.*)::[^:]+$/); - if ($MAKERS{$pkg}) { - $moo_constructor = 1; - $con = $MAKERS{$pkg}{constructor}; - } - } - } else { - $moo_constructor = 1; # no other constructor, make a Moo one - } - }; - Method::Generate::Constructor - ->new( - package => $target, - accessor_generator => do { - require Method::Generate::Accessor; - Method::Generate::Accessor->new; - }, - construction_string => ( - $moo_constructor - ? ($con ? $con->construction_string : undef) - : ('$class->'.$target.'::SUPER::new(@_)') - ), - subconstructor_generator => ( - $class.'->_constructor_maker_for($class,'.perlstring($target).')' - ), - ) - ->install_delayed - ->register_attribute_specs(%{$con?$con->all_attribute_specs:{}}) - } -} - -1; -=pod - -=encoding utf-8 - -=head1 NAME - -Moo - Minimalist Object Orientation (with Moose compatiblity) - -=head1 SYNOPSIS - - package Cat::Food; - - use Moo; - use Sub::Quote; - - sub feed_lion { - my $self = shift; - my $amount = shift || 1; - - $self->pounds( $self->pounds - $amount ); - } - - has taste => ( - is => 'ro', - ); - - has brand => ( - is => 'ro', - isa => sub { - die "Only SWEET-TREATZ supported!" unless $_[0] eq 'SWEET-TREATZ' - }, -); - - has pounds => ( - is => 'rw', - isa => quote_sub q{ die "$_[0] is too much cat food!" unless $_[0] < 15 }, - ); - - 1; - -and else where - - my $full = Cat::Food->new( - taste => 'DELICIOUS.', - brand => 'SWEET-TREATZ', - pounds => 10, - ); - - $full->feed_lion; - - say $full->pounds; - -=head1 DESCRIPTION - -This module is an extremely light-weight, high-performance L replacement. -It also avoids depending on any XS modules to allow simple deployments. The -name C is based on the idea that it provides almost -but not quite- two -thirds of L. - -Unlike C this module does not aim at full L compatibility. See -L for more details. - -=head1 WHY MOO EXISTS - -If you want a full object system with a rich Metaprotocol, L is -already wonderful. - -I've tried several times to use L but it's 3x the size of Moo and -takes longer to load than most of my Moo based CGI scripts take to run. - -If you don't want L, you don't want "less metaprotocol" like L, -you want "as little as possible" - which means "no metaprotocol", which is -what Moo provides. - -By Moo 1.0 I intend to have Moo's equivalent of L built in - -if Moose gets loaded, any Moo class or role will act as a Moose equivalent -if treated as such. - -Hence - Moo exists as its name - Minimal Object Orientation - with a pledge -to make it smooth to upgrade to L when you need more than minimal -features. - -=head1 IMPORTED METHODS - -=head2 new - - Foo::Bar->new( attr1 => 3 ); - -or - - Foo::Bar->new({ attr1 => 3 }); - -=head2 BUILDARGS - - around BUILDARGS => sub { - my $orig = shift; - my ( $class, @args ) = @_; - - unshift @args, "attr1" if @args % 2 == 1; - - return $class->$orig(@args); - }; - - Foo::Bar->new( 3 ); - -The default implementation of this method accepts a hash or hash reference of -named parameters. If it receives a single argument that isn't a hash reference -it throws an error. - -You can override this method in your class to handle other types of options -passed to the constructor. - -This method should always return a hash reference of named options. - -=head2 BUILD - -Define a C method on your class and the constructor will automatically -call the C method from parent down to child after the object has -been instantiated. Typically this is used for object validation or possibly -logging. - -=head2 DEMOLISH - -If you have a C method anywhere in your inheritance hierarchy, -a C method is created on first object construction which will call -C<< $instance->DEMOLISH($in_global_destruction) >> for each C -method from child upwards to parents. - -Note that the C method is created on first construction of an object -of your class in order to not add overhead to classes without C -methods; this may prove slightly surprising if you try and define your own. - -=head2 does - - if ($foo->does('Some::Role1')) { - ... - } - -Returns true if the object composes in the passed role. - -=head1 IMPORTED SUBROUTINES - -=head2 extends - - extends 'Parent::Class'; - -Declares base class. Multiple superclasses can be passed for multiple -inheritance (but please use roles instead). - -Calling extends more than once will REPLACE your superclasses, not add to -them like 'use base' would. - -=head2 with - - with 'Some::Role1'; - with 'Some::Role2'; - -Composes a L into current class. Only one role may be composed in -at a time to allow the code to remain as simple as possible. - -=head2 has - - has attr => ( - is => 'ro', - ); - -Declares an attribute for the class. - -The options for C are as follows: - -=over 2 - -=item * is - -B, must be C or C. Unsurprisingly, C generates an -accessor that will not respond to arguments; to be clear: a getter only. C -will create a perlish getter/setter. - -=item * isa - -Takes a coderef which is meant to validate the attribute. Unlike L Moo -does not include a basic type system, so instead of doing C<< isa => 'Num' >>, -one should do - - isa => quote_sub q{ - die "$_[0] is not a number!" unless looks_like_number $_[0] - }, - -L - -=item * coerce - -Takes a coderef which is meant to coerce the attribute. The basic idea is to -do something like the following: - - coerce => quote_sub q{ - $_[0] + 1 unless $_[0] % 2 - }, - -Coerce does not require C to be defined. - -L - -=item * handles - -Takes a string - - handles => 'RobotRole' - -Where C is a role (L) that defines an interface which -becomes the list of methods to handle. - -Takes a list of methods - - handles => [ qw( one two ) ] - -Takes a hashref - - handles => { - un => 'one', - } - -=item * trigger - -Takes a coderef which will get called any time the attribute is set. Coderef -will be invoked against the object with the new value as an argument. - -Note that Moose also passes the old value, if any; this feature is not yet -supported. - -L - -=item * default - -Takes a coderef which will get called with $self as its only argument -to populate an attribute if no value is supplied to the constructor - or -if the attribute is lazy, when the attribute is first retrieved if no -value has yet been provided. - -Note that if your default is fired during new() there is no guarantee that -other attributes have been populated yet so you should not rely on their -existence. - -L - -=item * predicate - -Takes a method name which will return true if an attribute has a value. - -A common example of this would be to call it C, implying that the -object has a C<$foo> set. - -=item * builder - -Takes a method name which will be called to create the attribute - functions -exactly like default except that instead of calling - - $default->($self); - -Moo will call - - $self->$builder; - -=item * clearer - -Takes a method name which will clear the attribute. - -=item * lazy - -B. Set this if you want values for the attribute to be grabbed -lazily. This is usually a good idea if you have a L which requires -another attribute to be set. - -=item * required - -B. Set this if the attribute must be passed on instantiation. - -=item * reader - -The value of this attribute will be the name of the method to get the value of -the attribute. If you like Java style methods, you might set this to -C - -=item * writer - -The value of this attribute will be the name of the method to set the value of -the attribute. If you like Java style methods, you might set this to -C - -=item * weak_ref - -B. Set this if you want the reference that the attribute contains to -be weakened; use this when circular references are possible, which will cause -leaks. - -=item * init_arg - -Takes the name of the key to look for at instantiation time of the object. A -common use of this is to make an underscored attribute have a non-underscored -initialization name. C means that passing the value in on instantiation - -=back - -=head2 before - - before foo => sub { ... }; - -See L<< Class::Method::Modifiers/before method(s) => sub { ... } >> for full -documentation. - -=head2 around - - around foo => sub { ... }; - -See L<< Class::Method::Modifiers/around method(s) => sub { ... } >> for full -documentation. - -=head2 after - - after foo => sub { ... }; - -See L<< Class::Method::Modifiers/after method(s) => sub { ... } >> for full -documentation. - -=head1 SUB QUOTE AWARE - -L allows us to create coderefs that are "inlineable," -giving us a handy, XS-free speed boost. Any option that is L -aware can take advantage of this. - -=head1 INCOMPATIBILITIES WITH MOOSE - -You can only compose one role at a time. If your application is large or -complex enough to warrant complex composition, you wanted L. Note that -this does not mean you can only compose one role per class - - - with 'FirstRole'; - with 'SecondRole'; - -is absolutely fine, there's just currently no equivalent of Moose's - - with 'FirstRole', 'SecondRole'; - -which composes the two roles together, and then applies them. - -There is no built in type system. C is verified with a coderef, if you -need complex types, just make a library of coderefs, or better yet, functions -that return quoted subs. L provides a similar API -to L so that you can write - - has days_to_live => (is => 'ro', isa => Int); - -and have it work with both; it is hoped that providing only subrefs as an -API will encourage the use of other type systems as well, since it's -probably the weakest part of Moose design-wise. - -C is not supported in core since the author considers it to be a -bad idea but may be supported by an extension in future. - -There is no meta object. If you need this level of complexity you wanted -L - Moo succeeds at being small because it explicitly does not -provide a metaprotocol. - -No support for C, C, C, or C - override can -be handled by around albeit with a little more typing, and the author considers -augment to be a bad idea. - -The C method is not provided by default. The author suggests loading -L into C (via C for example) and -using C<$obj-E$::Dwarn()> instead. - -L only supports coderefs, because doing otherwise is usually a -mistake anyway. - -C is not supported per se, but of course it will work if you -manually set all the options it implies. - -C is not supported since the author considers it a bad idea. - -C is not supported since it's a very poor replacement for POD. - -Handling of warnings: when you C we enable FATAL warnings. The nearest -similar invocation for L would be: - - use Moose; - use warnings FATAL => "all"; - -Additionally, L supports a set of attribute option shortcuts intended to -reduce common boilerplate. The set of shortcuts is the same as in the L -module L. So if you: - - package MyClass; - use Moo; - -The nearest L invocation would be: - - package MyClass; - - use Moose; - use warnings FATAL => "all"; - use MooseX::AttributeShortcuts; - -or, if you're inheriting from a non-Moose class, - - package MyClass; - - use Moose; - use MooseX::NonMoose; - use warnings FATAL => "all"; - use MooseX::AttributeShortcuts; - -Finally, Moose requires you to call - - __PACKAGE__->meta->make_immutable; - -at the end of your class to get an inlined (i.e. not horribly slow) -constructor. Moo does it automatically the first time ->new is called -on your class. - -=head1 AUTHOR - -mst - Matt S. Trout (cpan:MSTROUT) - -=head1 CONTRIBUTORS - -dg - David Leadbeater (cpan:DGL) - -frew - Arthur Axel "fREW" Schmidt (cpan:FREW) - -hobbs - Andrew Rodland (cpan:ARODLAND) - -jnap - John Napiorkowski (cpan:JJNAPIORK) - -ribasushi - Peter Rabbitson (cpan:RIBASUSHI) - -chip - Chip Salzenberg (cpan:CHIPS) - -ajgb - Alex J. G. Burzyński (cpan:AJGB) - -doy - Jesse Luehrs (cpan:DOY) - -perigrin - Chris Prather (cpan:PERIGRIN) - -=head1 COPYRIGHT - -Copyright (c) 2010-2011 the Moo L and L -as listed above. - -=head1 LICENSE - -This library is free software and may be distributed under the same terms -as perl itself. - -=cut diff --git a/lib/Moo/Object.pm b/lib/Moo/Object.pm deleted file mode 100644 index 9968382..0000000 --- a/lib/Moo/Object.pm +++ /dev/null @@ -1,72 +0,0 @@ -package Moo::Object; - -use strictures 1; - -our %NO_BUILD; -our %NO_DEMOLISH; -our $BUILD_MAKER; -our $DEMOLISH_MAKER; - -sub new { - my $class = shift; - unless (exists $NO_DEMOLISH{$class}) { - unless ($NO_DEMOLISH{$class} = !$class->can('DEMOLISH')) { - ($DEMOLISH_MAKER ||= do { - require Method::Generate::DemolishAll; - Method::Generate::DemolishAll->new - })->generate_method($class); - } - } - $NO_BUILD{$class} and - return bless({ ref($_[0]) eq 'HASH' ? %{$_[0]} : @_ }, $class); - $NO_BUILD{$class} = !$class->can('BUILD') unless exists $NO_BUILD{$class}; - $NO_BUILD{$class} - ? bless({ ref($_[0]) eq 'HASH' ? %{$_[0]} : @_ }, $class) - : do { - my $proto = ref($_[0]) eq 'HASH' ? $_[0] : { @_ }; - bless({ %$proto }, $class)->BUILDALL($proto); - }; -} - -# Inlined into Method::Generate::Constructor::_generate_args() - keep in sync -sub BUILDARGS { - my $class = shift; - if ( scalar @_ == 1 ) { - unless ( defined $_[0] && ref $_[0] eq 'HASH' ) { - die "Single parameters to new() must be a HASH ref" - ." data => ". $_[0] ."\n"; - } - return { %{ $_[0] } }; - } - elsif ( @_ % 2 ) { - die "The new() method for $class expects a hash reference or a key/value list." - . " You passed an odd number of arguments\n"; - } - else { - return {@_}; - } -} - -sub BUILDALL { - my $self = shift; - $self->${\(($BUILD_MAKER ||= do { - require Method::Generate::BuildAll; - Method::Generate::BuildAll->new - })->generate_method(ref($self)))}(@_); -} - -sub DEMOLISHALL { - my $self = shift; - $self->${\(($DEMOLISH_MAKER ||= do { - require Method::Generate::DemolishAll; - Method::Generate::DemolishAll->new - })->generate_method(ref($self)))}(@_); -} - -sub does { - require Role::Tiny; - { no warnings 'redefine'; *does = \&Role::Tiny::does_role } - goto &Role::Tiny::does_role; -} - -1; diff --git a/lib/Moo/Role.pm b/lib/Moo/Role.pm deleted file mode 100644 index 5b3761f..0000000 --- a/lib/Moo/Role.pm +++ /dev/null @@ -1,142 +0,0 @@ -package Moo::Role; - -use strictures 1; -use Moo::_Utils; -use base qw(Role::Tiny); - -BEGIN { *INFO = \%Role::Tiny::INFO } - -our %INFO; - -sub import { - my $target = caller; - strictures->import; - return if $INFO{$target}; # already exported into this package - # get symbol table reference - my $stash = do { no strict 'refs'; \%{"${target}::"} }; - *{_getglob "${target}::has"} = sub { - my ($name, %spec) = @_; - ($INFO{$target}{accessor_maker} ||= do { - require Method::Generate::Accessor; - Method::Generate::Accessor->new - })->generate_method($target, $name, \%spec); - $INFO{$target}{attributes}{$name} = \%spec; - }; - goto &Role::Tiny::import; -} - -sub apply_role_to_package { - my ($me, $to, $role) = @_; - $me->SUPER::apply_role_to_package($to, $role); - $me->_handle_constructor($to, $INFO{$role}{attributes}); -} - -sub create_class_with_roles { - my ($me, $superclass, @roles) = @_; - - my $new_name = join( - '__WITH__', $superclass, my $compose_name = join '__AND__', @roles - ); - - return $new_name if $Role::Tiny::COMPOSED{class}{$new_name}; - - require Sub::Quote; - - $me->SUPER::create_class_with_roles($superclass, @roles); - - foreach my $role (@roles) { - die "${role} is not a Role::Tiny" unless my $info = $INFO{$role}; - } - - $Moo::MAKERS{$new_name} = {}; - - $me->_handle_constructor( - $new_name, { map %{$INFO{$_}{attributes}||{}}, @roles }, $superclass - ); - - return $new_name; -} - -sub _install_single_modifier { - my ($me, @args) = @_; - _install_modifier(@args); -} - -sub _handle_constructor { - my ($me, $to, $attr_info, $superclass) = @_; - return unless $attr_info && keys %$attr_info; - if ($INFO{$to}) { - @{$INFO{$to}{attributes}||={}}{keys %$attr_info} = values %$attr_info; - } else { - # only fiddle with the constructor if the target is a Moo class - if ($INC{"Moo.pm"} - and my $con = Moo->_constructor_maker_for($to, $superclass)) { - $con->register_attribute_specs(%$attr_info); - } - } -} - -1; - -=head1 NAME - -Moo::Role - Minimal Object Orientation support for Roles - -=head1 SYNOPSIS - - package My::Role; - - use Moo::Role; - - sub foo { ... } - - sub bar { ... } - - has baz => ( - is => 'ro', - ); - - 1; - -else where - - package Some::Class; - - use Moo; - - # bar gets imported, but not foo - with('My::Role'); - - sub foo { ... } - - 1; - -=head1 DESCRIPTION - -C builds upon L, so look there for most of the -documentation on how this works. The main addition here is extra bits to make -the roles more "Moosey;" which is to say, it adds L. - -=head1 IMPORTED SUBROUTINES - -See L for all the other subroutines that are -imported by this module. - -=head2 has - - has attr => ( - is => 'ro', - ); - -Declares an attribute for the class to be composed into. See -L for all options. - -=head1 AUTHORS - -See L for authors. - -=head1 COPYRIGHT AND LICENSE - -See L for the copyright and license. - -=cut diff --git a/lib/Moo/_Utils.pm b/lib/Moo/_Utils.pm deleted file mode 100644 index 5f62a98..0000000 --- a/lib/Moo/_Utils.pm +++ /dev/null @@ -1,86 +0,0 @@ -package Moo::_Utils; - -no warnings 'once'; # guard against -w - -sub _getglob { \*{$_[0]} } -sub _getstash { \%{"$_[0]::"} } - -BEGIN { - *lt_5_8_3 = $] < 5.008003 - ? sub () { 1 } - : sub () { 0 } - ; -} - -use strictures 1; -use Module::Runtime qw(require_module); -use base qw(Exporter); -use Moo::_mro; - -our @EXPORT = qw( - _getglob _install_modifier _load_module _maybe_load_module - _get_linear_isa -); - -sub _install_modifier { - my ($into, $type, $name, $code) = @_; - - if (my $to_modify = $into->can($name)) { # CMM will throw for us if not - require Sub::Defer; - Sub::Defer::undefer_sub($to_modify); - } - - Class::Method::Modifiers::install_modifier(@_); -} - -our %MAYBE_LOADED; - -sub _load_module { - (my $proto = $_[0]) =~ s/::/\//g; - return 1 if $INC{"${proto}.pm"}; - # can't just ->can('can') because a sub-package Foo::Bar::Baz - # creates a 'Baz::' key in Foo::Bar's symbol table - return 1 if grep !/::$/, keys %{_getstash($_[0])||{}}; - require_module($_[0]); - return 1; -} - -sub _maybe_load_module { - return $MAYBE_LOADED{$_[0]} if exists $MAYBE_LOADED{$_[0]}; - (my $proto = $_[0]) =~ s/::/\//g; - local $@; - if (eval { require "${proto}.pm"; 1 }) { - $MAYBE_LOADED{$_[0]} = 1; - } else { - if (exists $INC{"${proto}.pm"}) { - warn "$_[0] exists but failed to load with error: $@"; - } - $MAYBE_LOADED{$_[0]} = 0; - } - return $MAYBE_LOADED{$_[0]}; -} - -sub _get_linear_isa { - return mro::get_linear_isa($_[0]); -} - -our $_in_global_destruction = 0; -END { $_in_global_destruction = 1 } - -sub STANDARD_DESTROY { - my $self = shift; - - my $e = do { - local $?; - local $@; - eval { - $self->DEMOLISHALL($_in_global_destruction); - }; - $@; - }; - - no warnings 'misc'; - die $e if $e; # rethrow -} - -1; diff --git a/lib/Moo/_mro.pm b/lib/Moo/_mro.pm deleted file mode 100644 index e599045..0000000 --- a/lib/Moo/_mro.pm +++ /dev/null @@ -1,9 +0,0 @@ -package Moo::_mro; - -if ($] >= 5.010) { - require mro; -} else { - require MRO::Compat; -} - -1; diff --git a/lib/Sub/Defer.pm b/lib/Sub/Defer.pm deleted file mode 100644 index 8202687..0000000 --- a/lib/Sub/Defer.pm +++ /dev/null @@ -1,89 +0,0 @@ -package Sub::Defer; - -use strictures 1; -use base qw(Exporter); -use Moo::_Utils; - -our @EXPORT = qw(defer_sub undefer_sub); - -our %DEFERRED; - -sub undefer_sub { - my ($deferred) = @_; - my ($target, $maker, $undeferred_ref) = @{ - $DEFERRED{$deferred}||return $deferred - }; - ${$undeferred_ref} = my $made = $maker->(); - - # make sure the method slot has not changed since deferral time - if (defined($target) && $deferred eq *{_getglob($target)}{CODE}||'') { - no warnings 'redefine'; - *{_getglob($target)} = $made; - } - push @{$DEFERRED{$made} = $DEFERRED{$deferred}}, $made; - - return $made; -} - -sub defer_info { - my ($deferred) = @_; - $DEFERRED{$deferred||''}; -} - -sub defer_sub { - my ($target, $maker) = @_; - my $undeferred; - my $deferred_string; - my $deferred = sub { - goto &{$undeferred ||= undefer_sub($deferred_string)}; - }; - $deferred_string = "$deferred"; - $DEFERRED{$deferred} = [ $target, $maker, \$undeferred ]; - *{_getglob $target} = $deferred if defined($target); - return $deferred; -} - -1; - -=head1 NAME - -Sub::Defer - defer generation of subroutines until they are first called - -=head1 SYNOPSIS - - use Sub::Defer; - - my $deferred = defer_sub 'Logger::time_since_first_log' => sub { - my $t = time; - sub { time - $t }; - }; - - Logger->time_since_first_log; # returns 0 and replaces itself - Logger->time_since_first_log; # returns time - $t - -=head1 DESCRIPTION - -These subroutines provide the user with a convenient way to defer creation of -subroutines and methods until they are first called. - -=head1 SUBROUTINES - -=head2 defer_sub - - my $coderef = defer_sub $name => sub { ... }; - -This subroutine returns a coderef that encapsulates the provided sub - when -it is first called, the provided sub is called and is -itself- expected to -return a subroutine which will be goto'ed to on subsequent calls. - -If a name is provided, this also installs the sub as that name - and when -the subroutine is undeferred will re-install the final version for speed. - -=head2 undefer_sub - - my $coderef = undefer_sub \&Foo::name; - -If the passed coderef has been L this will "undefer" it. -If the passed coderef has not been deferred, this will just return it. - -If this is confusing, take a look at the example in the L. diff --git a/lib/Sub/Quote.pm b/lib/Sub/Quote.pm deleted file mode 100644 index 8567d78..0000000 --- a/lib/Sub/Quote.pm +++ /dev/null @@ -1,222 +0,0 @@ -package Sub::Quote; - -use strictures 1; - -sub _clean_eval { eval $_[0] } - -use Sub::Defer; -use B 'perlstring'; -use Scalar::Util qw(weaken); -use base qw(Exporter); - -our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub); - -our %QUOTED; - -our %WEAK_REFS; - -sub capture_unroll { - my ($from, $captures, $indent) = @_; - join( - '', - map { - /^([\@\%\$])/ - or die "capture key should start with \@, \% or \$: $_"; - (' ' x $indent).qq{my ${_} = ${1}{${from}->{${\perlstring $_}}};\n}; - } keys %$captures - ); -} - -sub inlinify { - my ($code, $args, $extra, $local) = @_; - my $do = 'do { '.($extra||''); - if (my ($code_args, $body) = $code =~ / +my \(([^)]+)\) = \@_;(.*)$/s) { - if ($code_args eq $args) { - $do.$body.' }' - } else { - $do.'my ('.$code_args.') = ('.$args.'); '.$body.' }'; - } - } else { - $do.($local ? 'local ' : '').'@_ = ('.$args.'); '.$code.' }'; - } -} - -sub quote_sub { - # HOLY DWIMMERY, BATMAN! - # $name => $code => \%captures => \%options - # $name => $code => \%captures - # $name => $code - # $code => \%captures => \%options - # $code - my $options = - (ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH') - ? pop - : {}; - my $captures = pop if ref($_[-1]) eq 'HASH'; - undef($captures) if $captures && !keys %$captures; - my $code = pop; - my $name = $_[0]; - my $outstanding; - my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub { - unquote_sub($outstanding); - }; - $outstanding = "$deferred"; - $QUOTED{$outstanding} = [ $name, $code, $captures ]; - weaken($WEAK_REFS{$outstanding} = $deferred); - return $deferred; -} - -sub quoted_from_sub { - my ($sub) = @_; - $WEAK_REFS{$sub||''} and $QUOTED{$sub||''}; -} - -sub unquote_sub { - my ($sub) = @_; - unless ($QUOTED{$sub}[3]) { - my ($name, $code, $captures) = @{$QUOTED{$sub}}; - - my $make_sub = "{\n"; - - if (keys %$captures) { - $make_sub .= capture_unroll("\$_[1]", $captures, 2); - } - - my $o_quoted = perlstring $sub; - $make_sub .= ( - $name - # disable the 'variable $x will not stay shared' warning since - # we're not letting it escape from this scope anyway so there's - # nothing trying to share it - ? " no warnings 'closure';\n sub ${name} {\n" - : " \$Sub::Quote::QUOTED{${o_quoted}}[3] = sub {\n" - ); - $make_sub .= $code; - $make_sub .= " }".($name ? '' : ';')."\n"; - if ($name) { - $make_sub .= " \$Sub::Quote::QUOTED{${o_quoted}}[3] = \\&${name}\n"; - } - $make_sub .= "}\n1;\n"; - $ENV{SUB_QUOTE_DEBUG} && warn $make_sub; - { - local $@; - no strict 'refs'; - local *{$name} if $name; - unless (_clean_eval $make_sub, $captures) { - die "Eval went very, very wrong:\n\n${make_sub}\n\n$@"; - } - } - } - $QUOTED{$sub}[3]; -} - -1; - -=head1 NAME - -Sub::Quote - efficient generation of subroutines via string eval - -=head1 SYNOPSIS - - package Silly; - - use Sub::Quote qw(quote_sub unquote_sub quoted_from_sub); - - quote_sub 'Silly::kitty', q{ print "meow" }; - - quote_sub 'Silly::doggy', q{ print "woof" }; - - my $sound = 0; - - quote_sub 'Silly::dagron', - q{ print ++$sound % 2 ? 'burninate' : 'roar' }, - { '$sound' => \$sound }; - -And elsewhere: - - Silly->kitty; # meow - Silly->doggy; # woof - Silly->dagron; # burninate - Silly->dagron; # roar - Silly->dagron; # burninate - -=head1 DESCRIPTION - -This package provides performant ways to generate subroutines from strings. - -=head1 SUBROUTINES - -=head2 quote_sub - - my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 }; - -Arguments: ?$name, $code, ?\%captures, ?\%options - -C<$name> is the subroutine where the coderef will be installed. - -C<$code> is a string that will be turned into code. - -C<\%captures> is a hashref of variables that will be made available to the -code. See the L's C for an example using captures. - -=head3 options - -=over 2 - -=item * no_install - -B. Set this option to not install the generated coderef into the -passed subroutine name on undefer. - -=back - -=head2 unquote_sub - - my $coderef = unquote_sub $sub; - -Forcibly replace subroutine with actual code. Note that for performance -reasons all quoted subs declared so far will be globally unquoted/parsed in -a single eval. This means that if you have a syntax error in one of your -quoted subs you may find out when some other sub is unquoted. - -If $sub is not a quoted sub, this is a no-op. - -=head2 quoted_from_sub - - my $data = quoted_from_sub $sub; - - my ($name, $code, $captures, $compiled_sub) = @$data; - -Returns original arguments to quote_sub, plus the compiled version if this -sub has already been unquoted. - -Note that $sub can be either the original quoted version or the compiled -version for convenience. - -=head2 inlinify - - my $prelude = capture_unroll { - '$x' => 1, - '$y' => 2, - }; - - my $inlined_code = inlinify q{ - my ($x, $y) = @_; - - print $x + $y . "\n"; - }, '$x, $y', $prelude; - -Takes a string of code, a string of arguments, a string of code which acts as a -"prelude", and a B representing whether or not to localize the -arguments. - -=head2 capture_unroll - - my $prelude = capture_unroll { - '$x' => 1, - '$y' => 2, - }; - -Generates a snippet of code which is suitable to be used as a prelude for -L. The keys are the names of the variables and the values are (duh) -the values. Note that references work as values. diff --git a/lib/oo.pm b/lib/oo.pm deleted file mode 100644 index e1ea141..0000000 --- a/lib/oo.pm +++ /dev/null @@ -1,33 +0,0 @@ -package oo; - -use strictures 1; -use Moo::_Utils; - -sub moo { - print <<'EOMOO'; - ______ -< Moo! > - ------ - \ ^__^ - \ (oo)\_______ - (__)\ )\/\ - ||----w | - || || -EOMOO - exit 0; -} - -BEGIN { - my $package; - sub import { - moo() if $0 eq '-'; - $package = $_[1] || 'Class'; - if ($package =~ /^\+/) { - $package =~ s/^\+//; - _load_module($package); - } - } - use Filter::Simple sub { s/^/package $package;\nuse Moo;\n/; } -} - -1; diff --git a/maint/Makefile.PL.include b/maint/Makefile.PL.include index 515c039..993a293 100644 --- a/maint/Makefile.PL.include +++ b/maint/Makefile.PL.include @@ -4,6 +4,4 @@ use Distar; author 'mst - Matt S. Trout (cpan:MSTROUT) '; -manifest_include t => 'global-destruction-helper.pl'; - 1; diff --git a/t/accessor-coerce.t b/t/accessor-coerce.t deleted file mode 100644 index d3a41e1..0000000 --- a/t/accessor-coerce.t +++ /dev/null @@ -1,205 +0,0 @@ -use strictures 1; -use Test::More; -use Test::Fatal; - -sub run_for { - my $class = shift; - - my $obj = $class->new(plus_three => 1); - - is($obj->plus_three, 4, "initial value set (${class})"); - - $obj->plus_three(4); - - is($obj->plus_three, 7, 'Value changes after set'); -} - -sub run_with_default_for { - my $class = shift; - - my $obj = $class->new(); - - is($obj->plus_three, 4, "initial value set (${class})"); - - $obj->plus_three(4); - - is($obj->plus_three, 7, 'Value changes after set'); -} - - - -{ - package Foo; - - use Moo; - - has plus_three => ( - is => 'rw', - coerce => sub { $_[0] + 3 } - ); -} - -run_for 'Foo'; - -{ - package Bar; - - use Sub::Quote; - use Moo; - - has plus_three => ( - is => 'rw', - coerce => quote_sub q{ - my ($x) = @_; - $x + 3 - } - ); -} - -run_for 'Bar'; - -{ - package Baz; - - use Sub::Quote; - use Moo; - - has plus_three => ( - is => 'rw', - coerce => quote_sub( - q{ - my ($value) = @_; - $value + $plus - }, - { '$plus' => \3 } - ) - ); -} - -run_for 'Baz'; - -{ - package Biff; - - use Sub::Quote; - use Moo; - - has plus_three => ( - is => 'rw', - coerce => quote_sub( - q{ - die 'could not add three!' - }, - ) - ); -} - -like exception { Biff->new(plus_three => 1) }, qr/could not add three!/, 'Exception properly thrown'; - -{ - package Foo2; - - use Moo; - - has plus_three => ( - is => 'rw', - default => sub { 1 }, - coerce => sub { $_[0] + 3 } - ); -} - -run_with_default_for 'Foo2'; - -{ - package Bar2; - - use Sub::Quote; - use Moo; - - has plus_three => ( - is => 'rw', - default => sub { 1 }, - coerce => quote_sub q{ - my ($x) = @_; - $x + 3 - } - ); -} - -run_with_default_for 'Bar2'; - -{ - package Baz2; - - use Sub::Quote; - use Moo; - - has plus_three => ( - is => 'rw', - default => sub { 1 }, - coerce => quote_sub( - q{ - my ($value) = @_; - $value + $plus - }, - { '$plus' => \3 } - ) - ); -} - -run_with_default_for 'Baz2'; - -{ - package Biff2; - - use Sub::Quote; - use Moo; - - has plus_three => ( - is => 'rw', - default => sub { 1 }, - coerce => quote_sub( - q{ - die 'could not add three!' - }, - ) - ); -} - -like exception { Biff2->new() }, qr/could not add three!/, 'Exception properly thrown'; - -{ - package Foo3; - - use Moo; - - has plus_three => ( - is => 'rw', - default => sub { 1 }, - coerce => sub { $_[0] + 3 }, - lazy => 1, - ); -} - -run_with_default_for 'Foo3'; - -{ - package Bar3; - - use Sub::Quote; - use Moo; - - has plus_three => ( - is => 'rw', - default => sub { 1 }, - coerce => quote_sub(q{ - my ($x) = @_; - $x + 3 - }), - lazy => 1, - ); -} - -run_with_default_for 'Bar3'; - -done_testing; diff --git a/t/accessor-default.t b/t/accessor-default.t deleted file mode 100644 index 1f3fbac..0000000 --- a/t/accessor-default.t +++ /dev/null @@ -1,37 +0,0 @@ -use strictures 1; -use Test::More; - -{ - package Foo; - - use Sub::Quote; - use Moo; - - has one => (is => 'ro', lazy => 1, default => quote_sub q{ {} }); - has two => (is => 'ro', lazy => 1, builder => '_build_two'); - sub _build_two { {} } - has three => (is => 'ro', default => quote_sub q{ {} }); - has four => (is => 'ro', builder => '_build_four'); - sub _build_four { {} } - has five => (is => 'ro', init_arg => undef, default => sub { {} }); -} - -sub check { - my ($attr, @h) = @_; - - is_deeply($h[$_], {}, "${attr}: empty hashref \$h[$_]") for 0..1; - - isnt($h[0],$h[1], "${attr}: not the same hashref"); -} - -check one => map Foo->new->one, 1..2; - -check two => map Foo->new->two, 1..2; - -check three => map Foo->new->{three}, 1..2; - -check four => map Foo->new->{four}, 1..2; - -check five => map Foo->new->{five}, 1..2; - -done_testing; diff --git a/t/accessor-handles.t b/t/accessor-handles.t deleted file mode 100644 index aee5958..0000000 --- a/t/accessor-handles.t +++ /dev/null @@ -1,52 +0,0 @@ -use strictures 1; -use Test::More; - -{ - package Robot; - - use Moo::Role; - - requires 'smash'; - -} - -{ - package Foo; - - use Moo; - - with 'Robot'; - - sub one {1} - sub two {2} - sub smash {'smash'} - sub yum {$_[1]} -} - -{ - package Bar; - - use Moo; - - has foo => ( is => 'ro', handles => [ qw(one two) ] ); - has foo2 => ( is => 'ro', handles => { un => 'one' } ); - has foo3 => ( is => 'ro', handles => 'Robot' ); - has foo4 => ( is => 'ro', handles => { - eat_curry => [ yum => 'Curry!' ], - }); -} - -my $bar = Bar->new( - foo => Foo->new, foo2 => Foo->new, foo3 => Foo->new, foo4 => Foo->new -); - -is $bar->one, 1, 'handles works'; -is $bar->two, 2, 'handles works for more than one method'; - -is $bar->un, 1, 'handles works for aliasing a method'; - -is $bar->smash, 'smash', 'handles works for a role'; - -is $bar->eat_curry, 'Curry!', 'handles works for currying'; - -done_testing; diff --git a/t/accessor-isa.t b/t/accessor-isa.t deleted file mode 100644 index 1e8f88f..0000000 --- a/t/accessor-isa.t +++ /dev/null @@ -1,87 +0,0 @@ -use strictures 1; -use Test::More; -use Test::Fatal; - -sub run_for { - my $class = shift; - - my $obj = $class->new(less_than_three => 1); - - is($obj->less_than_three, 1, "initial value set (${class})"); - - like( - exception { $obj->less_than_three(4) }, - qr/4 is not less than three/, "exception thrown on bad set (${class})" - ); - - is($obj->less_than_three, 1, "initial value remains after bad set (${class})"); - - my $ret; - - is( - exception { $ret = $obj->less_than_three(2) }, - undef, "no exception on correct set (${class})" - ); - - is($ret, 2, "correct setter return (${class})"); - is($obj->less_than_three, 2, "correct getter return (${class})"); - - is(exception { $class->new }, undef, "no exception with no value (${class})"); - like( - exception { $class->new(less_than_three => 12) }, - qr/12 is not less than three/, - "exception thrown on bad constructor arg (${class})" - ); -} - -{ - package Foo; - - use Moo; - - has less_than_three => ( - is => 'rw', - isa => sub { die "$_[0] is not less than three" unless $_[0] < 3 } - ); -} - -run_for 'Foo'; - -{ - package Bar; - - use Sub::Quote; - use Moo; - - has less_than_three => ( - is => 'rw', - isa => quote_sub q{ - my ($x) = @_; - die "$x is not less than three" unless $x < 3 - } - ); -} - -run_for 'Bar'; - -{ - package Baz; - - use Sub::Quote; - use Moo; - - has less_than_three => ( - is => 'rw', - isa => quote_sub( - q{ - my ($value) = @_; - die "$value is not less than ${word}" unless $value < $limit - }, - { '$limit' => \3, '$word' => \'three' } - ) - ); -} - -run_for 'Baz'; - -done_testing; diff --git a/t/accessor-mixed.t b/t/accessor-mixed.t deleted file mode 100644 index ecf91ca..0000000 --- a/t/accessor-mixed.t +++ /dev/null @@ -1,50 +0,0 @@ -use strictures 1; -use Test::More; - -my @result; - -{ - package Foo; - - use Moo; - - my @isa = (isa => sub { push @result, 'isa', $_[0] }); - my @trigger = (trigger => sub { push @result, 'trigger', $_[1] }); - sub _mkdefault { - my $val = shift; - (default => sub { push @result, 'default', $val; $val; }) - } - - has a1 => ( - is => 'rw', @isa - ); - has a2 => ( - is => 'rw', @isa, @trigger - ); - has a3 => ( - is => 'rw', @isa, @trigger - ); - has a4 => ( - is => 'rw', @trigger, _mkdefault('a4') - ); - has a5 => ( - is => 'rw', @trigger, _mkdefault('a5') - ); - has a6 => ( - is => 'rw', @isa, @trigger, _mkdefault('a6') - ); - has a7 => ( - is => 'rw', @isa, @trigger, _mkdefault('a7') - ); -} - -my $foo = Foo->new(a1 => 'a1', a2 => 'a2', a4 => 'a4', a6 => 'a6'); - -is_deeply( - \@result, - [ qw(isa a1 isa a2 trigger a2 trigger a4 default a5 isa a6 trigger a6 - default a7 isa a7) ], - 'Stuff fired in expected order' -); - -done_testing; diff --git a/t/accessor-pred-clear.t b/t/accessor-pred-clear.t deleted file mode 100644 index 4f73321..0000000 --- a/t/accessor-pred-clear.t +++ /dev/null @@ -1,25 +0,0 @@ -use strictures 1; -use Test::More; - -{ - package Foo; - - use Moo; - - has one => ( - is => 'ro', lazy => 1, default => sub { 3 }, - predicate => 'has_one', clearer => 'clear_one' - ); -} - -my $foo = Foo->new; - -ok(!$foo->has_one, 'empty'); -is($foo->one, 3, 'lazy default'); -ok($foo->has_one, 'not empty now'); -is($foo->clear_one, 3, 'clearer returns value'); -ok(!$foo->has_one, 'clearer empties'); -is($foo->one, 3, 'default re-fired'); -ok($foo->has_one, 'not empty again'); - -done_testing; diff --git a/t/accessor-reader-writer.t b/t/accessor-reader-writer.t deleted file mode 100644 index eed47f9..0000000 --- a/t/accessor-reader-writer.t +++ /dev/null @@ -1,43 +0,0 @@ -use strictures 1; -use Test::More; -use Test::Fatal; - -my @result; - -{ - package Foo; - - use Moo; - - has one => ( - is => 'rw', - reader => 'get_one', - writer => 'set_one', - ); -} - -{ - package Bar; - - use Moo; - - has two => ( - is => 'rw', - accessor => 'TWO', - ); -} - -my $foo = Foo->new(one => 'lol'); -my $bar = Bar->new(two => '...'); - -is( $foo->get_one, 'lol', 'reader works' ); -$foo->set_one('rofl'); -is( $foo->get_one, 'rofl', 'writer works' ); - -ok( exception { $foo->get_one('blah') }, 'reader dies on write' ); - -is( $bar->TWO, '...', 'accessor works for reading' ); -$bar->TWO('!!!'); -is( $bar->TWO, '!!!', 'accessor works for writing' ); - -done_testing; diff --git a/t/accessor-roles.t b/t/accessor-roles.t deleted file mode 100644 index eb8b8b6..0000000 --- a/t/accessor-roles.t +++ /dev/null @@ -1,25 +0,0 @@ -use strictures 1; -use Test::More; -use Sub::Quote; - -{ - package One; use Moo; - has one => (is => 'ro', default => sub { 'one' }); - - package One::P1; use Moo::Role; - has two => (is => 'ro', default => sub { 'two' }); - - package One::P2; use Moo::Role; - has three => (is => 'ro', default => sub { 'three' }); -} - -my $combined = Moo::Role->create_class_with_roles('One', qw(One::P1 One::P2)); -isa_ok $combined, "One"; -ok $combined->does($_), "Does $_" for qw(One::P1 One::P2); - -my $c = $combined->new; -is $c->one, "one", "attr default set from class"; -is $c->two, "two", "attr default set from role"; -is $c->three, "three", "attr default set from role"; - -done_testing; diff --git a/t/accessor-trigger.t b/t/accessor-trigger.t deleted file mode 100644 index 4728395..0000000 --- a/t/accessor-trigger.t +++ /dev/null @@ -1,96 +0,0 @@ -use strictures 1; -use Test::More; - -our @tr; - -sub run_for { - my $class = shift; - - @tr = (); - - my $obj = $class->new; - - ok(!@tr, "${class}: trigger not fired with no value"); - - $obj = $class->new(one => 1); - - is_deeply(\@tr, [ 1 ], "${class}: trigger fired on new"); - - my $res = $obj->one(2); - - is_deeply(\@tr, [ 1, 2 ], "${class}: trigger fired on set"); - - is($res, 2, "${class}: return from set ok"); - - is($obj->one, 2, "${class}: return from accessor ok"); - - is_deeply(\@tr, [ 1, 2 ], "${class}: trigger not fired for accessor as get"); -} - -{ - package Foo; - - use Moo; - - has one => (is => 'rw', trigger => sub { push @::tr, $_[1] }); -} - -run_for 'Foo'; - -{ - package Bar; - - use Sub::Quote; - use Moo; - - has one => (is => 'rw', trigger => quote_sub q{ push @::tr, $_[1] }); -} - -run_for 'Bar'; - -{ - package Baz; - - use Sub::Quote; - use Moo; - - has one => ( - is => 'rw', - trigger => quote_sub(q{ push @{$tr}, $_[1] }, { '$tr' => \\@::tr }) - ); -} - -run_for 'Baz'; - -{ - package Default; - - use Sub::Quote; - use Moo; - - has one => ( - is => 'rw', - trigger => quote_sub(q{ push @{$tr}, $_[1] }, { '$tr' => \\@::tr }), - default => sub { 0 } - ); -} - -run_for 'Default'; - -{ - package LazyDefault; - - use Sub::Quote; - use Moo; - - has one => ( - is => 'rw', - trigger => quote_sub(q{ push @{$tr}, $_[1] }, { '$tr' => \\@::tr }), - default => sub { 0 }, - lazy => 1 - ); -} - -run_for 'LazyDefault'; - -done_testing; diff --git a/t/accessor-weaken.t b/t/accessor-weaken.t deleted file mode 100644 index d390c27..0000000 --- a/t/accessor-weaken.t +++ /dev/null @@ -1,40 +0,0 @@ -use strictures 1; -use Test::More; - -{ - package Foo; - - use Moo; - - has one => (is => 'ro', weak_ref => 1); -} - -my $ref = {}; -my $foo = Foo->new(one => $ref); -is($foo->one, $ref, 'value present'); -ok(Scalar::Util::isweak($foo->{one}), 'value weakened'); -undef $ref; -ok (!defined $foo->{one}, 'weak value gone'); - -# test readonly SVs -sub mk_ref { \ 'yay' }; -my $foo_ro = eval { Foo->new(one => mk_ref()) }; -if ($] < 5.008003) { - like( - $@, - qr/\QReference to readonly value in "one" can not be weakened on Perl < 5.8.3/, - 'Expected exception thrown on old perls' - ); -} -elsif ($^O eq 'cygwin' and $] < 5.012000) { - SKIP: { skip 'Static coderef reaping seems nonfunctional on cygwin < 5.12', 1 } -} -else { - is(${$foo_ro->one},'yay', 'value present'); - ok(Scalar::Util::isweak($foo_ro->{one}), 'value weakened'); - - { no warnings 'redefine'; *mk_ref = sub {} } - ok (!defined $foo_ro->{one}, 'optree reaped, ro static value gone'); -} - -done_testing; diff --git a/t/buildall-subconstructor.t b/t/buildall-subconstructor.t deleted file mode 100644 index 2cfe28e..0000000 --- a/t/buildall-subconstructor.t +++ /dev/null @@ -1,88 +0,0 @@ -use strictures 1; -use Test::More; - -my @ran; - -{ - package Foo; use Moo; sub BUILD { push @ran, 'Foo' } - package Bar; use Moo; extends 'Foo'; sub BUILD { push @ran, 'Bar' } - package Baz; use Moo; extends 'Bar'; - package Quux; use Moo; extends 'Baz'; sub BUILD { push @ran, 'Quux' } -} - -{ - package Fleem; - use Moo; - extends 'Quux'; - has 'foo' => (is => 'ro'); - sub BUILD { push @ran, $_[0]->foo, $_[1]->{bar} } -} - -{ - package Odd1; - use Moo; - has 'odd1' => (is => 'ro'); - sub BUILD { push @ran, 'Odd1' } - package Odd2; - use Moo; - extends 'Odd1'; - package Odd3; - use Moo; - extends 'Odd2'; - has 'odd3' => (is => 'ro'); - sub BUILD { push @ran, 'Odd3' } -} - -{ - package Sub1; - use Moo; - has 'foo' => (is => 'ro'); - package Sub2; - use Moo; - extends 'Sub1'; - sub BUILD { push @ran, "sub2" } -} - -my @tests = ( - 'Foo' => { - ran => [qw( Foo )], - }, - 'Bar' => { - ran => [qw( Foo Bar )], - }, - 'Baz' => { - ran => [qw( Foo Bar )], - }, - 'Quux' => { - ran => [qw( Foo Bar Quux )], - }, - 'Fleem' => { - ran => [qw( Foo Bar Quux Fleem1 Fleem2 )], - args => [ foo => 'Fleem1', bar => 'Fleem2' ], - }, - 'Odd1' => { - ran => [qw( Odd1 )], - }, - 'Odd2' => { - ran => [qw( Odd1 )], - }, - 'Odd3' => { - ran => [qw( Odd1 Odd3 )], - args => [ odd1 => 1, odd3 => 3 ], - }, - 'Sub1' => { - ran => [], - }, - 'Sub2' => { - ran => [qw( sub2 )], - }, -); - -while ( my ($class, $conf) = splice(@tests,0,2) ) { - my $o = $class->new( @{ $conf->{args} || [] } ); - isa_ok($o, $class); - is_deeply(\@ran, $conf->{ran}, 'BUILDs ran in order'); - @ran = (); -} - -done_testing; diff --git a/t/buildall.t b/t/buildall.t deleted file mode 100644 index 9f441f0..0000000 --- a/t/buildall.t +++ /dev/null @@ -1,72 +0,0 @@ -use strictures 1; -use Test::More; - -my @ran; - -{ - package Foo; use Moo; sub BUILD { push @ran, 'Foo' } - package Bar; use Moo; extends 'Foo'; sub BUILD { push @ran, 'Bar' } - package Baz; use Moo; extends 'Bar'; - package Quux; use Moo; extends 'Baz'; sub BUILD { push @ran, 'Quux' } -} - -{ - package Fleem; - use Moo; - extends 'Quux'; - has 'foo' => (is => 'ro'); - sub BUILD { push @ran, $_[0]->foo, $_[1]->{bar} } -} - -{ - package Odd1; - use Moo; - has 'odd1' => (is => 'ro'); - sub BUILD { push @ran, 'Odd1' } - package Odd2; - use Moo; - extends 'Odd1'; - package Odd3; - use Moo; - extends 'Odd2'; - has 'odd3' => (is => 'ro'); - sub BUILD { push @ran, 'Odd3' } -} - -{ - package Sub1; - use Moo; - has 'foo' => (is => 'ro'); - package Sub2; - use Moo; - extends 'Sub1'; - sub BUILD { push @ran, "sub2" } -} - -my $o = Quux->new; - -is(ref($o), 'Quux', 'object returned'); -is_deeply(\@ran, [ qw(Foo Bar Quux) ], 'BUILDs ran in order'); - -@ran = (); - -$o = Fleem->new(foo => 'Fleem1', bar => 'Fleem2'); - -is(ref($o), 'Fleem', 'object with inline constructor returned'); -is_deeply(\@ran, [ qw(Foo Bar Quux Fleem1 Fleem2) ], 'BUILDs ran in order'); - -@ran = (); - -$o = Odd3->new(odd1 => 1, odd3 => 3); - -is(ref($o), 'Odd3', 'Odd3 object constructed'); -is_deeply(\@ran, [ qw(Odd1 Odd3) ], 'BUILDs ran in order'); - -@ran = (); - -$o = Sub2->new; - -is(ref($o), 'Sub2', 'Sub2 object constructed'); -is_deeply(\@ran, [ qw(sub2) ], 'BUILD ran'); - -done_testing; diff --git a/t/buildargs.t b/t/buildargs.t deleted file mode 100644 index f1e4c27..0000000 --- a/t/buildargs.t +++ /dev/null @@ -1,137 +0,0 @@ -use strictures 1; -use Test::More; - -{ - package Qux; - use Moo; - - has bar => ( is => "rw" ); - has baz => ( is => "rw" ); - - package Quux; - use Moo; - - extends qw(Qux); -} - -{ - package t::non_moo; - - sub new { - my ($class, $arg) = @_; - bless { attr => $arg }, $class; - } - - sub attr { shift->{attr} } - - package t::ext_non_moo::with_attr; - use Moo; - extends qw( t::non_moo ); - - has 'attr2' => ( is => 'ro' ); - - sub BUILDARGS { - my ( $class, @args ) = @_; - shift @args if @args % 2 == 1; - return { @args }; - } -} - - -{ - package Foo; - use Moo; - - has bar => ( is => "rw" ); - has baz => ( is => "rw" ); - - sub BUILDARGS { - my ( $class, @args ) = @_; - unshift @args, "bar" if @args % 2 == 1; - return $class->SUPER::BUILDARGS(@args); - } - - package Bar; - use Moo; - - extends qw(Foo); -} - -{ - package Baz; - use Moo; - - has bar => ( is => "rw" ); - has baz => ( is => "rw" ); - - around BUILDARGS => sub { - my $orig = shift; - my ( $class, @args ) = @_; - - unshift @args, "bar" if @args % 2 == 1; - - return $class->$orig(@args); - }; - - package Biff; - use Moo; - - extends qw(Baz); -} - -foreach my $class (qw(Foo Bar Baz Biff)) { - is( $class->new->bar, undef, "no args" ); - is( $class->new( bar => 42 )->bar, 42, "normal args" ); - is( $class->new( 37 )->bar, 37, "single arg" ); - { - my $o = $class->new(bar => 42, baz => 47); - is($o->bar, 42, '... got the right bar'); - is($o->baz, 47, '... got the right baz'); - } - { - my $o = $class->new(42, baz => 47); - is($o->bar, 42, '... got the right bar'); - is($o->baz, 47, '... got the right baz'); - } -} - -foreach my $class (qw(Qux Quux)) { - my $o = $class->new(bar => 42, baz => 47); - is($o->bar, 42, '... got the right bar'); - is($o->baz, 47, '... got the right baz'); - - eval { - $class->new( 37 ); - }; - like( $@, qr/Single parameters to new\(\) must be a HASH ref/, - "new() requires a list or a HASH ref" - ); - - eval { - $class->new( [ 37 ] ); - }; - like( $@, qr/Single parameters to new\(\) must be a HASH ref/, - "new() requires a list or a HASH ref" - ); - - eval { - $class->new( bar => 42, baz => 47, 'quux' ); - }; - like( $@, qr/You passed an odd number of arguments/, - "new() requires a list or a HASH ref" - ); -} - -my $non_moo = t::non_moo->new( 'bar' ); -my $ext_non_moo = t::ext_non_moo::with_attr->new( 'bar', attr2 => 'baz' ); - -is $non_moo->attr, 'bar', - "non-moo accepts params"; -is $ext_non_moo->attr, 'bar', - "extended non-moo passes params"; -is $ext_non_moo->attr2, 'baz', - "extended non-moo has own attributes"; - - -done_testing; - diff --git a/t/compose-roles.t b/t/compose-roles.t deleted file mode 100644 index 29a3342..0000000 --- a/t/compose-roles.t +++ /dev/null @@ -1,31 +0,0 @@ -use strictures 1; -use Test::More; - -{ - package One; use Role::Tiny; - around foo => sub { my $orig = shift; (__PACKAGE__, $orig->(@_)) }; - package Two; use Role::Tiny; - around foo => sub { my $orig = shift; (__PACKAGE__, $orig->(@_)) }; - package Three; use Role::Tiny; - around foo => sub { my $orig = shift; (__PACKAGE__, $orig->(@_)) }; - package Four; use Role::Tiny; - around foo => sub { my $orig = shift; (__PACKAGE__, $orig->(@_)) }; - package Base; sub foo { __PACKAGE__ } -} - -foreach my $combo ( - [ qw(One Two Three Four) ], - [ qw(Two Four Three) ], - [ qw(One Two) ] -) { - my $combined = Role::Tiny->create_class_with_roles('Base', @$combo); - is_deeply( - [ $combined->foo ], [ reverse(@$combo), 'Base' ], - "${combined} ok" - ); - my $object = bless({}, 'Base'); - Role::Tiny->apply_roles_to_object($object, @$combo); - is(ref($object), $combined, 'Object reblessed into correct class'); -} - -done_testing; diff --git a/t/demolish-basics.t b/t/demolish-basics.t deleted file mode 100644 index b5a83da..0000000 --- a/t/demolish-basics.t +++ /dev/null @@ -1,51 +0,0 @@ - -use strictures 1; -use Test::More; -use Test::Fatal; - -our @demolished; -package Foo; -use Moo; - -sub DEMOLISH { - my $self = shift; - push @::demolished, __PACKAGE__; -} - -package Foo::Sub; -use Moo; -extends 'Foo'; - -sub DEMOLISH { - my $self = shift; - push @::demolished, __PACKAGE__; -} - -package Foo::Sub::Sub; -use Moo; -extends 'Foo::Sub'; - -sub DEMOLISH { - my $self = shift; - push @::demolished, __PACKAGE__; -} - -package main; -{ - my $foo = Foo->new; -} -is_deeply(\@demolished, ['Foo'], "Foo demolished properly"); -@demolished = (); -{ - my $foo_sub = Foo::Sub->new; -} -is_deeply(\@demolished, ['Foo::Sub', 'Foo'], "Foo::Sub demolished properly"); -@demolished = (); -{ - my $foo_sub_sub = Foo::Sub::Sub->new; -} -is_deeply(\@demolished, ['Foo::Sub::Sub', 'Foo::Sub', 'Foo'], - "Foo::Sub::Sub demolished properly"); -@demolished = (); - -done_testing; diff --git a/t/demolish-bugs-eats_exceptions.t b/t/demolish-bugs-eats_exceptions.t deleted file mode 100644 index 7170b7a..0000000 --- a/t/demolish-bugs-eats_exceptions.t +++ /dev/null @@ -1,141 +0,0 @@ - -use strictures 1; -use Test::More; -use Test::Fatal; -use FindBin; - - -my $FilePath = sub { die "does not pass the type constraint" if $_[0] eq '/' }; - -{ - package Baz; - use Moo; - - has 'path' => ( - is => 'ro', - isa => $FilePath, - required => 1, - ); - - sub BUILD { - my ( $self, $params ) = @_; - die $params->{path} . " does not exist" - unless -e $params->{path}; - } - - # Defining this causes the FIRST call to Baz->new w/o param to fail, - # if no call to ANY Moo::Object->new was done before. - sub DEMOLISH { - my ( $self ) = @_; - } -} - -{ - package Qee; - use Moo; - - has 'path' => ( - is => 'ro', - isa => $FilePath, - required => 1, - ); - - sub BUILD { - my ( $self, $params ) = @_; - die $params->{path} . " does not exist" - unless -e $params->{path}; - } - - # Defining this causes the FIRST call to Qee->new w/o param to fail... - # if no call to ANY Moo::Object->new was done before. - sub DEMOLISH { - my ( $self ) = @_; - } -} - -{ - package Foo; - use Moo; - - has 'path' => ( - is => 'ro', - isa => $FilePath, - required => 1, - ); - - sub BUILD { - my ( $self, $params ) = @_; - die $params->{path} . " does not exist" - unless -e $params->{path}; - } - - # Having no DEMOLISH, everything works as expected... -} - -check_em ( 'Baz' ); # 'Baz plain' will fail, aka NO error -check_em ( 'Qee' ); # ok -check_em ( 'Foo' ); # ok - -check_em ( 'Qee' ); # 'Qee plain' will fail, aka NO error -check_em ( 'Baz' ); # ok -check_em ( 'Foo' ); # ok - -check_em ( 'Foo' ); # ok -check_em ( 'Baz' ); # ok ! -check_em ( 'Qee' ); # ok - - -sub check_em { - my ( $pkg ) = @_; - my ( %param, $obj ); - - # Uncomment to see, that it is really any first call. - # Subsequents calls will not fail, aka giving the correct error. - { - local $@; - my $obj = eval { $pkg->new; }; - ::like( $@, qr/Missing required argument/, "... $pkg plain" ); - ::is( $obj, undef, "... the object is undef" ); - } - { - local $@; - my $obj = eval { $pkg->new(); }; - ::like( $@, qr/Missing required argument/, "... $pkg empty" ); - ::is( $obj, undef, "... the object is undef" ); - } - { - local $@; - my $obj = eval { $pkg->new ( notanattr => 1 ); }; - ::like( $@, qr/Missing required argument/, "... $pkg undef" ); - ::is( $obj, undef, "... the object is undef" ); - } - - { - local $@; - my $obj = eval { $pkg->new ( %param ); }; - ::like( $@, qr/Missing required argument/, "... $pkg undef param" ); - ::is( $obj, undef, "... the object is undef" ); - } - { - local $@; - my $obj = eval { $pkg->new ( path => '/' ); }; - ::like( $@, qr/does not pass the type constraint/, "... $pkg root path forbidden" ); - ::is( $obj, undef, "... the object is undef" ); - } - { - local $@; - my $obj = eval { $pkg->new ( path => '/this_path/does/not_exist' ); }; - ::like( $@, qr/does not exist/, "... $pkg non existing path" ); - ::is( $obj, undef, "... the object is undef" ); - } - { - local $@; - my $obj = eval { $pkg->new ( path => $FindBin::Bin ); }; - ::is( $@, '', "... $pkg no error" ); - ::isa_ok( $obj, $pkg ); - ::isa_ok( $obj, 'Moo::Object' ); - ::is( $obj->path, $FindBin::Bin, "... $pkg got the right value" ); - } -} - -done_testing; diff --git a/t/demolish-bugs-eats_mini.t b/t/demolish-bugs-eats_mini.t deleted file mode 100644 index 43af629..0000000 --- a/t/demolish-bugs-eats_mini.t +++ /dev/null @@ -1,75 +0,0 @@ - -use strictures 1; -use Test::More; -use Test::Fatal; - -{ - package Foo; - use Moo; - - has 'bar' => ( - is => 'ro', - required => 1, - ); - - # Defining this causes the FIRST call to Baz->new w/o param to fail, - # if no call to ANY Moo::Object->new was done before. - sub DEMOLISH { - my ( $self ) = @_; - # ... Moo (kinda) eats exceptions in DESTROY/DEMOLISH"; - } -} - -{ - my $obj = eval { Foo->new; }; - like( $@, qr/Missing required arguments/, "... Foo plain" ); - is( $obj, undef, "... the object is undef" ); -} - -{ - package Bar; - - sub new { die "Bar died"; } - - sub DESTROY { - die "Vanilla Perl eats exceptions in DESTROY too"; - } -} - -{ - my $obj = eval { Bar->new; }; - like( $@, qr/Bar died/, "... Bar plain" ); - is( $obj, undef, "... the object is undef" ); -} - -{ - package Baz; - use Moo; - - sub DEMOLISH { - $? = 0; - } -} - -{ - local $@ = 42; - local $? = 84; - - { - Baz->new; - } - - is( $@, 42, '$@ is still 42 after object is demolished without dying' ); - is( $?, 84, '$? is still 84 after object is demolished without dying' ); - - local $@ = 0; - - { - Baz->new; - } - - is( $@, 0, '$@ is still 0 after object is demolished without dying' ); - -} - -done_testing; diff --git a/t/demolish-global_destruction.t b/t/demolish-global_destruction.t deleted file mode 100644 index 62ddf4c..0000000 --- a/t/demolish-global_destruction.t +++ /dev/null @@ -1,31 +0,0 @@ - -use strictures 1; -use Test::More; -use Test::Fatal; - -{ - package Foo; - use Moo; - - sub DEMOLISH { - my $self = shift; - my ($igd) = @_; - ::ok( - !$igd, - 'in_global_destruction state is passed to DEMOLISH properly (false)' - ); - } -} - -{ - my $foo = Foo->new; -} - -chomp(my $out = `$^X t/global-destruction-helper.pl`); - -is( - $out, 'true', - 'in_global_destruction state is passed to DEMOLISH properly (true)' -); - -done_testing; diff --git a/t/extends-non-moo.t b/t/extends-non-moo.t deleted file mode 100644 index 17d87fd..0000000 --- a/t/extends-non-moo.t +++ /dev/null @@ -1,67 +0,0 @@ -use strictures 1; -use Test::More; - -{ - package t::moo::extends_non_moo::base; - - sub new { - my ($proto, $args) = @_; - bless $args, $proto; - } - - sub to_app { - (shift)->{app}; - } - - package t::moo::extends_non_moo::middle; - use base qw(t::moo::extends_non_moo::base); - - sub wrap { - my($class, $app) = @_; - $class->new({app => $app}) - ->to_app; - } - - package t::moo::extends_non_moo::moo; - use Moo; - extends 't::moo::extends_non_moo::middle'; - - package t::moo::extends_non_moo::moo_with_attr; - use Moo; - extends 't::moo::extends_non_moo::middle'; - has 'attr' => (is=>'ro'); - - package t::moo::extends_non_moo::second_level_moo; - use Moo; - extends 't::moo::extends_non_moo::moo_with_attr'; - has 'attr2' => (is=>'ro'); -} - -ok my $app = 100, - 'prepared $app'; - -ok $app = t::moo::extends_non_moo::middle->wrap($app), - '$app from $app'; - -is $app, 100, - '$app still 100'; - -ok $app = t::moo::extends_non_moo::moo->wrap($app), - '$app from $app'; - -is $app, 100, - '$app still 100'; - -ok $app = t::moo::extends_non_moo::moo_with_attr->wrap($app), - '$app from $app'; - -is $app, 100, - '$app still 100'; - -ok $app = t::moo::extends_non_moo::second_level_moo->wrap($app), - '$app from $app'; - -is $app, 100, - '$app still 100'; - -done_testing(); diff --git a/t/global-destruction-helper.pl b/t/global-destruction-helper.pl deleted file mode 100644 index f238c06..0000000 --- a/t/global-destruction-helper.pl +++ /dev/null @@ -1,17 +0,0 @@ -use strictures 1; -use lib 'lib'; -no warnings 'once'; # work around 5.6.2 - -{ - package Foo; - use Moo; - - sub DEMOLISH { - my $self = shift; - my ($igd) = @_; - - print $igd ? "true" : "false", "\n"; - } -} - -our $foo = Foo->new; diff --git a/t/lib/base_class.pm b/t/lib/base_class.pm deleted file mode 100644 index c5dcaad..0000000 --- a/t/lib/base_class.pm +++ /dev/null @@ -1,7 +0,0 @@ -use strictures; - -package base_class; -use Moo; -extends "marp"; - -1; diff --git a/t/lib/sub_class.pm b/t/lib/sub_class.pm deleted file mode 100644 index 3959550..0000000 --- a/t/lib/sub_class.pm +++ /dev/null @@ -1,7 +0,0 @@ -use strictures; - -package sub_class; - -use Moo; - -extends 'base_class'; diff --git a/t/load_module.t b/t/load_module.t deleted file mode 100644 index 8704137..0000000 --- a/t/load_module.t +++ /dev/null @@ -1,22 +0,0 @@ -# this test is replicated to t/load_module_role_tiny.t for Role::Tiny - -# work around RT#67692 -use Moo::_Utils; -use strictures 1; - -use Test::More; - -local @INC = (sub { - return unless $_[1] eq 'Foo/Bar.pm'; - my $source = "package Foo::Bar; sub baz { 1 } 1"; - open my $fh, '<', \$source; - $fh; -}, @INC); - -{ package Foo::Bar::Baz; sub quux { } } - -_load_module("Foo::Bar"); - -ok(eval { Foo::Bar->baz }, 'Loaded module ok'); - -done_testing; diff --git a/t/load_module_error.t b/t/load_module_error.t deleted file mode 100644 index 464ef29..0000000 --- a/t/load_module_error.t +++ /dev/null @@ -1,14 +0,0 @@ -use strictures; - -package load_module_error; - -use Test::More; - -use lib 't/lib'; - -eval "use sub_class;"; - -ok $@, "got a crash"; -unlike $@, qr/Unknown error/, "it came with a useful error message"; - -done_testing; diff --git a/t/load_module_role_tiny.t b/t/load_module_role_tiny.t deleted file mode 100644 index 2c7c88f..0000000 --- a/t/load_module_role_tiny.t +++ /dev/null @@ -1,20 +0,0 @@ -# this test is replicated to t/load_module.t for Moo::_Utils - -use Role::Tiny (); -use strictures 1; -use Test::More; - -local @INC = (sub { - return unless $_[1] eq 'Foo/Bar.pm'; - my $source = "package Foo::Bar; sub baz { 1 } 1"; - open my $fh, '<', \$source; - $fh; -}, @INC); - -{ package Foo::Bar::Baz; sub quux { } } - -Role::Tiny::_load_module("Foo::Bar"); - -ok(eval { Foo::Bar->baz }, 'Loaded module ok'); - -done_testing; diff --git a/t/method-generate-accessor.t b/t/method-generate-accessor.t deleted file mode 100644 index 13ac5a8..0000000 --- a/t/method-generate-accessor.t +++ /dev/null @@ -1,38 +0,0 @@ -use strictures 1; -use Test::More; -use Test::Fatal; - -use Method::Generate::Accessor; - -my $gen = Method::Generate::Accessor->new; - -{ - package Foo; - use Moo; -} - -$gen->generate_method('Foo' => 'one' => { is => 'ro' }); - -$gen->generate_method('Foo' => 'two' => { is => 'rw' }); - -like( - exception { $gen->generate_method('Foo' => 'three' => {}) }, - qr/Must have an is/, 'No is rejected' -); - -like( - exception { $gen->generate_method('Foo' => 'three' => { is => 'purple' }) }, - qr/Unknown is purple/, 'is purple rejected' -); - -my $foo = Foo->new(one => 1); - -is($foo->one, 1, 'ro reads'); -ok(exception { $foo->one(-3) }, 'ro dies on write attempt'); -is($foo->one, 1, 'ro does not write'); - -is($foo->two, undef, 'rw reads'); -$foo->two(-3); -is($foo->two, -3, 'rw writes'); - -done_testing; diff --git a/t/method-generate-constructor.t b/t/method-generate-constructor.t deleted file mode 100644 index 6299010..0000000 --- a/t/method-generate-constructor.t +++ /dev/null @@ -1,66 +0,0 @@ -use strictures 1; -use Test::More; -use Test::Fatal; - -use Method::Generate::Constructor; -use Method::Generate::Accessor; - -my $gen = Method::Generate::Constructor->new( - accessor_generator => Method::Generate::Accessor->new -); - -$gen->generate_method('Foo', 'new', { - one => { }, - two => { init_arg => undef }, - three => { init_arg => 'THREE' } -}); - -my $first = Foo->new({ - one => 1, - two => 2, - three => -75, - THREE => 3, - four => 4, -}); - -is_deeply( - { %$first }, { one => 1, three => 3 }, - 'init_arg handling ok' -); - -$gen->generate_method('Bar', 'new' => { - one => { required => 1 }, - three => { init_arg => 'THREE', required => 1 } -}); - -like( - exception { Bar->new }, - qr/Missing required arguments: THREE, one/, - 'two missing args reported correctly' -); - -like( - exception { Bar->new(THREE => 3) }, - qr/Missing required arguments: one/, - 'one missing arg reported correctly' -); - -is( - exception { Bar->new(one => 1, THREE => 3) }, - undef, - 'pass with both required args' -); - -is( - exception { Bar->new({ one => 1, THREE => 3 }) }, - undef, - 'hashrefs also supported' -); - -is( - exception { $first->new(one => 1, THREE => 3) }, - undef, - 'calling ->new on an object works' -); - -done_testing; diff --git a/t/moo-accessors.t b/t/moo-accessors.t deleted file mode 100644 index a5d28c7..0000000 --- a/t/moo-accessors.t +++ /dev/null @@ -1,51 +0,0 @@ -use strictures 1; -use Test::More; - -{ - package Foo; - - use Moo; - - has one => (is => 'ro'); - has two => (is => 'rw', init_arg => undef); - has three => (is => 'ro', init_arg => 'THREE', required => 1); - - package Bar; - - use Moo::Role; - - has four => (is => 'ro'); - - package Baz; - - use Moo; - - extends 'Foo'; - - with 'Bar'; - - has five => (is => 'rw'); -} - -my $foo = Foo->new( - one => 1, - THREE => 3 -); - -is_deeply( - { %$foo }, { one => 1, three => 3 }, 'simple class ok' -); - -my $baz = Baz->new( - one => 1, - THREE => 3, - four => 4, - five => 5, -); - -is_deeply( - { %$baz }, { one => 1, three => 3, four => 4, five => 5 }, - 'subclass with role ok' -); - -done_testing; diff --git a/t/moo.t b/t/moo.t deleted file mode 100644 index 2ba2a00..0000000 --- a/t/moo.t +++ /dev/null @@ -1,80 +0,0 @@ -use strictures 1; -use Test::More; - -{ - package MyClass0; - - BEGIN { our @ISA = 'ZeroZero' } - - use Moo; -} - -BEGIN { - is( - $INC{'Class/Tiny/Object.pm'}, undef, - 'Object.pm not loaded if not required' - ); -} - -{ - package MyClass1; - - use Moo; -} - -is_deeply( - [ @MyClass1::ISA ], [ 'Moo::Object' ], 'superclass defaulted' -); - -{ - package MyClass2; - - use base qw(MyClass1); - use Moo; -} - -is_deeply( - [ @MyClass2::ISA ], [ 'MyClass1' ], 'prior superclass left alone' -); - -{ - package MyClass3; - - use Moo; - - extends 'MyClass2'; -} - -is_deeply( - [ @MyClass3::ISA ], [ 'MyClass2' ], 'extends sets superclass' -); - -{ package WhatTheFlyingFornication; sub wtff {} } - -{ - package MyClass4; - - use Moo; - - extends 'WhatTheFlyingFornication'; - - extends qw(MyClass2 MyClass3); -} - -is_deeply( - [ @MyClass4::ISA ], [ qw(MyClass2 MyClass3) ], 'extends overwrites' -); - -{ - package MyClass5; - - use Moo; - - sub foo { 'foo' } - - around foo => sub { my $orig = shift; $orig->(@_).' with around' }; -} - -is(MyClass5->foo, 'foo with around', 'method modifier'); - -done_testing; diff --git a/t/role-tiny-with.t b/t/role-tiny-with.t index b77a70c..8fc2b14 100644 --- a/t/role-tiny-with.t +++ b/t/role-tiny-with.t @@ -1,4 +1,5 @@ -use strictures 1; +use strict; +use warnings FATAL => 'all'; use Test::More; BEGIN { diff --git a/t/role-tiny.t b/t/role-tiny.t index ebd7b8e..cf221ab 100644 --- a/t/role-tiny.t +++ b/t/role-tiny.t @@ -1,4 +1,5 @@ -use strictures 1; +use strict; +use warnings FATAL => 'all'; use Test::More; use Test::Fatal; diff --git a/t/sub-defer.t b/t/sub-defer.t deleted file mode 100644 index ba7f042..0000000 --- a/t/sub-defer.t +++ /dev/null @@ -1,57 +0,0 @@ -use strictures 1; -use Test::More; -use Sub::Defer; - -my %made; - -my $one_defer = defer_sub 'Foo::one' => sub { - die "remade - wtf" if $made{'Foo::one'}; - $made{'Foo::one'} = sub { 'one' } -}; - -my $two_defer = defer_sub 'Foo::two' => sub { - die "remade - wtf" if $made{'Foo::two'}; - $made{'Foo::two'} = sub { 'two' } -}; - -is($one_defer, \&Foo::one, 'one defer installed'); -is($two_defer, \&Foo::two, 'two defer installed'); - -is($one_defer->(), 'one', 'one defer runs'); - -is($made{'Foo::one'}, \&Foo::one, 'one made'); - -is($made{'Foo::two'}, undef, 'two not made'); - -is($one_defer->(), 'one', 'one (deferred) still runs'); - -is(Foo->one, 'one', 'one (undeferred) runs'); - -is(my $two_made = undefer_sub($two_defer), $made{'Foo::two'}, 'make two'); - -is($two_made, \&Foo::two, 'two installed'); - -is($two_defer->(), 'two', 'two (deferred) still runs'); - -is($two_made->(), 'two', 'two (undeferred) runs'); - -my $three = sub { 'three' }; - -is(undefer_sub($three), $three, 'undefer non-deferred is a no-op'); - -my $four_defer = defer_sub 'Foo::four' => sub { - sub { 'four' } -}; -is($four_defer, \&Foo::four, 'four defer installed'); - -# somebody somewhere wraps up around the deferred installer -no warnings qw/redefine/; -my $orig = Foo->can('four'); -*Foo::four = sub { - $orig->() . ' with a twist'; -}; - -is(Foo->four, 'four with a twist', 'around works'); -is(Foo->four, 'four with a twist', 'around has not been destroyed by first invocation'); - -done_testing; diff --git a/t/sub-quote.t b/t/sub-quote.t deleted file mode 100644 index 4cc9a1d..0000000 --- a/t/sub-quote.t +++ /dev/null @@ -1,50 +0,0 @@ -use strictures 1; -use Test::More; -use Test::Fatal; - -use Sub::Quote; - -our %EVALED; - -my $one = quote_sub q{ - BEGIN { $::EVALED{'one'} = 1 } - 42 -}; - -my $two = quote_sub q{ - BEGIN { $::EVALED{'two'} = 1 } - 3 + $x++ -} => { '$x' => \do { my $x = 0 } }; - -ok(!keys %EVALED, 'Nothing evaled yet'); - -my $u_one = unquote_sub $one; - -is_deeply( - [ sort keys %EVALED ], [ qw(one) ], - 'subs one evaled' -); - -is($one->(), 42, 'One (quoted version)'); - -is($u_one->(), 42, 'One (unquoted version)'); - -is($two->(), 3, 'Two (quoted version)'); -is(unquote_sub($two)->(), 4, 'Two (unquoted version)'); -is($two->(), 5, 'Two (quoted version again)'); - -my $three = quote_sub 'Foo::three' => q{ - $x = $_[1] if $_[1]; - die +(caller(0))[3] if @_ > 2; - return $x; -} => { '$x' => \do { my $x = 'spoon' } }; - -is(Foo->three, 'spoon', 'get ok (named method)'); -is(Foo->three('fork'), 'fork', 'set ok (named method)'); -is(Foo->three, 'fork', 're-get ok (named method)'); -like( - exception { Foo->three(qw(full cutlery set)) }, qr/Foo::three/, - 'exception contains correct name' -); - -done_testing;