+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
'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) : (),
);
+++ /dev/null
-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;
- }
- ;
-}
+++ /dev/null
-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 $@;
-}
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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<Moose> replacement.
-It also avoids depending on any XS modules to allow simple deployments. The
-name C<Moo> is based on the idea that it provides almost -but not quite- two
-thirds of L<Moose>.
-
-Unlike C<Mouse> this module does not aim at full L<Moose> compatibility. See
-L</INCOMPATIBILITIES> for more details.
-
-=head1 WHY MOO EXISTS
-
-If you want a full object system with a rich Metaprotocol, L<Moose> is
-already wonderful.
-
-I've tried several times to use L<Mouse> 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<Moose>, you don't want "less metaprotocol" like L<Mouse>,
-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<Any::Moose> 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<Moose> 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<BUILD> method on your class and the constructor will automatically
-call the C<BUILD> 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<DEMOLISH> method anywhere in your inheritance hierarchy,
-a C<DESTROY> method is created on first object construction which will call
-C<< $instance->DEMOLISH($in_global_destruction) >> for each C<DEMOLISH>
-method from child upwards to parents.
-
-Note that the C<DESTROY> method is created on first construction of an object
-of your class in order to not add overhead to classes without C<DEMOLISH>
-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<Role::Tiny> 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<has> are as follows:
-
-=over 2
-
-=item * is
-
-B<required>, must be C<ro> or C<rw>. Unsurprisingly, C<ro> generates an
-accessor that will not respond to arguments; to be clear: a getter only. C<rw>
-will create a perlish getter/setter.
-
-=item * isa
-
-Takes a coderef which is meant to validate the attribute. Unlike L<Moose> 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<Sub::Quote aware|/SUB QUOTE AWARE>
-
-=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<isa> to be defined.
-
-L<Sub::Quote aware|/SUB QUOTE AWARE>
-
-=item * handles
-
-Takes a string
-
- handles => 'RobotRole'
-
-Where C<RobotRole> is a role (L<Moo::Role>) 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<Sub::Quote aware|/SUB QUOTE AWARE>
-
-=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<Sub::Quote aware|/SUB QUOTE AWARE>
-
-=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<has_$foo>, 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<Boolean>. Set this if you want values for the attribute to be grabbed
-lazily. This is usually a good idea if you have a L</builder> which requires
-another attribute to be set.
-
-=item * required
-
-B<Boolean>. 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<get_foo>
-
-=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<set_foo>
-
-=item * weak_ref
-
-B<Boolean>. 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<undef> 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<Sub::Quote/quote_sub> allows us to create coderefs that are "inlineable,"
-giving us a handy, XS-free speed boost. Any option that is L<Sub::Quote>
-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<Moose>. 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<isa> 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<MooX::Types::MooseLike> provides a similar API
-to L<MooseX::Types::Moose> 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<initializer> 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<Moose> - Moo succeeds at being small because it explicitly does not
-provide a metaprotocol.
-
-No support for C<super>, C<override>, C<inner>, or C<augment> - override can
-be handled by around albeit with a little more typing, and the author considers
-augment to be a bad idea.
-
-The C<dump> method is not provided by default. The author suggests loading
-L<Devel::Dwarn> into C<main::> (via C<perl -MDevel::Dwarn ...> for example) and
-using C<$obj-E<gt>$::Dwarn()> instead.
-
-L</default> only supports coderefs, because doing otherwise is usually a
-mistake anyway.
-
-C<lazy_build> is not supported per se, but of course it will work if you
-manually set all the options it implies.
-
-C<auto_deref> is not supported since the author considers it a bad idea.
-
-C<documentation> is not supported since it's a very poor replacement for POD.
-
-Handling of warnings: when you C<use Moo> we enable FATAL warnings. The nearest
-similar invocation for L<Moose> would be:
-
- use Moose;
- use warnings FATAL => "all";
-
-Additionally, L<Moo> supports a set of attribute option shortcuts intended to
-reduce common boilerplate. The set of shortcuts is the same as in the L<Moose>
-module L<MooseX::AttributeShortcuts>. So if you:
-
- package MyClass;
- use Moo;
-
-The nearest L<Moose> 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) <mst@shadowcat.co.uk>
-
-=head1 CONTRIBUTORS
-
-dg - David Leadbeater (cpan:DGL) <dgl@dgl.cx>
-
-frew - Arthur Axel "fREW" Schmidt (cpan:FREW) <frioux@gmail.com>
-
-hobbs - Andrew Rodland (cpan:ARODLAND) <arodland@cpan.org>
-
-jnap - John Napiorkowski (cpan:JJNAPIORK) <jjn1056@yahoo.com>
-
-ribasushi - Peter Rabbitson (cpan:RIBASUSHI) <ribasushi@cpan.org>
-
-chip - Chip Salzenberg (cpan:CHIPS) <chip@pobox.com>
-
-ajgb - Alex J. G. Burzyński (cpan:AJGB) <ajgb@cpan.org>
-
-doy - Jesse Luehrs (cpan:DOY) <doy at tozt dot net>
-
-perigrin - Chris Prather (cpan:PERIGRIN) <chris@prather.org>
-
-=head1 COPYRIGHT
-
-Copyright (c) 2010-2011 the Moo L</AUTHOR> and L</CONTRIBUTORS>
-as listed above.
-
-=head1 LICENSE
-
-This library is free software and may be distributed under the same terms
-as perl itself.
-
-=cut
+++ /dev/null
-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;
+++ /dev/null
-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<Moo::Role> builds upon L<Role::Tiny>, 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</has>.
-
-=head1 IMPORTED SUBROUTINES
-
-See L<Role::Tiny/IMPORTED SUBROUTINES> 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<Moo/has> for all options.
-
-=head1 AUTHORS
-
-See L<Moo> for authors.
-
-=head1 COPYRIGHT AND LICENSE
-
-See L<Moo> for the copyright and license.
-
-=cut
+++ /dev/null
-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;
+++ /dev/null
-package Moo::_mro;
-
-if ($] >= 5.010) {
- require mro;
-} else {
- require MRO::Compat;
-}
-
-1;
+++ /dev/null
-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<deferred|/defer_sub> 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</SYNOPSIS>.
+++ /dev/null
-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</SYNOPSIS>'s C<Silly::dagron> for an example using captures.
-
-=head3 options
-
-=over 2
-
-=item * no_install
-
-B<Boolean>. 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<Boolean> 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</inlinify>. The keys are the names of the variables and the values are (duh)
-the values. Note that references work as values.
+++ /dev/null
-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;
author 'mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>';
-manifest_include t => 'global-destruction-helper.pl';
-
1;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
-
+++ /dev/null
-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;
+++ /dev/null
-
-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;
+++ /dev/null
-
-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;
+++ /dev/null
-
-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;
+++ /dev/null
-
-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;
+++ /dev/null
-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();
+++ /dev/null
-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;
+++ /dev/null
-use strictures;
-
-package base_class;
-use Moo;
-extends "marp";
-
-1;
+++ /dev/null
-use strictures;
-
-package sub_class;
-
-use Moo;
-
-extends 'base_class';
+++ /dev/null
-# 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;
+++ /dev/null
-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;
+++ /dev/null
-# 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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
+++ /dev/null
-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;
-use strictures 1;
+use strict;
+use warnings FATAL => 'all';
use Test::More;
BEGIN {
-use strictures 1;
+use strict;
+use warnings FATAL => 'all';
use Test::More;
use Test::Fatal;
+++ /dev/null
-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;
+++ /dev/null
-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;
projects / gitmo/Role-Tiny.git / commitdiff