MouseX-NativeTraits-1.09/0000755€(NñY€ZÃ);0000000000012054627374017660 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/benchmarks/0000755€(NñY€ZÃ);0000000000012054627374021775 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/benchmarks/arrayref.pl0000644€(NñY€ZÃ);0000000230412054627122024133 0ustar fuji.goroDENA\Domain Users#!perl -w use strict; use Benchmark qw(:all); print "Benchmark for native traits (Array)\n"; { package MouseStack; use Mouse; has stack => ( is => 'rw', isa => 'ArrayRef', traits => ['Array'], handles => { pop => 'pop', push => 'push', top => [ get => -1 ], is_empty => 'is_empty', }, default => sub{ [] }, ); __PACKAGE__->meta->make_immutable(); } { package MooseStack; use Moose; has stack => ( is => 'rw', isa => 'ArrayRef', traits => ['Array'], handles => { pop => 'pop', push => 'push', top => [ get => -1 ], is_empty => 'is_empty', }, default => sub{ [] }, ); __PACKAGE__->meta->make_immutable(); } my $mouse = MouseStack->new; my $moose = MooseStack->new; print "push && pop && is_empty\n"; cmpthese -1 => { Mouse => sub{ $mouse->push($_) for 1 .. 100; $mouse->pop() until $mouse->is_empty; }, Moose => sub{ $moose->push($_) for 1 .. 100; $moose->pop() until $moose->is_empty; }, }; MouseX-NativeTraits-1.09/benchmarks/bool.pl0000644€(NñY€ZÃ);0000000164412054627122023261 0ustar fuji.goroDENA\Domain Users#!perl -w use strict; use Benchmark qw(:all); print "Benchmark for native traits (Bool)\n"; { package MouseBool; use Mouse; has ok => ( is => 'rw', isa => 'Bool', traits => ['Bool'], handles => { toggle => 'toggle', }, default => 0, ); __PACKAGE__->meta->make_immutable(); } { package MooseBool; use Moose; has ok => ( is => 'rw', isa => 'Bool', traits => ['Bool'], handles => { toggle => 'toggle', }, default => 0, ); __PACKAGE__->meta->make_immutable(); } my $mouse = MouseBool->new; my $moose = MooseBool->new; print "toggle && ok\n"; cmpthese -1 => { Mouse => sub{ $mouse->toggle(); $mouse->ok && $mouse->ok && $mouse->ok; }, Moose => sub{ $moose->toggle(); $moose->ok && $moose->ok && $moose->ok; }, }; MouseX-NativeTraits-1.09/benchmarks/inc.pl0000644€(NñY€ZÃ);0000000106312054627122023072 0ustar fuji.goroDENA\Domain Users#!perl use strict; package MyHomePage; use Mouse; has 'counter' => ( traits => ['Counter'], is => 'rw', isa => 'Int', default => 0, handles => { inc_counter => 'inc', dec_counter => 'dec', reset_counter => 'reset', }, ); sub by_hand_inc_counter { return $_[0]->counter( $_[0]->counter + 1 ); } package main; use Benchmark qw(cmpthese); my $obj = MyHomePage->new; cmpthese shift || -1, { mousex => sub { $obj->inc_counter }, by_hand => sub { $obj->by_hand_inc_counter }, }; MouseX-NativeTraits-1.09/benchmarks/inc2.pl0000644€(NñY€ZÃ);0000000176112054627122023161 0ustar fuji.goroDENA\Domain Users#!perl -w use strict; use Benchmark qw(:all); print "Benchmark for native traits (Counter)\n"; { package MouseCounter; use Mouse; has ok => ( is => 'rw', isa => 'Int', traits => ['Counter'], handles => { inc2 => [inc => 2 ], }, default => 0, clearer => 'foo', ); __PACKAGE__->meta->make_immutable(); } { package MooseCounter; use Moose; has ok => ( is => 'rw', isa => 'Int', traits => ['Counter'], handles => { inc2 => [inc => 2 ], }, default => 0, ); __PACKAGE__->meta->make_immutable(); } print "curried inc\n"; cmpthese -1 => { Mouse => sub{ my $mouse = MouseCounter->new; $mouse->inc2() for 1 .. 100; $mouse->ok == 200 or die $mouse->ok; }, Moose => sub{ my $moose = MooseCounter->new; $moose->inc2() for 1 .. 100; $moose->ok == 200 or die $moose->ok; }, }; MouseX-NativeTraits-1.09/benchmarks/sort_by.pl0000644€(NñY€ZÃ);0000000216512054627122024006 0ustar fuji.goroDENA\Domain Users#!perl -w use strict; use Benchmark qw(:all); use Digest::MD5 qw(md5_hex); print "Benchmark for native traits (Array)\n"; { package MouseList; use Mouse; has list => ( traits => ['Array'], is => 'rw', handles => { sort => 'sort', sort_by => 'sort_by', }, default => sub{ [] }, ); __PACKAGE__->meta->make_immutable(); } sub f{ return md5_hex($_[0]); } print "sort_by vs. sort (10 items)\n"; cmpthese -1 => { sort_by => sub{ my $o = MouseList->new(list => [0 .. 10]); my @a = $o->sort_by(sub{ f($_) }, sub{ $_[0] cmp $_[1] }); }, sort => sub{ my $o = MouseList->new(list => [0 .. 10]); my @a = $o->sort(sub{ f($_[0]) cmp f($_[1]) }); }, }; print "sort_by vs. sort (100 items)\n"; cmpthese timethese -1 => { sort_by => sub{ my $o = MouseList->new(list => [0 .. 100]); my @a = $o->sort_by(sub{ f($_) }, sub{ $_[0] cmp $_[1] }); }, sort => sub{ my $o = MouseList->new(list => [0 .. 100]); my @a = $o->sort(sub{ f($_[0]) cmp f($_[1]) }); }, }; MouseX-NativeTraits-1.09/Changes0000644€(NñY€ZÃ);0000000231312054627341021144 0ustar fuji.goroDENA\Domain UsersRevision history for Perl extension MouseX::NativeTraits 1.09 2012-11-26 17:56:42 - Remove "set" handler from pod 1.08 2012-10-20 20:51:22 - No feature changes. Just upgraded Module::Install. 1.07 2011-12-04 16:11:32 - Resolve RT #69039 - Hash trait: Tied hashes become "untied" when using setter 1.06 2011-12-04 15:23:07 - Apply a patch in RT #72900 - Spelling gritch (gregor herrmann) 1.05 2011-11-28 13:09:51 - Resolve RT #72549 - Counter is slower than doing it by hand 1.04 2010-11-08 14:06:41 - Workaround test problms, again 1.03 2010-11-07 17:07:09 - Workaround test problems 1.02 2010-11-06 19:36:15 - Fix testing issue on Windows/nmake 1.01 2010-11-05 20:27:52 - This is a major update - Requires Mouse 0.82 for type constraint robusity - Follow Moose 1.19 except for smart coercions 1.00 Mon Sep 27 15:01:21 2010 - No functional changes - Follow Mouse 0.74, which is more compatible with Moose 0.002 Mon Mar 15 15:56:36 2010 - First non-dev release 0.001_02 Mon Feb 22 17:42:50 2010 - Improve docs 0.001_01 Sat Feb 20 15:49:59 2010 - first dev release 0.001 Fri Feb 19 10:45:19 2010 - original version; created by Module::Setup MouseX-NativeTraits-1.09/example/0000755€(NñY€ZÃ);0000000000012054627374021313 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/example/complex_tc.pl0000644€(NñY€ZÃ);0000000105012054627122023770 0ustar fuji.goroDENA\Domain Users#!perl -w use strict; { package Foo; use Any::Moose; use Any::Moose '::Util::TypeConstraints'; subtype 'ArrayRef3', as 'ArrayRef', where { @{$_} <= 3 }; has 'a3' => ( is => 'rw', isa => 'ArrayRef3', traits => ['Array'], handles => { push => 'push', }, default => sub { [] }, ); no Any::Moose '::Util::TypeConstraints'; no Any::Moose; } my $foo = Foo->new; eval { $foo->push($_) for 10 .. 20; 1; } or warn $@; print $foo->dump; MouseX-NativeTraits-1.09/inc/0000755€(NñY€ZÃ);0000000000012054627374020431 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/inc/Module/0000755€(NñY€ZÃ);0000000000012054627374021656 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/inc/Module/Install/0000755€(NñY€ZÃ);0000000000012054627374023264 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/inc/Module/Install/AuthorTests.pm0000644€(NñY€ZÃ);0000000221512054627374026107 0ustar fuji.goroDENA\Domain Users#line 1 package Module::Install::AuthorTests; use 5.005; use strict; use Module::Install::Base; use Carp (); #line 16 use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.002'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } #line 42 sub author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 0); } #line 56 sub recursive_author_tests { my ($self, @dirs) = @_; _add_author_tests($self, \@dirs, 1); } sub _wanted { my $href = shift; sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 } } sub _add_author_tests { my ($self, $dirs, $recurse) = @_; return unless $Module::Install::AUTHOR; my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t'; # XXX: pick a default, later -- rjbs, 2008-02-24 my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests"; @dirs = grep { -d } @dirs; if ($recurse) { require File::Find; my %test_dir; File::Find::find(_wanted(\%test_dir), @dirs); $self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir ); } else { $self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs ); } } #line 107 1; MouseX-NativeTraits-1.09/inc/Module/Install/Base.pm0000644€(NñY€ZÃ);0000000214712054627374024500 0ustar fuji.goroDENA\Domain Users#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 MouseX-NativeTraits-1.09/inc/Module/Install/Makefile.pm0000644€(NñY€ZÃ);0000002743712054627374025354 0ustar fuji.goroDENA\Domain Users#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 MouseX-NativeTraits-1.09/inc/Module/Install/Metadata.pm0000644€(NñY€ZÃ);0000004327712054627374025357 0ustar fuji.goroDENA\Domain Users#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; MouseX-NativeTraits-1.09/inc/Module/Install/Repository.pm0000644€(NñY€ZÃ);0000000425612054627374026010 0ustar fuji.goroDENA\Domain Users#line 1 package Module::Install::Repository; use strict; use 5.005; use vars qw($VERSION); $VERSION = '0.06'; use base qw(Module::Install::Base); sub _execute { my ($command) = @_; `$command`; } sub auto_set_repository { my $self = shift; return unless $Module::Install::AUTHOR; my $repo = _find_repo(\&_execute); if ($repo) { $self->repository($repo); } else { warn "Cannot determine repository URL\n"; } } sub _find_repo { my ($execute) = @_; if (-e ".git") { # TODO support remote besides 'origin'? if ($execute->('git remote show -n origin') =~ /URL: (.*)$/m) { # XXX Make it public clone URL, but this only works with github my $git_url = $1; $git_url =~ s![\w\-]+\@([^:]+):!git://$1/!; return $git_url; } elsif ($execute->('git svn info') =~ /URL: (.*)$/m) { return $1; } } elsif (-e ".svn") { if (`svn info` =~ /URL: (.*)$/m) { return $1; } } elsif (-e "_darcs") { # defaultrepo is better, but that is more likely to be ssh, not http if (my $query_repo = `darcs query repo`) { if ($query_repo =~ m!Default Remote: (http://.+)!) { return $1; } } open my $handle, '<', '_darcs/prefs/repos' or return; while (<$handle>) { chomp; return $_ if m!^http://!; } } elsif (-e ".hg") { if ($execute->('hg paths') =~ /default = (.*)$/m) { my $mercurial_url = $1; $mercurial_url =~ s!^ssh://hg\@(bitbucket\.org/)!https://$1!; return $mercurial_url; } } elsif (-e "$ENV{HOME}/.svk") { # Is there an explicit way to check if it's an svk checkout? my $svk_info = `svk info` or return; SVK_INFO: { if ($svk_info =~ /Mirrored From: (.*), Rev\./) { return $1; } if ($svk_info =~ m!Merged From: (/mirror/.*), Rev\.!) { $svk_info = `svk info /$1` or return; redo SVK_INFO; } } return; } } 1; __END__ =encoding utf-8 #line 128 MouseX-NativeTraits-1.09/inc/Module/Install/TestTarget.pm0000644€(NñY€ZÃ);0000001037112054627374025712 0ustar fuji.goroDENA\Domain Users#line 1 package Module::Install::TestTarget; use 5.006_002; use strict; #use warnings; # XXX: warnings.pm produces a lot of 'redefine' warnings! our $VERSION = '0.19'; use base qw(Module::Install::Base); use Config; use Carp qw(croak); our($ORIG_TEST_VIA_HARNESS); our $TEST_DYNAMIC = { env => '', includes => '', load_modules => '', insert_on_prepare => '', insert_on_finalize => '', run_on_prepare => '', run_on_finalize => '', }; # override the default `make test` sub default_test_target { my ($self, %args) = @_; my %test = _build_command_parts(%args); $TEST_DYNAMIC = \%test; } # create a new test target sub test_target { my ($self, $target, %args) = @_; croak 'target must be spesiced at test_target()' unless $target; my $alias = "\n"; if($args{alias}) { $alias .= qq{$args{alias} :: $target\n\n}; } if($Module::Install::AUTHOR && $args{alias_for_author}) { $alias .= qq{$args{alias_for_author} :: $target\n\n}; } my $test = _assemble(_build_command_parts(%args)); $self->postamble( $alias . qq{$target :: pure_all\n} . qq{\t} . $test ); } sub _build_command_parts { my %args = @_; #XXX: _build_command_parts() will be called first, so we put it here unless(defined $ORIG_TEST_VIA_HARNESS) { $ORIG_TEST_VIA_HARNESS = MY->can('test_via_harness'); no warnings 'redefine'; *MY::test_via_harness = \&_test_via_harness; } for my $key (qw/includes load_modules run_on_prepare run_on_finalize insert_on_prepare insert_on_finalize tests/) { $args{$key} ||= []; $args{$key} = [$args{$key}] unless ref $args{$key} eq 'ARRAY'; } $args{env} ||= {}; my %test; $test{includes} = @{$args{includes}} ? join '', map { qq|"-I$_" | } @{$args{includes}} : ''; $test{load_modules} = @{$args{load_modules}} ? join '', map { qq|"-M$_" | } @{$args{load_modules}} : ''; $test{tests} = @{$args{tests}} ? join '', map { qq|"$_" | } @{$args{tests}} : '$(TEST_FILES)'; for my $key (qw/run_on_prepare run_on_finalize/) { $test{$key} = @{$args{$key}} ? join '', map { qq|do { local \$@; do '$_'; die \$@ if \$@ }; | } @{$args{$key}} : ''; $test{$key} = _quote($test{$key}); } for my $key (qw/insert_on_prepare insert_on_finalize/) { my $codes = join '', map { _build_funcall($_) } @{$args{$key}}; $test{$key} = _quote($codes); } $test{env} = %{$args{env}} ? _quote(join '', map { my $key = _env_quote($_); my $val = _env_quote($args{env}->{$_}); sprintf "\$ENV{q{%s}} = q{%s}; ", $key, $val } keys %{$args{env}}) : ''; return %test; } my $bd; sub _build_funcall { my($code) = @_; if(ref $code eq 'CODE') { $bd ||= do { require B::Deparse; B::Deparse->new() }; $code = $bd->coderef2text($code); } return qq|sub { $code }->(); |; } sub _quote { my $code = shift; $code =~ s/\$/\\\$\$/g; $code =~ s/"/\\"/g; $code =~ s/\n/ /g; if ($^O eq 'MSWin32') { $code =~ s/\\\$\$/\$\$/g; if ($Config{make} =~ /dmake/i) { $code =~ s/{/{{/g; $code =~ s/}/}}/g; } } return $code; } sub _env_quote { my $val = shift; $val =~ s/}/\\}/g; return $val; } sub _assemble { my %args = @_; my $command = MY->$ORIG_TEST_VIA_HARNESS($args{perl} || '$(FULLPERLRUN)', $args{tests}); # inject includes and modules before the first switch $command =~ s/("- \S+? ")/$args{includes}$args{load_modules}$1/xms; # inject snipetts in the one-liner $command =~ s{ ( "-e" \s+ ") # start the one liner ( (?: [^"] | \\ . )+ ) # body of the one liner ( " ) # end the one liner }{ join '', $1, $args{env}, $args{run_on_prepare}, $args{insert_on_prepare}, "$2; ", $args{run_on_finalize}, $args{insert_on_finalize}, $3, }xmse; return $command; } sub _test_via_harness { my($self, $perl, $tests) = @_; $TEST_DYNAMIC->{perl} = $perl; $TEST_DYNAMIC->{tests} ||= $tests; return _assemble(%$TEST_DYNAMIC); } 1; __END__ #line 393 MouseX-NativeTraits-1.09/inc/Module/Install/WriteAll.pm0000644€(NñY€ZÃ);0000000237612054627374025355 0ustar fuji.goroDENA\Domain Users#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; MouseX-NativeTraits-1.09/inc/Module/Install.pm0000644€(NñY€ZÃ);0000003013512054627374023624 0ustar fuji.goroDENA\Domain Users#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. MouseX-NativeTraits-1.09/lib/0000755€(NñY€ZÃ);0000000000012054627374020426 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/lib/Mouse/0000755€(NñY€ZÃ);0000000000012054627374021516 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/lib/Mouse/Meta/0000755€(NñY€ZÃ);0000000000012054627374022404 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/lib/Mouse/Meta/Attribute/0000755€(NñY€ZÃ);0000000000012054627374024347 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/lib/Mouse/Meta/Attribute/Custom/0000755€(NñY€ZÃ);0000000000012054627374025621 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/lib/Mouse/Meta/Attribute/Custom/Trait/0000755€(NñY€ZÃ);0000000000012054627374026704 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/lib/Mouse/Meta/Attribute/Custom/Trait/Array.pm0000644€(NñY€ZÃ);0000000067612054627122030320 0ustar fuji.goroDENA\Domain Userspackage Mouse::Meta::Attribute::Custom::Trait::Array; use strict; sub register_implementation { 'MouseX::NativeTraits::ArrayRef' } 1; __END__ =head1 NAME Mouse::Meta::Attribute::Custom::Trait::Array - Shortcut for ArrayRef trait =head1 DESCRIPTION This module is an alias to MouseX::NativeTraits::ArrayRef, which allows you to refer the trait as C. =head1 SEE ALSO L L =cut MouseX-NativeTraits-1.09/lib/Mouse/Meta/Attribute/Custom/Trait/Bool.pm0000644€(NñY€ZÃ);0000000065612054627122030133 0ustar fuji.goroDENA\Domain Userspackage Mouse::Meta::Attribute::Custom::Trait::Bool; use strict; sub register_implementation { 'MouseX::NativeTraits::Bool' } 1; __END__ =head1 NAME Mouse::Meta::Attribute::Custom::Trait::Bool - Shortcut for Bool trait =head1 DESCRIPTION This module is an alias to MouseX::NativeTraits::Bool, which allows you to refer the trait as C. =head1 SEE ALSO L L =cut MouseX-NativeTraits-1.09/lib/Mouse/Meta/Attribute/Custom/Trait/Code.pm0000644€(NñY€ZÃ);0000000066712054627122030114 0ustar fuji.goroDENA\Domain Userspackage Mouse::Meta::Attribute::Custom::Trait::Code; use strict; sub register_implementation { 'MouseX::NativeTraits::CodeRef' } 1; __END__ =head1 NAME Mouse::Meta::Attribute::Custom::Trait::Code - Shortcut for CodeRef trait =head1 DESCRIPTION This module is an alias to MouseX::NativeTraits::CodeRef, which allows you to refer the trait as C. =head1 SEE ALSO L L =cut MouseX-NativeTraits-1.09/lib/Mouse/Meta/Attribute/Custom/Trait/Counter.pm0000644€(NñY€ZÃ);0000000070012054627122030645 0ustar fuji.goroDENA\Domain Userspackage Mouse::Meta::Attribute::Custom::Trait::Counter; use strict; sub register_implementation { 'MouseX::NativeTraits::Counter' } 1; __END__ =head1 NAME Mouse::Meta::Attribute::Custom::Trait::Counter - Shortcut for Counter trait =head1 DESCRIPTION This module is an alias to MouseX::NativeTraits::Counter, which allows you to refer the trait as C. =head1 SEE ALSO L L =cut MouseX-NativeTraits-1.09/lib/Mouse/Meta/Attribute/Custom/Trait/Hash.pm0000644€(NñY€ZÃ);0000000066712054627122030125 0ustar fuji.goroDENA\Domain Userspackage Mouse::Meta::Attribute::Custom::Trait::Hash; use strict; sub register_implementation { 'MouseX::NativeTraits::HashRef' } 1; __END__ =head1 NAME Mouse::Meta::Attribute::Custom::Trait::Hash - Shortcut for HashRef trait =head1 DESCRIPTION This module is an alias to MouseX::NativeTraits::HashRef, which allows you to refer the trait as C. =head1 SEE ALSO L L =cut MouseX-NativeTraits-1.09/lib/Mouse/Meta/Attribute/Custom/Trait/Number.pm0000644€(NñY€ZÃ);0000000066612054627122030471 0ustar fuji.goroDENA\Domain Userspackage Mouse::Meta::Attribute::Custom::Trait::Number; use strict; sub register_implementation { 'MouseX::NativeTraits::Num' } 1; __END__ =head1 NAME Mouse::Meta::Attribute::Custom::Trait::Number - Shortcut for Number trait =head1 DESCRIPTION This module is an alias to MouseX::NativeTraits::Number, which allows you to refer the trait as C. =head1 SEE ALSO L L =cut MouseX-NativeTraits-1.09/lib/Mouse/Meta/Attribute/Custom/Trait/String.pm0000644€(NñY€ZÃ);0000000065512054627122030505 0ustar fuji.goroDENA\Domain Userspackage Mouse::Meta::Attribute::Custom::Trait::String; use strict; sub register_implementation { 'MouseX::NativeTraits::Str' } 1; __END__ =head1 NAME Mouse::Meta::Attribute::Custom::Trait::String - Shortcut for Str trait =head1 DESCRIPTION This module is an alias to MouseX::NativeTraits::Str, which allows you to refer the trait as C. =head1 SEE ALSO L L =cut MouseX-NativeTraits-1.09/lib/Mouse/Meta/Attribute/Native.pm0000644€(NñY€ZÃ);0000000101012054627355026122 0ustar fuji.goroDENA\Domain Userspackage Mouse::Meta::Attribute::Native; use strict; our $VERSION = '1.09'; 1; __END__ =head1 NAME Mouse::Meta::Attribute::Native - Extend your attribute interfaces =head1 SYNOPSIS # In your Makefile.PL # you can say: requires 'Mouse::Meta::Attribute::Native'; # just like as 'Moose::Meta::Attribute::Native' =head1 DESCRIPTION This module is just a hook to set C to prerequisites. =head1 SEE ALSO L L =cut MouseX-NativeTraits-1.09/lib/MouseX/0000755€(NñY€ZÃ);0000000000012054627374021646 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/lib/MouseX/NativeTraits/0000755€(NñY€ZÃ);0000000000012054627374024263 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/lib/MouseX/NativeTraits/ArrayRef.pm0000644€(NñY€ZÃ);0000001567112054627122026335 0ustar fuji.goroDENA\Domain Userspackage MouseX::NativeTraits::ArrayRef; use Mouse::Role; with 'MouseX::NativeTraits'; sub method_provider_class { return 'MouseX::NativeTraits::MethodProvider::ArrayRef'; } sub helper_type { return 'ArrayRef'; } no Mouse::Role; 1; __END__ =head1 NAME MouseX::NativeTraits::ArrayRef - Helper trait for ArrayRef attributes =head1 SYNOPSIS package Stuff; use Mouse; has 'options' => ( traits => ['Array'], is => 'ro', isa => 'ArrayRef[Str]', default => sub { [] }, handles => { all_options => 'elements', add_option => 'push', map_options => 'map', filter_options => 'grep', find_option => 'first', get_option => 'get', join_options => 'join', count_options => 'count', has_options => 'count', has_no_options => 'is_empty', sorted_options => 'sort', }, ); =head1 DESCRIPTION This module provides an Array attribute which provides a number of array operations. =head1 PROVIDED METHODS These methods are implemented in L. =over 4 =item B Returns the number of elements in the array. $stuff = Stuff->new; $stuff->options(["foo", "bar", "baz", "boo"]); my $count = $stuff->count_options; print "$count\n"; # prints 4 =item B Returns a boolean value that is true when the array has no elements. $stuff->has_no_options ? die "No options!\n" : print "Good boy.\n"; =item B Returns all of the elements of the array. my @option = $stuff->all_options; print "@options\n"; # prints "foo bar baz boo" =item B Returns an element of the array by its index. You can also use negative index numbers, just as with Perl's core array handling. my $option = $stuff->get_option(1); print "$option\n"; # prints "bar" =item B =item B =item B =item B =item B These methods are all equivalent to the Perl core functions of the same name. =item B This method returns the first item matching item in the array, just like L's C function. The matching is done with a subroutine reference you pass to this method. The reference will be called against each element in the array until one matches or all elements have been checked. my $found = $stuff->find_option( sub { /^b/ } ); print "$found\n"; # prints "bar" =item B This method returns true if any item in the array meets the criterion given through the subroutine, otherwise returns false. It sets $_ for each item in the array. =item B This method returns every element matching a given criteria, just like Perl's core C function. This method requires a subroutine which implements the matching logic. my @found = $stuff->filter_options( sub { /^b/ } ); print "@found\n"; # prints "bar baz boo" =item B This method transforms every element in the array and returns a new array, just like Perl's core C function. This method requires a subroutine which implements the transformation. my @mod_options = $stuff->map_options( sub { $_ . "-tag" } ); print "@mod_options\n"; # prints "foo-tag bar-tag baz-tag boo-tag" =item B This method also transform every element in the array and returns a new array, just like L's C function.his is similar to C, but does not modify the element of the array. =item B This method condenses an array into a single value, by passing a function the value so far and the next value in the array, just like L's C function. The reducing is done with a subroutine reference you pass to this method. my $found = $stuff->reduce_options( sub { $_[0] . $_[1] } ); print "$found\n"; # prints "foobarbazboo" =item B Returns the array in sorted order. You can provide an optional subroutine reference to sort with (as you can with Perl's core C function). However, instead of using C<$a> and C<$b>, you will need to use C<$_[0]> and C<$_[1]> instead. # ascending ASCIIbetical my @sorted = $stuff->sort_options(); # Descending alphabetical order my @sorted_options = $stuff->sort_options( sub { lc $_[1] cmp lc $_[0] } ); print "@sorted_options\n"; # prints "foo boo baz bar" =item B Sorts the array I, modifying the value of the attribute. You can provide an optional subroutine reference to sort with (as you can with Perl's core C function). However, instead of using C<$a> and C<$b>, you will need to use C<$_[0]> and C<$_[1]> instead. =item B Returns the array in sorted order, applying I<\&by> function to each item. This is equivalent to C<< sort(sub{ by($_[0]) cmp by($_[1]) }) >>, but implemented effectively. Currently (as of Moose 0.98) this is a Mouse specific method. =item B Sorts the array, applying I<\&by> function to each item, modifying the value of the attribute. This is equivalent to C<< sort_in_place(sub{ by($_[0]) cmp by($_[1]) }) >>, but implemented effectively. Currently (as of Moose 0.98) this is a Mouse specific method. =item B Returns the array, with indices in random order, like C from L. =item B Returns the array, with all duplicate elements removed, like C from L. =item B Joins every element of the array using the separator given as argument, just like Perl's core C function. my $joined = $stuff->join_options( ':' ); print "$joined\n"; # prints "foo:bar:baz:boo" =item B Given an index and a value, sets the specified array element's value. =item B Removes the element at the given index from the array. =item B Inserts a new element into the array at the given index. =item B Empties the entire array, like C<@array = ()>. =item B This method provides a get/set accessor for the array, based on array indexes. If passed one argument, it returns the value at the specified index. If passed two arguments, it sets the value of the specified index. =item B This method calls the given subroutine with each element of the array, like Perl's core C statement. Currently (as of Moose 0.98) this is a Mouse specific method. =item B This method calls the given subroutine with each two element of the array, as if the array is a list of pairs. Currently (as of Moose 0.98) this is a Mouse specific method. =back =head1 METHODS =over 4 =item B =item B =item B =back =head1 SEE ALSO L =cut MouseX-NativeTraits-1.09/lib/MouseX/NativeTraits/Bool.pm0000644€(NñY€ZÃ);0000000307012054627122025503 0ustar fuji.goroDENA\Domain Userspackage MouseX::NativeTraits::Bool; use Mouse::Role; with 'MouseX::NativeTraits'; sub method_provider_class { return 'MouseX::NativeTraits::MethodProvider::Bool'; } sub helper_type { return 'Bool'; } 1; __END__ =head1 NAME MouseX::NativeTraits::Bool - Helper trait for Bool attributes =head1 SYNOPSIS package Room; use Mouse; has 'is_lit' => ( traits => ['Bool'], is => 'rw', isa => 'Bool', default => 0, handles => { illuminate => 'set', darken => 'unset', flip_switch => 'toggle', is_dark => 'not', }, ); my $room = Room->new(); $room->illuminate; # same as $room->is_lit(1); $room->darken; # same as $room->is_lit(0); $room->flip_switch; # same as $room->is_lit(not $room->is_lit); return $room->is_dark; # same as !$room->is_lit =head1 DESCRIPTION This provides a simple boolean attribute, which supports most of the basic math operations. =head1 PROVIDED METHODS These methods are implemented in L. It is important to note that all those methods do in place modification of the value stored in the attribute. =over 4 =item B Sets the value to true. =item B Set the value to false. =item B Toggles the value. If it's true, set to false, and vice versa. =item B Equivalent of 'not C<$value>'. =back =head1 METHODS =over 4 =item B =item B =item B =back =head1 SEE ALSO L. =cut MouseX-NativeTraits-1.09/lib/MouseX/NativeTraits/CodeRef.pm0000644€(NñY€ZÃ);0000000170212054627122026117 0ustar fuji.goroDENA\Domain Userspackage MouseX::NativeTraits::CodeRef; use Mouse::Role; with 'MouseX::NativeTraits'; sub method_provider_class { return 'MouseX::NativeTraits::MethodProvider::CodeRef'; } sub helper_type { return 'CodeRef'; } 1; __END__ =head1 NAME MouseX::NativeTraits::CodeRef - Helper trait for CodeRef attributes =head1 SYNOPSIS package Foo; use Mouse; has 'callback' => ( traits => ['Code'], is => 'ro', isa => 'CodeRef', default => sub { sub { print "called" } }, handles => { call => 'execute', }, ); my $foo = Foo->new; $foo->call; # prints "called" =head1 DESCRIPTION This provides operations on coderef attributes. =head1 PROVIDED METHODS =over 4 =item B Calls the coderef with the given args. =back =head1 METHODS =over 4 =item B =item B =item B =back =head1 SEE ALSO L =cut MouseX-NativeTraits-1.09/lib/MouseX/NativeTraits/Counter.pm0000644€(NñY€ZÃ);0000000402612054627122026231 0ustar fuji.goroDENA\Domain Userspackage MouseX::NativeTraits::Counter; use Mouse::Role; with 'MouseX::NativeTraits'; sub method_provider_class { return 'MouseX::NativeTraits::MethodProvider::Counter'; } sub helper_type { return 'Int'; } sub _default_default { 0 } no Mouse::Role; 1; __END__ =head1 NAME MouseX::NativeTraits::Counter - Helper trait for counter attributes =head1 SYNOPSIS package MyHomePage; use Mouse; has 'counter' => ( traits => ['Counter'], is => 'ro', isa => 'Num', default => 0, handles => { inc_counter => 'inc', dec_counter => 'dec', reset_counter => 'reset', }, ); my $page = MyHomePage->new(); $page->inc_counter; # same as $page->counter( $page->counter + 1 ); $page->dec_counter; # same as $page->counter( $page->counter - 1 ); =head1 DESCRIPTION This module provides a simple counter attribute, which can be incremented and decremented. If your attribute definition does not include any of I, I, I or I but does use the C trait, then this module applies defaults as in the L above. This allows for a very basic counter definition: has 'foo' => (traits => ['Counter']); $obj->inc_foo; =head1 PROVIDED METHODS These methods are implemented in L. It is important to note that all those methods do in place modification of the value stored in the attribute. =over 4 =item B Set the counter to the specified value. =item B Increments the value stored in this slot by 1. Providing an argument will cause the counter to be increased by specified amount. =item B Decrements the value stored in this slot by 1. Providing an argument will cause the counter to be increased by specified amount. =item B Resets the value stored in this slot to it's default value. =back =head1 METHODS =over 4 =item B =item B =item B =back =head1 SEE ALSO L =cut MouseX-NativeTraits-1.09/lib/MouseX/NativeTraits/HashRef.pm0000644€(NñY€ZÃ);0000000501612054627122026132 0ustar fuji.goroDENA\Domain Userspackage MouseX::NativeTraits::HashRef; use Mouse::Role; with 'MouseX::NativeTraits'; sub method_provider_class { return 'MouseX::NativeTraits::MethodProvider::HashRef'; } sub helper_type { return 'HashRef'; } no Mouse::Role; 1; __END__ =head1 NAME MouseX::NativeTraits::HashRef - Helper trait for HashRef attributes =head1 SYNOPSIS package Stuff; use Mouse; has 'options' => ( traits => ['Hash'], is => 'ro', isa => 'HashRef[Str]', default => sub { {} }, handles => { set_option => 'set', get_option => 'get', has_no_options => 'is_empty', num_options => 'count', delete_option => 'delete', pairs => 'kv', }, ); =head1 DESCRIPTION This module provides a Hash attribute which provides a number of hash-like operations. =head1 PROVIDED METHODS These methods are implemented in L. =over 4 =item B Returns values from the hash. In list context return a list of values in the hash for the given keys. In scalar context returns the value for the last key specified. =item B $value, $key2 =E $value2...)> Sets the elements in the hash to the given values. =item B Removes the elements with the given keys. =item B Returns true if the given key is present in the hash. =item B Returns true if the value of a given key is defined. =item B Returns the list of keys in the hash. =item B Returns the list of sorted keys in the hash. =item B Returns the list of values in the hash. =item B Returns the key/value pairs in the hash as an array of array references. for my $pair ( $object->options->pairs ) { print "$pair->[0] = $pair->[1]\n"; } =item B Returns the key/value pairs in the hash as a flattened list. =item B Resets the hash to an empty value, like C<%hash = ()>. =item B Returns the number of elements in the hash. Also useful for not empty: C<< has_options => 'count' >>. =item B If the hash is populated, returns false. Otherwise, returns true. =item B If passed one argument, returns the value of the specified key. If passed two arguments, sets the value of the specified key. =back =head1 METHODS =over 4 =item B =item B =item B =back =head1 SEE ALSO L =cut MouseX-NativeTraits-1.09/lib/MouseX/NativeTraits/MethodProvider/0000755€(NñY€ZÃ);0000000000012054627374027216 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/lib/MouseX/NativeTraits/MethodProvider/ArrayRef.pm0000644€(NñY€ZÃ);0000003677412054627122031277 0ustar fuji.goroDENA\Domain Userspackage MouseX::NativeTraits::MethodProvider::ArrayRef; use Mouse; use Mouse::Util::TypeConstraints (); use List::Util (); extends qw(MouseX::NativeTraits::MethodProvider); sub generate_count { my($self) = @_; my $reader = $self->reader; return sub { if(@_ != 1) { $self->argument_error('count', 1, 1, scalar @_); } return scalar @{ $reader->( $_[0] ) }; }; } sub generate_is_empty { my($self) = @_; my $reader = $self->reader; return sub { if(@_ != 1) { $self->argument_error('is_empty', 1, 1, scalar @_); } return scalar(@{ $reader->( $_[0] ) }) == 0; }; } sub generate_first { my($self) = @_; my $reader = $self->reader; return sub { my ( $instance, $block ) = @_; if(@_ != 2) { $self->argument_error('first', 2, 2, scalar @_); } Mouse::Util::TypeConstraints::CodeRef($block) or $instance->meta->throw_error( "The argument passed to first must be a code reference"); return List::Util::first(\&{$block}, @{ $reader->($instance) }); }; } sub generate_any { my($self) = @_; my $reader = $self->reader; return sub { my ( $instance, $block ) = @_; if(@_ != 2) { $self->argument_error('any', 2, 2, scalar @_); } Mouse::Util::TypeConstraints::CodeRef($block) or $instance->meta->throw_error( "The argument passed to any must be a code reference"); foreach (@{ $reader->($instance) }){ if($block->($_)){ return 1; } } return 0; }; } sub generate_apply { my($self) = @_; my $reader = $self->reader; return sub { my ( $instance, $block ) = @_; if(@_ != 2) { $self->argument_error('apply', 2, 2, scalar @_); } Mouse::Util::TypeConstraints::CodeRef($block) or $instance->meta->throw_error( "The argument passed to apply must be a code reference"); my @values = @{ $reader->($instance) }; foreach (@values){ $block->(); } return @values; }; } sub generate_map { my($self) = @_; my $reader = $self->reader; return sub { my ( $instance, $block ) = @_; if(@_ != 2) { $self->argument_error('map', 2, 2, scalar @_); } Mouse::Util::TypeConstraints::CodeRef($block) or $instance->meta->throw_error( "The argument passed to map must be a code reference"); return map { $block->() } @{ $reader->($instance) }; }; } sub generate_reduce { my($self) = @_; my $reader = $self->reader; return sub { my ( $instance, $block ) = @_; if(@_ != 2) { $self->argument_error('reduce', 2, 2, scalar @_); } Mouse::Util::TypeConstraints::CodeRef($block) or $instance->meta->throw_error( "The argument passed to reduce must be a code reference"); our ($a, $b); return List::Util::reduce { $block->($a, $b) } @{ $reader->($instance) }; }; } sub generate_sort { my($self) = @_; my $reader = $self->reader; return sub { my ( $instance, $block ) = @_; if(@_ < 1 or @_ > 2) { $self->argument_error('sort', 1, 2, scalar @_); } if (defined $block) { Mouse::Util::TypeConstraints::CodeRef($block) or $instance->meta->throw_error( "The argument passed to sort must be a code reference"); return sort { $block->( $a, $b ) } @{ $reader->($instance) }; } else { return sort @{ $reader->($instance) }; } }; } sub generate_sort_in_place { my($self) = @_; my $reader = $self->reader; return sub { my ( $instance, $block ) = @_; if(@_ < 1 or @_ > 2) { $self->argument_error('sort_in_place', 1, 2, scalar @_); } my $array_ref = $reader->($instance); if(defined $block){ Mouse::Util::TypeConstraints::CodeRef($block) or $instance->meta->throw_error( "The argument passed to sort_in_place must be a code reference"); @{$array_ref} = sort { $block->($a, $b) } @{$array_ref}; } else{ @{$array_ref} = sort @{$array_ref}; } return $instance; }; } # The sort_by algorithm comes from perlfunc/sort # See also perldoc -f sort and perldoc -q sort sub generate_sort_by { my($self) = @_; my $reader = $self->reader; return sub { my ( $instance, $block, $compare ) = @_; if(@_ < 1 or @_ > 3) { $self->argument_error('sort_by', 1, 3, scalar @_); } my $array_ref = $reader->($instance); my @idx; foreach (@{$array_ref}){ # intentinal use of $_ push @idx, scalar $block->($_); } # NOTE: scalar(@idx)-1 is faster than $#idx if($compare){ return @{ $array_ref }[ sort { $compare->($idx[$a], $idx[$b]) } 0 .. scalar(@idx)-1 ]; } else{ return @{ $array_ref }[ sort { $idx[$a] cmp $idx[$b] } 0 .. scalar(@idx)-1 ]; } }; } sub generate_sort_in_place_by { my($self) = @_; my $reader = $self->reader; return sub { my ( $instance, $block, $compare ) = @_; if(@_ < 1 or @_ > 3) { $self->argument_error('sort_by', 1, 3, scalar @_); } my $array_ref = $reader->($instance); my @idx; foreach (@{$array_ref}){ push @idx, scalar $block->($_); } if($compare){ @{ $array_ref } = @{ $array_ref }[ sort { $compare->($idx[$a], $idx[$b]) } 0 .. scalar(@idx)-1 ]; } else{ @{ $array_ref } = @{ $array_ref }[ sort { $idx[$a] cmp $idx[$b] } 0 .. scalar(@idx)-1 ]; } return $instance; }; } sub generate_shuffle { my($self) = @_; my $reader = $self->reader; return sub { my ( $instance ) = @_; if(@_ != 1) { $self->argument_error('shuffle', 1, 1, scalar @_); } return List::Util::shuffle @{ $reader->($instance) }; }; } sub generate_grep { my($self) = @_; my $reader = $self->reader; return sub { my ( $instance, $block ) = @_; if(@_ != 2) { $self->argument_error('grep', 2, 2, scalar @_); } Mouse::Util::TypeConstraints::CodeRef($block) or $instance->meta->throw_error( "The argument passed to grep must be a code reference"); return grep { $block->() } @{ $reader->($instance) }; }; } sub generate_uniq { my($self) = @_; my $reader = $self->reader; return sub { my ( $instance ) = @_; if(@_ != 1) { $self->argument_error('uniq', 1, 1, scalar @_); } my %seen; my $seen_undef; return grep{ ( defined($_) ? ++$seen{$_} : ++$seen_undef ) == 1 } @{ $reader->($instance) }; }; } sub generate_elements { my($self) = @_; my $reader = $self->reader; return sub { my ($instance) = @_; if(@_ != 1) { $self->argument_error('elements', 1, 1, scalar @_); } return @{ $reader->($instance) }; }; } sub generate_join { my($self) = @_; my $reader = $self->reader; return sub { my ( $instance, $separator ) = @_; if(@_ != 2) { $self->argument_error('join', 2, 2, scalar @_); } Mouse::Util::TypeConstraints::Str($separator) or $instance->meta->throw_error( "The argument passed to join must be a string"); return join $separator, @{ $reader->($instance) }; }; } sub generate_push { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; return sub { my($instance, @values) = @_; my @new_values = @{ $reader->($instance) }; push @new_values, @values; $writer->($instance, \@new_values); # commit return scalar @new_values; }; } sub generate_pop { my($self) = @_; my $reader = $self->reader; return sub { if(@_ != 1) { $self->argument_error('pop', 1, 1, scalar @_); } return pop @{ $reader->( $_[0] ) }; }; } sub generate_unshift { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; return sub { my($instance, @values) = @_; my @new_values = @{ $reader->($instance) }; unshift @new_values, @values; $writer->($instance, \@new_values); # commit return scalar @new_values; }; } sub generate_shift { my($self) = @_; my $reader = $self->reader; return sub { if(@_ != 1) { $self->argument_error('shift', 1, 1, scalar @_); } return shift @{ $reader->( $_[0] ) }; }; } __PACKAGE__->meta->add_method(generate_get => \&generate_fetch); # alias sub generate_fetch { my($self, $handle_name) = @_; my $reader = $self->reader; return sub { my($instance, $idx) = @_; if(@_ != 2) { $self->argument_error('get', 2, 2, scalar @_); } Mouse::Util::TypeConstraints::Int($idx) or $instance->meta->throw_error( "The index passed to get must be an integer"); return $reader->( $instance )->[ $idx ]; }; } __PACKAGE__->meta->add_method(generate_set => \&generate_store); # alias sub generate_store { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; return sub { my($instance, $idx, $value) = @_; if(@_ != 3) { $self->argument_error('set', 3, 3, scalar @_); } Mouse::Util::TypeConstraints::Int($idx) or $instance->meta->throw_error( "The index argument passed to set must be an integer"); my @new_values = @{ $reader->($instance) }; $new_values[$idx] = $value; $writer->($instance, \@new_values); # commit return $value; }; } sub generate_accessor { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; return sub { my($instance, $idx, $value) = @_; if ( @_ == 2 ) { # reader Mouse::Util::TypeConstraints::Int($idx) or $instance->meta->throw_error( "The index argument passed to accessor must be an integer"); return $reader->($instance)->[ $idx ]; } elsif ( @_ == 3) { # writer Mouse::Util::TypeConstraints::Int($idx) or $instance->meta->throw_error( "The index argument passed to accessor must be an integer"); my @new_values = @{ $reader->($instance) }; $new_values[$idx] = $value; $writer->($instance, \@new_values); # commit return $value; } else { $self->argument_error('accessor', 2, 3, scalar @_); } }; } sub generate_clear { my($self) = @_; my $reader = $self->reader; return sub { my($instance) = @_; if(@_ != 1) { $self->argument_error('clear', 1, 1, scalar @_); } @{ $reader->( $instance ) } = (); return $instance; }; } __PACKAGE__->meta->add_method(generate_delete => \&generate_remove); # alias sub generate_remove { my($self) = @_; my $reader = $self->reader; return sub { my($instance, $idx) = @_; if(@_ != 2) { $self->argument_error('delete', 2, 2, scalar @_); } Mouse::Util::TypeConstraints::Int($idx) or $instance->meta->throw_error( "The index argument passed to delete must be an integer"); return splice @{ $reader->( $instance ) }, $idx, 1; }; } sub generate_insert { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; return sub { my($instance, $idx, $value) = @_; if(@_ != 3) { $self->argument_error('insert', 3, 3, scalar @_); } Mouse::Util::TypeConstraints::Int($idx) or $instance->meta->throw_error( "The index argument passed to insert must be an integer"); my @new_values = @{ $reader->($instance) }; splice @new_values, $idx, 0, $value; $writer->($instance, \@new_values); # commit return $instance; }; } sub generate_splice { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; return sub { my ( $instance, $idx, $len, @elems ) = @_; if(@_ < 2) { $self->argument_error('splice', 2, undef, scalar @_); } Mouse::Util::TypeConstraints::Int($idx) or $instance->meta->throw_error( "The index argument passed to splice must be an integer"); if(defined $len) { Mouse::Util::TypeConstraints::Int($len) or $instance->meta->throw_error( "The length argument passed to splice must be an integer"); } my @new_values = @{ $reader->($instance) }; my @ret_values = defined($len) ? splice @new_values, $idx, $len, @elems : splice @new_values, $idx; $writer->($instance, \@new_values); # commit return wantarray ? @ret_values : $ret_values[-1]; }; } sub generate_for_each { my($self) = @_; my $reader = $self->reader; return sub { my ( $instance, $block ) = @_; foreach my $element(@{ $reader->instance($instance) }){ $block->($element); } return $instance; }; } sub generate_for_each_pair { my($self) = @_; my $reader = $self->reader; return sub { my ( $instance, $block ) = @_; my $array_ref = $reader->($instance); for(my $i = 0; $i < @{$array_ref}; $i += 2){ $block->($array_ref->[$i], $array_ref->[$i + 1]); } return $instance; }; } no Mouse; __PACKAGE__->meta->make_immutable(); __END__ =head1 NAME MouseX::NativeTraits::MethodProvider::ArrayRef - Provides methods for ArrayRef =head1 DESCRIPTION This class provides method generators for the C trait. See L for details. =head1 METHOD GENERATORS =over 4 =item generate_count =item generate_is_empty =item generate_first =item generate_any =item generate_apply =item generate_map =item generate_reduce =item generate_sort =item generate_sort_in_place =item generate_sort_by =item generate_sort_in_place_by =item generate_shuffle =item generate_grep =item generate_uniq =item generate_elements =item generate_join =item generate_push =item generate_pop =item generate_unshift =item generate_shift =item generate_fetch =item generate_get The same as C =item generate_store =item generate_set The same as C =item generate_accessor =item generate_clear =item generate_remove =item generate_delete The same as C. Note that it is different from C. =item generate_insert =item generate_splice =item generate_for_each =item generate_for_each_pair =back =head1 SEE ALSO L =cut MouseX-NativeTraits-1.09/lib/MouseX/NativeTraits/MethodProvider/Bool.pm0000644€(NñY€ZÃ);0000000276412054627122030447 0ustar fuji.goroDENA\Domain Userspackage MouseX::NativeTraits::MethodProvider::Bool; use Mouse; extends qw(MouseX::NativeTraits::MethodProvider); sub generate_set { my($self) = @_; my $writer = $self->writer; return sub { if(@_ != 1) { $self->argument_error('set', 1, 1, scalar @_); } $writer->( $_[0], 1 ); }; } sub generate_unset { my($self) = @_; my $writer = $self->writer; return sub { if(@_ != 1) { $self->argument_error('unset', 1, 1, scalar @_); } $writer->( $_[0], 0 ); }; } sub generate_toggle { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; return sub { if(@_ != 1) { $self->argument_error('toggle', 1, 1, scalar @_); } $writer->( $_[0], !$reader->( $_[0] ) ); }; } sub generate_not { my($self) = @_; my $reader = $self->reader; return sub { if(@_ != 1) { $self->argument_error('not', 1, 1, scalar @_); } !$reader->( $_[0] ); }; } no Mouse; __PACKAGE__->meta->make_immutable(); __END__ =head1 NAME MouseX::NativeTraits::MethodProvider::Bool - Provides methods for Bool =head1 DESCRIPTION This class provides method generators for the C trait. See L for details. =head1 METHOD GENERATORS =over 4 =item generate_set =item generate_unset =item generate_toggle =item generate_not =back =head1 SEE ALSO L =cut MouseX-NativeTraits-1.09/lib/MouseX/NativeTraits/MethodProvider/CodeRef.pm0000644€(NñY€ZÃ);0000000164412054627122031057 0ustar fuji.goroDENA\Domain Userspackage MouseX::NativeTraits::MethodProvider::CodeRef; use Mouse; extends qw(MouseX::NativeTraits::MethodProvider); sub generate_execute { my($self) = @_; my $reader = $self->reader; return sub { my ($instance, @args) = @_; $reader->($instance)->(@args); }; } sub generate_execute_method { my($self) = @_; my $reader = $self->reader; return sub { my ($instance, @args) = @_; $reader->($instance)->($instance, @args); }; } no Mouse; __PACKAGE__->meta->make_immutable(); __END__ =head1 NAME MouseX::NativeTraits::MethodProvider::CodeRef - Provides methods for CodeRef =head1 DESCRIPTION This class provides method generators for the C trait. See L for details. =head1 METHOD GENERATORS =over 4 =item generate_execute =item generate_execute_method =back =head1 SEE ALSO L =cut MouseX-NativeTraits-1.09/lib/MouseX/NativeTraits/MethodProvider/Counter.pm0000644€(NñY€ZÃ);0000000555312054627122031172 0ustar fuji.goroDENA\Domain Userspackage MouseX::NativeTraits::MethodProvider::Counter; use Mouse; extends qw(MouseX::NativeTraits::MethodProvider); sub generate_reset { my($self) = @_; my $attr = $self->attr; my $writer = $self->writer; my $builder; my $default; if($attr->has_builder){ $builder = $attr->builder; } else { $default = $attr->default; if(ref $default){ $builder = $default; } } if(ref $builder){ return sub { my($instance) = @_; if(@_ != 1) { $self->argument_error('reset', 1, 1, scalar @_); } $writer->($instance, $instance->$builder()); }; } else{ return sub { my($instance) = @_; if(@_ != 1) { $self->argument_error('reset', 1, 1, scalar @_); } $writer->($instance, $default); }; } } sub generate_set{ my($self) = @_; my $writer = $self->writer; return sub { if(@_ != 2) { $self->argument_error('set', 2, 2, scalar @_); } $writer->( $_[0], $_[1] ) }; } sub generate_inc { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; my $constraint = $self->attr->type_constraint; my $name = $self->attr->name; my $optimized_inc = ( $constraint->name eq 'Int' && !$self->attr->trigger ); return sub { my($instance, $value) = @_; if(@_ == 1){ if($optimized_inc) { return ++$instance->{$name}; } else { $value = 1; } } elsif(@_ == 2){ $constraint->assert_valid($value); } else { $self->argument_error('inc', 1, 2, scalar @_); } $instance->$writer($instance->$reader() + $value); }; } sub generate_dec { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; my $constraint = $self->attr->type_constraint; return sub { my($instance, $value) = @_; if(@_ == 1){ $value = 1; } elsif(@_ == 2){ $constraint->assert_valid($value); } else { $self->argument_error('dec', 1, 2, scalar @_); } $writer->($instance, $reader->($instance) - $value); }; } no Mouse; __PACKAGE__->meta->make_immutable(); __END__ =head1 NAME MouseX::NativeTraits::MethodProvider::Counter - Provides methods for Counter =head1 DESCRIPTION This class provides method generators for the C trait. See L for details. =head1 METHOD GENERATORS =over 4 =item generate_reset =item generate_set =item generate_inc =item generate_dec =back =head1 SEE ALSO L =cut MouseX-NativeTraits-1.09/lib/MouseX/NativeTraits/MethodProvider/HashRef.pm0000644€(NñY€ZÃ);0000002115012054627122031062 0ustar fuji.goroDENA\Domain Userspackage MouseX::NativeTraits::MethodProvider::HashRef; use Mouse; extends qw(MouseX::NativeTraits::MethodProvider); sub generate_keys { my($self) = @_; my $reader = $self->reader; return sub { if(@_ != 1) { $self->argument_error('keys', 1, 1, scalar @_); } return keys %{ $reader->( $_[0] ) }; }; } sub generate_sorted_keys { my($self) = @_; my $reader = $self->reader; return sub { if(@_ != 1) { $self->argument_error('sorted_keys', 1, 1, scalar @_); } return sort keys %{ $reader->( $_[0] ) }; }; } sub generate_values { my($self) = @_; my $reader = $self->reader; return sub { if(@_ != 1) { $self->argument_error('values', 1, 1, scalar @_); } return values %{ $reader->( $_[0] ) }; }; } sub generate_kv { my($self) = @_; my $reader = $self->reader; return sub { if(@_ != 1) { $self->argument_error('kv', 1, 1, scalar @_); } my $hash_ref = $reader->( $_[0] ); return map { [ $_ => $hash_ref->{$_} ] } keys %{ $hash_ref }; }; } sub generate_elements { my($self) = @_; my $reader = $self->reader; return sub { if(@_ != 1) { $self->argument_error('elements', 1, 1, scalar @_); } return %{ $reader->( $_[0] ) }; }; } sub generate_count { my($self) = @_; my $reader = $self->reader; return sub { if(@_ != 1) { $self->argument_error('count', 1, 1, scalar @_); } return scalar keys %{ $reader->( $_[0] ) }; }; } sub generate_is_empty { my($self) = @_; my $reader = $self->reader; return sub { if(@_ != 1) { $self->argument_error('is_empty', 1, 1, scalar @_); } return scalar(keys %{ $reader->( $_[0] ) }) == 0; }; } sub generate_exists { my($self) = @_; my $reader = $self->reader; return sub { my($instance, $key) = @_; if(@_ != 2) { $self->argument_error('exists', 2, 2, scalar @_); } defined($key) or $self->meta->throw_error( "Hash keys passed to exists must be defined" ); return exists $reader->( $instance )->{ $key }; } } sub generate_defined { my($self) = @_; my $reader = $self->reader; return sub { my($instance, $key) = @_; if(@_ != 2) { $self->argument_error('defined', 2, 2, scalar @_); } defined($key) or $self->meta->throw_error( "Hash keys passed to defined must be defined" ); return defined $reader->( $instance )->{ $key }; } } __PACKAGE__->meta->add_method(generate_get => \&generate_fetch); sub generate_fetch { my($self) = @_; my $reader = $self->reader; return sub { if(@_ < 2) { $self->argument_error('get', 2, undef, scalar @_); } my $instance = shift; foreach my $key(@_) { defined($key) or $self->meta->throw_error( "Hash keys passed to get must be defined" ); } if ( @_ == 1 ) { return $reader->( $instance )->{ $_[0] }; } else { return @{ $reader->($instance) }{@_}; } }; } __PACKAGE__->meta->add_method(generate_set => \&generate_store); sub generate_store { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; my $constraint = $self->attr->type_constraint; my $trigger = $self->attr->trigger; return sub { my ( $instance, @kv ) = @_; if(@_ < 2) { $self->argument_error('set', 2, undef, scalar @_); } my $hash_ref = $reader->($instance); my %new_value = %{ $hash_ref }; # make a working copy my @ret_value; while (my ($key, $value) = splice @kv, 0, 2 ) { defined($key) or $self->meta->throw_error( "Hash keys passed to set must be defined" ); push @ret_value, $new_value{$key} = $value; # change } $constraint->assert_valid(\%new_value) if defined $constraint; %{ $hash_ref } = %new_value; # commit $trigger->($instance) if defined $trigger; return wantarray ? @ret_value : $ret_value[-1]; }; } sub generate_accessor { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; my $constraint = $self->attr->type_constraint; my $trigger = $self->attr->trigger; return sub { my($instance, $key, $value) = @_;; if ( @_ == 2 ) { # reader defined($key) or $self->meta->throw_error( "Hash keys passed to accessor must be defined" ); return $reader->($instance)->{ $key }; } elsif ( @_ == 3 ) { # writer defined($key) or $self->meta->throw_error( "Hash keys passed to accessor must be defined" ); my $hash_ref = $reader->($instance); my %new_value = %{ $hash_ref }; $new_value{$key} = $value; $constraint->assert_valid(\%new_value) if defined $constraint; %{ $hash_ref } = %new_value; $trigger->($instance) if defined $trigger; } else { $self->argument_error('accessor', 2, 3, scalar @_); } }; } sub generate_clear { my($self) = @_; my $reader = $self->reader; return sub { if(@_ != 1) { $self->argument_error('clear', 1, 1, scalar @_); } %{ $reader->( $_[0] ) } = (); }; } sub generate_delete { my($self) = @_; my $reader = $self->reader; my $trigger = $self->attr->trigger; return sub { if(@_ < 2) { $self->argument_error('delete', 2, undef, scalar @_); } my $instance = shift; my @r = delete @{ $reader->($instance) }{@_}; $trigger->($instance) if defined $trigger; return wantarray ? @r : $r[-1]; }; } sub generate_for_each_key { my($self) = @_; my $reader = $self->reader; return sub { my($instance, $block) = @_; if(@_ != 2) { $self->argument_error('for_each_key', 2, 2, scalar @_); } Mouse::Util::TypeConstraints::CodeRef($block) or $instance->meta->throw_error( "The argument passed to for_each_key must be a code reference"); foreach (keys %{$reader->($instance)}) { # intentional use of $_ $block->($_); } return $instance; }; } sub generate_for_each_value { my($self) = @_; my $reader = $self->reader; return sub { my($instance, $block) = @_; if(@_ != 2) { $self->argument_error('for_each_value', 2, 2, scalar @_); } Mouse::Util::TypeConstraints::CodeRef($block) or $instance->meta->throw_error( "The argument passed to for_each_value must be a code reference"); foreach (values %{$reader->($instance)}) { # intentional use of $_ $block->($_); } return $instance; }; } sub generate_for_each_pair { my($self) = @_; my $reader = $self->reader; return sub { my($instance, $block) = @_; if(@_ != 2) { $self->argument_error('for_each_pair', 2, 2, scalar @_); } Mouse::Util::TypeConstraints::CodeRef($block) or $instance->meta->throw_error( "The argument passed to for_each_pair must be a code reference"); my $hash_ref = $reader->($instance); foreach my $key(keys %{$hash_ref}){ $block->($key, $hash_ref->{$key}); } return $instance; }; } no Mouse; __PACKAGE__->meta->make_immutable(); __END__ =head1 NAME MouseX::NativeTraits::MethodProvider::HashRef - Provides methods for HashRef =head1 DESCRIPTION This class provides method generators for the C trait. See L for details. =head1 METHOD GENERATORS =over 4 =item generate_keys =item generate_sorted_keys =item generate_values =item generate_kv =item generate_elements =item generate_count =item generate_is_empty =item generate_exists =item generate_defined =item generate_fetch =item generate_get The same as C. =item generate_store =item generate_set The same as C. =item generate_accessor =item generate_clear =item generate_delete =item generate_for_each_key =item generate_for_each_value =item generate_for_each_pair =back =head1 SEE ALSO L =cut MouseX-NativeTraits-1.09/lib/MouseX/NativeTraits/MethodProvider/Num.pm0000644€(NñY€ZÃ);0000000576612054627122030320 0ustar fuji.goroDENA\Domain Userspackage MouseX::NativeTraits::MethodProvider::Num; use Mouse; extends qw(MouseX::NativeTraits::MethodProvider); sub generate_add { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; my $constraint = $self->attr->type_constraint; return sub { my($instance, $value) = @_; if(@_ != 2) { $self->argument_error('add', 2, 2, scalar @_); } $constraint->assert_valid($value); $writer->( $instance, $reader->( $instance ) + $value ); }; } sub generate_sub { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; my $constraint = $self->attr->type_constraint; return sub { my($instance, $value) = @_; if(@_ != 2) { $self->argument_error('sub', 2, 2, scalar @_); } $constraint->assert_valid($value); $writer->( $instance, $reader->( $instance ) - $value ); }; } sub generate_mul { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; my $constraint = $self->attr->type_constraint; return sub { my($instance, $value) = @_; if(@_ != 2) { $self->argument_error('mul', 2, 2, scalar @_); } $constraint->assert_valid($value); $writer->( $instance, $reader->( $instance ) * $value ); }; } sub generate_div { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; my $constraint = $self->attr->type_constraint; return sub { my($instance, $value) = @_; if(@_ != 2) { $self->argument_error('div', 2, 2, scalar @_); } $constraint->assert_valid($value); $writer->( $instance, $reader->( $instance ) / $value ); }; } sub generate_mod { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; my $constraint = $self->attr->type_constraint; return sub { my($instance, $value) = @_; if(@_ != 2) { $self->argument_error('mod', 2, 2, scalar @_); } $constraint->assert_valid($value); $writer->( $instance, $reader->( $instance ) % $value ); }; } sub generate_abs { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; return sub { my($instance) = @_; if(@_ != 1) { $self->argument_error('abs', 1, 1, scalar @_); } $writer->( $instance, abs( $reader->( $instance ) ) ); }; } no Mouse; __PACKAGE__->meta->make_immutable(); __END__ =head1 NAME MouseX::NativeTraits::MethodProvider::Num - Provides methods for Num =head1 DESCRIPTION This class provides method generators for the C trait. See L for details. =head1 METHOD GENERATORS =over 4 =item generate_add =item generate_sub =item generate_mul =item generate_div =item generate_mod =item generate_abs =back =head1 SEE ALSO L. =cut MouseX-NativeTraits-1.09/lib/MouseX/NativeTraits/MethodProvider/Str.pm0000644€(NñY€ZÃ);0000001577512054627122030332 0ustar fuji.goroDENA\Domain Userspackage MouseX::NativeTraits::MethodProvider::Str; use Mouse; use Mouse::Util::TypeConstraints (); extends qw(MouseX::NativeTraits::MethodProvider); sub generate_append { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; return sub { my($instance, $value) = @_; if(@_ != 2) { $self->argument_error('append', 2, 2, scalar @_); } defined($value) or $self->meta->throw_error( "The argument passed to append must be a string"); $writer->( $instance, $reader->( $instance ) . $value ); }; } sub generate_prepend { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; return sub { my($instance, $value) = @_; if(@_ != 2) { $self->argument_error('prepend', 2, 2, scalar @_); } defined($value) or $self->meta->throw_error( "The argument passed to prepend must be a string"); $writer->( $instance, $value . $reader->( $instance ) ); }; } sub generate_replace { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; return sub { my( $instance, $regexp, $replacement ) = @_; if(@_ != 3) { $self->argument_error('replace', 3, 3, scalar @_); } ( Mouse::Util::TypeConstraints::Str($regexp) || Mouse::Util::TypeConstraints::RegexpRef($regexp) ) or $self->meta->throw_error( "The first argument passed to replace must be a string" . " or regexp reference"); my $v = $reader->( $instance ); if ( ref($replacement) eq 'CODE' ) { $v =~ s/$regexp/$replacement->()/e; } else { Mouse::Util::TypeConstraints::Str($replacement) or $self->meta->throw_error( "The second argument passed to replace must be a string" . " or code reference"); $v =~ s/$regexp/$replacement/; } $writer->( $instance, $v ); }; } sub generate_replace_globally { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; return sub { my( $instance, $regexp, $replacement ) = @_; if(@_ != 3) { $self->argument_error('replace_globally', 3, 3, scalar @_); } ( Mouse::Util::TypeConstraints::Str($regexp) || Mouse::Util::TypeConstraints::RegexpRef($regexp) ) or $self->meta->throw_error( "The first argument passed to replace_globally must be a string" . " or regexp reference"); my $v = $reader->( $instance ); if ( ref($replacement) eq 'CODE' ) { $v =~ s/$regexp/$replacement->()/eg; } else { Mouse::Util::TypeConstraints::Str($replacement) or $self->meta->throw_error( "The second argument passed to replace must be a string" . " or code reference"); $v =~ s/$regexp/$replacement/g; } $writer->( $instance, $v ); }; } sub generate_match { my($self) = @_; my $reader = $self->reader; return sub { my($instance, $regexp) = @_; if(@_ != 2) { $self->argument_error('match', 2, 2, scalar @_); } ( Mouse::Util::TypeConstraints::Str($regexp) || Mouse::Util::TypeConstraints::RegexpRef($regexp) ) or $self->meta->throw_error( "The argument passed to match must be a string" . " or regexp reference"); $reader->( $instance ) =~ $regexp; }; } sub generate_chop { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; return sub { my($instance) = @_; if(@_ != 1) { $self->argument_error('chop', 1, 1, scalar @_); } my $v = $reader->( $instance ); my $r = chop($v); $writer->( $instance, $v ); return $r; }; } sub generate_chomp { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; return sub { my($instance) = @_; if(@_ != 1) { $self->argument_error('chomp', 1, 1, scalar @_); } my $v = $reader->( $instance ); my $r = chomp($v); $writer->( $instance, $v ); return $r; }; } sub generate_inc { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; return sub { my($instance) = @_; if(@_ != 1) { $self->argument_error('inc', 1, 1, scalar @_); } my $v = $reader->( $instance ); $v++; $writer->( $instance, $v ); }; } sub generate_clear { my($self) = @_; my $writer = $self->writer; return sub { my($instance) = @_; if(@_ != 1) { $self->argument_error('clear', 1, 1, scalar @_); } $writer->( $instance, '' ); }; } sub generate_length { my($self) = @_; my $reader = $self->reader; return sub { if(@_ != 1) { $self->argument_error('length', 1, 1, scalar @_); } return length( $reader->($_[0]) ); }; } sub generate_substr { my($self) = @_; my $reader = $self->reader; my $writer = $self->writer; return sub { my($instance, $offset, $length, $replacement) = @_; if(@_ < 2 or @_ > 4) { $self->argument_error('substr', 2, 4, scalar @_); } my $v = $reader->($instance); Mouse::Util::TypeConstraints::Int($offset) or $self->meta->throw_error( "The first argument passed to substr must be an integer"); if(defined $length) { Mouse::Util::TypeConstraints::Int($length) or $self->meta->throw_error( "The second argument passed to substr must be an integer"); } else { $length = length($v); } my $ret; if ( defined $replacement ) { Mouse::Util::TypeConstraints::Str($replacement) or $self->meta->throw_error( "The third argument passed to substr must be a string"); $ret = substr( $v, $offset, $length, $replacement ); $writer->( $instance, $v ); } else { $ret = substr( $v, $offset, $length ); } return $ret; }; } no Mouse; __PACKAGE__->meta->make_immutable(); __END__ =head1 NAME MouseX::NativeTraits::MethodProvider::Str - Provides methods for Str =head1 DESCRIPTION This class provides method generators for the C trait. See L for details. =head1 METHOD GENERATORS =over 4 =item generate_append =item generate_prepend =item generate_replace =item generate_replace_globally =item generate_match =item generate_chop =item generate_chomp =item generate_inc =item generate_clear =item generate_length =item generate_substr =back =head1 SEE ALSO L. =cut MouseX-NativeTraits-1.09/lib/MouseX/NativeTraits/MethodProvider.pm0000644€(NñY€ZÃ);0000000466512054627122027556 0ustar fuji.goroDENA\Domain Userspackage MouseX::NativeTraits::MethodProvider; use Mouse; has attr => ( is => 'ro', isa => 'Object', required => 1, weak_ref => 1, ); has reader => ( is => 'ro', lazy_build => 1, ); has writer => ( is => 'ro', lazy_build => 1, ); sub _build_reader { my($self) = @_; return $self->attr->get_read_method_ref; } sub _build_writer { my($self) = @_; return $self->attr->get_write_method_ref; } sub has_generator { my($self, $name) = @_; return $self->meta->has_method("generate_$name"); } sub generate { my($self, $handle_name, $method_to_call) = @_; my @curried_args; ($method_to_call, @curried_args) = @{$method_to_call}; my $code = $self->meta ->get_method_body("generate_$method_to_call")->($self); if(@curried_args){ return sub { my $instance = shift; $code->($instance, @curried_args, @_); }; } else{ return $code; } } sub get_generators { my($self) = @_; return grep{ s/\A generate_ //xms } $self->meta->get_method_list; } sub argument_error { my($self, $name, $min, $max, $nargs) = @_; if(not defined $max) { $max = 9 ** 9 ** 9; # inifinity :p } # fix numbers for $self $min--; $max--; $nargs--; if($min <= $nargs and $nargs <= $max) { Carp::croak("Oops ($name): nags=$nargs, min=$min, max=$max"); } my $message = 'Cannot call %s %s argument%s'; if($min == 0 and $max == 0 && $nargs > 0) { $self->meta->throw_error( sprintf $message, $name, 'with any', 's' ); } $self->meta->throw_error( sprintf 'Cannot call %s %s %d argument%s', $name, ($nargs < $min ? ('without at least', $min) : ('with more than', $max) ), $nargs == 1 ? '' : 's' ); } no Mouse; __PACKAGE__->meta->make_immutable(strict_constructor => 1); __END__ =head1 NAME MouseX::NativeTraits::MethodProvider - The common base class for method providers =head1 DESCRIPTION This class is the common base class for method providers. =head1 ATTRIBUTES =over 4 =item attr =item reader Shortcut for C<< $provider->attr->get_read_method_ref >>. =item writer Shortcut for C<< $provider->attr->get_write_method_ref >>. =back =head1 METHODS =over 4 =item has_generator =item generate =item get_generators =back =head1 SEE ALSO L =cut MouseX-NativeTraits-1.09/lib/MouseX/NativeTraits/Num.pm0000644€(NñY€ZÃ);0000000340412054627277025363 0ustar fuji.goroDENA\Domain Userspackage MouseX::NativeTraits::Num; use Mouse::Role; with 'MouseX::NativeTraits'; sub method_provider_class { return 'MouseX::NativeTraits::MethodProvider::Num'; } sub helper_type { return 'Num'; } no Mouse::Role; 1; __END__ =pod =head1 NAME MouseX::NativeTraits::Num - Helper trait for Num attributes =head1 SYNOPSIS package Real; use Mouse; has 'integer' => ( traits => ['Number'], is => 'ro', isa => 'Num', default => 5, handles => { set => 'set', add => 'add', sub => 'sub', mul => 'mul', div => 'div', mod => 'mod', abs => 'abs', }, ); my $real = Real->new(); $real->add(5); # same as $real->integer($real->integer + 5); $real->sub(2); # same as $real->integer($real->integer - 2); =head1 DESCRIPTION This provides a simple numeric attribute, which supports most of the basic math operations. =head1 PROVIDED METHODS It is important to note that all those methods do in place modification of the value stored in the attribute. These methods are implemented within this package. =over 4 =item B Adds the current value of the attribute to C<$value>. =item B Subtracts C<$value> from the current value of the attribute. =item B Multiplies the current value of the attribute by C<$value>. =item B Divides the current value of the attribute by C<$value>. =item B Returns the current value of the attribute modulo C<$value>. =item B Sets the current value of the attribute to its absolute value. =back =head1 METHODS =over 4 =item B =item B =item B =back =head1 SEE ALSO L =cut MouseX-NativeTraits-1.09/lib/MouseX/NativeTraits/Str.pm0000644€(NñY€ZÃ);0000000505212054627122025362 0ustar fuji.goroDENA\Domain Userspackage MouseX::NativeTraits::Str; use Mouse::Role; with 'MouseX::NativeTraits'; sub method_provider_class { return 'MouseX::NativeTraits::MethodProvider::Str'; } sub helper_type { return 'Str'; } sub _default_default{ '' } no Mouse::Role; 1; __END__ =head1 NAME MouseX::NativeTraits::Str - Helper trait for Str attributes =head1 SYNOPSIS package MyHomePage; use Mouse; has 'text' => ( traits => ['String'], is => 'rw', isa => 'Str', default => q{}, handles => { add_text => 'append', replace_text => 'replace', }, ); my $page = MyHomePage->new(); $page->add_text("foo"); # same as $page->text($page->text . "foo"); =head1 DESCRIPTION This module provides a simple string attribute, to which mutating string operations can be applied more easily (no need to make an lvalue attribute metaclass or use temporary variables). Additional methods are provided for completion. =head1 PROVIDED METHODS These methods are implemented in L. It is important to note that all those methods do in place modification of the value stored in the attribute. =over 4 =item B Increments the value stored in this slot using the magical string autoincrement operator. Note that Perl doesn't provide analogous behavior in C<-->, so C is not available. =item B Append a string, like C<.=>. =item B Prepend a string. =item B Performs a regexp substitution (L). A code references will be accepted for the replacement, causing the regexp to be modified with a single C. C can be applied using the C operator. =item B Performs a regexp substitution (L) with the C flag. A code references will be accepted for the replacement, causing the regexp to be modified with a single C. C can be applied using the C operator. =item B Like C but without the replacement. Provided mostly for completeness. =item B L =item B L =item B Sets the string to the empty string (not the value passed to C). =item B L =item B L. We go to some lengths to match the different functionality based on C's arity. =back =head1 METHODS =over 4 =item B =item B =item B =back =head1 SEE ALSO L =cut MouseX-NativeTraits-1.09/lib/MouseX/NativeTraits.pm0000644€(NñY€ZÃ);0000001531512054627355024625 0ustar fuji.goroDENA\Domain Userspackage MouseX::NativeTraits; use 5.006_002; use Mouse::Role; our $VERSION = '1.09'; requires qw(method_provider_class helper_type); #has default => ( # is => 'bare', # don't create new methods # required => 1, #); has type_constraint => ( is => 'bare', # don't create new methods required => 1, ); has method_provider => ( is => 'ro', isa => 'Object', builder => '_build_method_provider', ); sub _build_method_provider{ my($self) = @_; my $mpc = $self->method_provider_class; Mouse::Util::load_class($mpc); return $mpc->new(attr => $self); } before _process_options => sub { my ( $self, $name, $options ) = @_; my $type = $self->helper_type; $options->{isa} = $type if !exists $options->{isa}; my $isa = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint( $options->{isa} ); ( $isa->is_a_type_of($type) ) || $self->throw_error( "The type constraint for $name must be a subtype of $type but it's a $isa"); $options->{default} = $self->_default_default if !exists $options->{default} && $self->can('_default_default'); }; around _canonicalize_handles => sub { my($next, $self) = @_; my $handles_ref = $self->handles; if( ref($handles_ref) ne 'HASH' ) { $self->throw_error( "The 'handles' option must be a HASH reference, not $handles_ref"); } my $provider = $self->method_provider; my %handles; while(my($name, $to) = each %{$handles_ref}){ $to = [$to] if !ref $to; $provider->has_generator($to->[0]) or $self->throw_error("$to->[0] is an unsupported method type"); $handles{$name} = $to; } return %handles; }; around _make_delegation_method => sub { my( $next, $self, $handle_name, $method_to_call) = @_; return $self->method_provider->generate($handle_name, $method_to_call); }; no Mouse::Role; 1; __END__ =head1 NAME MouseX::NativeTraits - Extend your attribute interfaces for Mouse =head1 VERSION This document describes MouseX::NativeTraits version 1.09. =head1 SYNOPSIS package MyClass; use Mouse; has mapping => ( traits => ['Hash'], is => 'rw', isa => 'HashRef[Str]', default => sub { +{} }, handles => { exists_in_mapping => 'exists', ids_in_mapping => 'keys', get_mapping => 'get', set_mapping => 'set', set_quantity => [ set => 'quantity' ], }, ); =head1 DESCRIPTION While L attributes provide a way to name your accessors, readers, writers, clearers and predicates, MouseX::NativeTraits provides commonly used attribute helper methods for more specific types of data. As seen in the L, you specify the data structure via the C parameter. These traits will be loaded automatically, so you need not load MouseX::NativeTraits explicitly. This extension is compatible with Moose native traits, although it is not a part of Mouse core. =head1 PARAMETERS =head2 handles This is like C in L, but only HASH references are allowed. Keys are method names that you want installed locally, and values are methods from the method providers (below). Currying with delegated methods works normally for C<< handles >>. =head1 NATIVE TRAITS =head2 Array Common methods for array references. has 'queue' => ( traits => ['Array'], is => 'ro', isa => 'ArrayRef[Str]', default => sub { [] }, handles => { add_item => 'push', next_item => 'shift', } ); See L. =head2 Hash Common methods for hash references. has 'options' => ( traits => ['Hash'], is => 'ro', isa => 'HashRef[Str]', default => sub { {} }, handles => { set_option => 'set', get_option => 'get', has_option => 'exists', } ); See L. =head2 Code Common methods for code references. has 'callback' => ( traits => ['Code'], is => 'ro', isa => 'CodeRef', default => sub { sub { 'called' } }, handles => { call => 'execute', } ); See L. =head2 Bool Common methods for boolean values. has 'is_lit' => ( traits => ['Bool'], is => 'rw', isa => 'Bool', default => 0, handles => { illuminate => 'set', darken => 'unset', flip_switch => 'toggle', is_dark => 'not', } ); See L. =head2 String Common methods for string operations. has text => ( traits => ['String'], is => 'rw', isa => 'Str', default => q{}, handles => { add_text => 'append', replace_text => 'replace', # or replace_globally } ); See L. =head2 Number Common numerical operations. has value => ( traits => ['Number'], is => 'ro', isa => 'Int', default => 5, handles => { set => 'set', add => 'add', sub => 'sub', mul => 'mul', div => 'div', mod => 'mod', abs => 'abs', } ); See L. =head2 Counter Methods for incrementing and decrementing a counter attribute. has counter => ( traits => ['Counter'], is => 'ro', isa => 'Num', default => 0, handles => { inc_counter => 'inc', dec_counter => 'dec', reset_counter => 'reset', } ); See L. =head1 DEPENDENCIES Perl 5.6.2 or later. =head1 BUGS All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. =head1 SEE ALSO L L L L L =head1 AUTHORS Goro Fuji (gfx) Egfuji(at)cpan.orgE This module is based on Moose native traits written by Stevan Little and others. =head1 LICENSE AND COPYRIGHT Copyright (c) 2010, Goro Fuji (gfx), mostly based on Moose, which is (c) Infinity Interactive, Inc (L). This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L for details. =cut MouseX-NativeTraits-1.09/Makefile.PL0000644€(NñY€ZÃ);0000000115512054627122021623 0ustar fuji.goroDENA\Domain Usersuse strict; use warnings; use inc::Module::Install 1.06; use Module::Install::TestTarget 0.19; all_from 'lib/MouseX/NativeTraits.pm'; requires 'Mouse' => 0.82; test_requires 'Any::Moose' => 0.13; test_requires 'Test::More' => 0.88; # done_testing() test_requires 'Test::Fatal' => 0.003; tests_recursive 't'; author_tests 'xt'; auto_set_repository() if -d '.git'; default_test_target env => { ANY_MOOSE => 'Mouse' }; test_target 'test_moose' => ( env => { ANY_MOOSE => 'Moose' }, ); clean_files qw( MouseX-NativeTraits-* *.stackdump cover_db nytprof *.out ); WriteAll(check_nmake => 0); MouseX-NativeTraits-1.09/MANIFEST0000644€(NñY€ZÃ);0000000432712054627352021013 0ustar fuji.goroDENA\Domain Usersbenchmarks/arrayref.pl benchmarks/bool.pl benchmarks/inc.pl benchmarks/inc2.pl benchmarks/sort_by.pl Changes example/complex_tc.pl inc/Module/Install.pm inc/Module/Install/AuthorTests.pm inc/Module/Install/Base.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Repository.pm inc/Module/Install/TestTarget.pm inc/Module/Install/WriteAll.pm lib/Mouse/Meta/Attribute/Custom/Trait/Array.pm lib/Mouse/Meta/Attribute/Custom/Trait/Bool.pm lib/Mouse/Meta/Attribute/Custom/Trait/Code.pm lib/Mouse/Meta/Attribute/Custom/Trait/Counter.pm lib/Mouse/Meta/Attribute/Custom/Trait/Hash.pm lib/Mouse/Meta/Attribute/Custom/Trait/Number.pm lib/Mouse/Meta/Attribute/Custom/Trait/String.pm lib/Mouse/Meta/Attribute/Native.pm lib/MouseX/NativeTraits.pm lib/MouseX/NativeTraits/ArrayRef.pm lib/MouseX/NativeTraits/Bool.pm lib/MouseX/NativeTraits/CodeRef.pm lib/MouseX/NativeTraits/Counter.pm lib/MouseX/NativeTraits/HashRef.pm lib/MouseX/NativeTraits/MethodProvider.pm lib/MouseX/NativeTraits/MethodProvider/ArrayRef.pm lib/MouseX/NativeTraits/MethodProvider/Bool.pm lib/MouseX/NativeTraits/MethodProvider/CodeRef.pm lib/MouseX/NativeTraits/MethodProvider/Counter.pm lib/MouseX/NativeTraits/MethodProvider/HashRef.pm lib/MouseX/NativeTraits/MethodProvider/Num.pm lib/MouseX/NativeTraits/MethodProvider/Str.pm lib/MouseX/NativeTraits/Num.pm lib/MouseX/NativeTraits/Str.pm Makefile.PL MANIFEST This list of files MANIFEST.SKIP META.yml README t/00_load.t t/01_basic.t t/02_meta.t t/03_extra.t t/04_counter.t t/05_remain_tied.t t/070_native_traits/010_trait_array.t t/070_native_traits/011_array_subtypes.t t/070_native_traits/012_array_trigger.t t/070_native_traits/013_array_coerce.t t/070_native_traits/020_trait_bool.t t/070_native_traits/030_trait_code.t t/070_native_traits/040_trait_counter.t t/070_native_traits/050_trait_hash.t t/070_native_traits/051_hash_subtypes.t t/070_native_traits/052_hash_trigger.t t/070_native_traits/053_hash_coerce.t t/070_native_traits/060_trait_number.t t/070_native_traits/070_trait_string.t t/070_native_traits/100_array_from_role.t t/070_native_traits/101_remove_attribute.t t/070_native_traits/102_collection_with_roles.t t/070_native_traits/103_custom_instance.t xt/01_podspell.t xt/02_pod.t xt/04_synopsis.t MouseX-NativeTraits-1.09/MANIFEST.SKIP0000644€(NñY€ZÃ);0000000124512054627122021547 0ustar fuji.goroDENA\Domain Users #!start included /home/s0710509/sperl/lib/5.10.1/ExtUtils/MANIFEST.SKIP # Avoid version control files. \bRCS\b \bCVS\b \bSCCS\b ,v$ \B\.svn\b \B\.git\b \B\.gitignore\b \b_darcs\b # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ # Avoid Devel::Cover files. \bcover_db\b #!end included /home/s0710509/sperl/lib/5.10.1/ExtUtils/MANIFEST.SKIP # skip dot files ^\. # skip author's files \bauthor\b MYMETA MouseX-NativeTraits-1.09/META.yml0000644€(NñY€ZÃ);0000000134612054627374021135 0ustar fuji.goroDENA\Domain Users--- abstract: 'Extend your attribute interfaces for Mouse' author: - 'Goro Fuji (gfx) ' build_requires: Any::Moose: 0.13 ExtUtils::MakeMaker: 6.59 Test::Fatal: 0.003 Test::More: 0.88 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 module_name: MouseX::NativeTraits name: MouseX-NativeTraits no_index: directory: - example - inc - t - xt requires: Mouse: 0.82 perl: 5.6.2 resources: license: http://dev.perl.org/licenses/ repository: git://github.com/gfx/p5-MouseX-NativeTraits.git version: 1.09 MouseX-NativeTraits-1.09/README0000644€(NñY€ZÃ);0000000104612054627122020530 0ustar fuji.goroDENA\Domain UsersThis is Perl module MouseX::NativeTraits. INSTALLATION MouseX::NativeTraits installation is straightforward. If your CPAN shell is set up, you should just be able to do $ cpan MouseX::NativeTraits Download it, unpack it, then build it as per the usual: $ perl Makefile.PL $ make && make test Then install it: $ make install DOCUMENTATION MouseX::NativeTraits documentation is available as in POD. So you can do: $ perldoc MouseX::NativeTraits to read the documentation online with your favorite pager. Goro Fuji (gfx) MouseX-NativeTraits-1.09/t/0000755€(NñY€ZÃ);0000000000012054627374020123 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/t/00_load.t0000644€(NñY€ZÃ);0000000107012054627122021513 0ustar fuji.goroDENA\Domain Users#!perl -w use strict; use Test::More; require_ok 'Mouse::Meta::Attribute::Native'; require_ok 'MouseX::NativeTraits'; require_ok 'MouseX::NativeTraits::MethodProvider'; foreach my $type(qw(ArrayRef HashRef CodeRef Str Num Bool Counter)){ my $trait = 'MouseX::NativeTraits::' . $type; require_ok $trait; require_ok $trait->method_provider_class; } ok( Mouse::Meta::Attribute::Native->VERSION ); diag "Testing MouseX::NativeTraits/$MouseX::NativeTraits::VERSION"; diag "Dependencies:"; require Mouse; diag " Mouse/$Mouse::VERSION"; done_testing; MouseX-NativeTraits-1.09/t/01_basic.t0000644€(NñY€ZÃ);0000000234312054627122021662 0ustar fuji.goroDENA\Domain Users#!perl -w use strict; use Test::More; { package MyClass; use Any::Moose; has stack => ( is => 'rw', isa => 'ArrayRef', traits => ['Array'], handles => { pop => 'pop', push => 'push', top => [ get => -1 ], stack_is_empty => 'is_empty', }, default => sub{ [] }, ); has mapping => ( is => 'rw', isa => 'HashRef', traits => ['Hash'], handles => { keys => 'keys', values => 'values', store_to_map => 'set', map_count => 'count', }, default => sub{ +{} }, ); } my $o = MyClass->new(); note 'Array'; $o->push(10); is $o->top, 10; $o->push(20); is $o->top, 20; ok !$o->stack_is_empty; is $o->pop, 20; is $o->top, 10; is $o->pop, 10; is $o->pop, undef; ok $o->stack_is_empty; note 'Hash'; $o->store_to_map(aaa => 42, bbb => 10); is join(' ', sort $o->keys), 'aaa bbb'; is join(' ', sort $o->values), '10 42'; is $o->map_count, 2; $o->store_to_map(ccc => 99); is join(' ', sort $o->keys), 'aaa bbb ccc'; is join(' ', sort $o->values), '10 42 99'; is $o->map_count, 3; done_testing; MouseX-NativeTraits-1.09/t/02_meta.t0000644€(NñY€ZÃ);0000000153112054627122021526 0ustar fuji.goroDENA\Domain Users#!perl -w use strict; use Test::More; use Test::Fatal; use Any::Moose; is exception { has foo => ( traits => [qw(Array)], default => sub{ [] }, handles => { mypush0 => 'push' }, ); }, undef, '"is" parameter can be omitted'; #throws_ok { # has bar1 => ( # traits => [qw(Array)], # handles => { mypush1 => 'push' }, # ); #} qr/default .* is \s+ required/xms; my $e = exception { has bar2 => ( traits => [qw(Array)], default => sub{ [] }, handles => { push => 'mypush2' }, ); }; like $e, qr/\b unsupported \b/xms, 'wrong use of handles'; like exception { has bar3 => ( traits => [qw(Array)], isa => 'HashRef', default => sub{ [] }, handles => { mypush3 => 'push' }, ); }, qr/must be a subtype of ArrayRef/; done_testing; MouseX-NativeTraits-1.09/t/03_extra.t0000644€(NñY€ZÃ);0000000257112054627122021731 0ustar fuji.goroDENA\Domain Users#!perl -w # Mouse specific features use strict; use Test::More; { package MyClass; use Mouse; has list => ( is => 'rw', isa => 'ArrayRef', traits => ['Array'], handles => { any => 'any', sort_by => 'sort_by', sort_in_place_by => 'sort_in_place_by', apply => 'apply', map => 'map', }, default => sub{ [] }, ); has hash => ( is => 'rw', isa => 'HashRef', traits => ['Hash'], handles => { sorted_keys => 'sorted_keys', }, default => sub{ {} }, ); } my $o = MyClass->new(list => [ {value => 3}, {value => 10}, { value => 0 } ]); note 'Array'; ok $o->any(sub{ $_->{value} == 0 }), 'any'; is join(' ', map{ $_->{value} } $o->sort_by(sub{ $_->{value} }, sub{ $_[0] <=> $_[1] })), '0 3 10', 'sort_by'; $o->sort_in_place_by(sub{ $_->{value} }, sub{ $_[0] <=> $_[1] }); is join(' ', $o->map(sub{ $_->{value} })), '0 3 10', 'sort_in_place_by'; is join(' ', $o->apply(sub{ $_ = $_->{value} })), '0 3 10', 'apply'; is join(' ', $o->map(sub{ $_->{value} })), '0 3 10', 'apply does not affect the original value'; note 'Hash'; $o->hash({ 'a' => 10, 'b' => 20, 'c' => 30 }); is join(' ', $o->sorted_keys), 'a b c', 'sorted_keys'; done_testing; MouseX-NativeTraits-1.09/t/04_counter.t0000644€(NñY€ZÃ);0000000170212054627122022261 0ustar fuji.goroDENA\Domain Users#!perl use strict; use Test::More; my $triggered = 0; { package MyHomePage; use Mouse; has 'counter' => ( traits => ['Counter'], is => 'rw', isa => 'Int', default => 0, handles => { inc_counter => 'inc', dec_counter => 'dec', reset_counter => 'reset', }, ); has 'counter_w_trigger' => ( traits => ['Counter'], is => 'rw', isa => 'Int', default => 0, handles => { inc_counter2 => 'inc', dec_counter2 => 'dec', reset_counter2 => 'reset', }, trigger => sub { $triggered++; }, ); __PACKAGE__->meta->make_immutable(); } my $o = MyHomePage->new(); $o->inc_counter for 1 .. 42; is $o->counter, 42; is $triggered, 0; $o->inc_counter2 for 1 .. 42; is $o->counter_w_trigger, 42; is $triggered, 42; done_testing; MouseX-NativeTraits-1.09/t/05_remain_tied.t0000644€(NñY€ZÃ);0000000132312054627122023062 0ustar fuji.goroDENA\Domain Users#!perl -w # https://rt.cpan.org/Ticket/Display.html?id=69039 package HashTest; use Mouse; use Tie::Hash; use Test::More; my @triggered; has values => ( is => 'ro', isa => 'HashRef', traits => ['Hash'], default => sub { tie my %e, 'Tie::StdHash'; \%e }, handles => { set_value => 'set', }, trigger => sub { my($self) = @_; push @triggered, $self; }, ); my $test = __PACKAGE__->new; isa_ok tied(%{$test->values}), 'Tie::StdHash', 'HashRef is still tied after set directly'; $test->set_value('b' => 'b'); isa_ok tied(%{$test->values}), 'Tie::StdHash', 'HashRef is still tied after set via NativeTraits'; is_deeply \@triggered, [$test]; done_testing; MouseX-NativeTraits-1.09/t/070_native_traits/0000755€(NñY€ZÃ);0000000000012054627374023365 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/t/070_native_traits/010_trait_array.t0000644€(NñY€ZÃ);0000005604612054627122026455 0ustar fuji.goroDENA\Domain Users#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Any::Moose (); use Any::Moose '::Util::TypeConstraints'; #use NoInlineAttribute; BEGIN { eval 'use Test::' . any_moose(); } { my %handles = ( count => 'count', elements => 'elements', is_empty => 'is_empty', push => 'push', push_curried => [ push => 42, 84 ], unshift => 'unshift', unshift_curried => [ unshift => 42, 84 ], pop => 'pop', shift => 'shift', get => 'get', get_curried => [ get => 1 ], set => 'set', set_curried_1 => [ set => 1 ], set_curried_2 => [ set => ( 1, 98 ) ], accessor => 'accessor', accessor_curried_1 => [ accessor => 1 ], accessor_curried_2 => [ accessor => ( 1, 90 ) ], clear => 'clear', delete => 'delete', delete_curried => [ delete => 1 ], insert => 'insert', insert_curried => [ insert => ( 1, 101 ) ], splice => 'splice', splice_curried_1 => [ splice => 1 ], splice_curried_2 => [ splice => 1, 2 ], splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], sort => 'sort', sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ], sort_in_place => 'sort_in_place', sort_in_place_curried => [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], map => 'map', map_curried => [ map => ( sub { $_ + 1 } ) ], grep => 'grep', grep_curried => [ grep => ( sub { $_ < 5 } ) ], first => 'first', first_curried => [ first => ( sub { $_ % 2 } ) ], join => 'join', join_curried => [ join => '-' ], shuffle => 'shuffle', uniq => 'uniq', reduce => 'reduce', reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ], #natatime => 'natatime', #natatime_curried => [ natatime => 2 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my $class = any_moose('::Meta::Class')->create( $name++, superclasses => [any_moose('::Object')], ); my @traits = 'Array'; push @traits, 'NoInlineAttribute' if delete $attr{no_inline}; $class->add_attribute( _values => ( traits => \@traits, is => 'rw', isa => 'ArrayRef[Int]', default => sub { [] }, handles => \%handles, clearer => '_clear_values', %attr, ), ); return ( $class->name, \%handles ); } } { package Overloader; use overload '&{}' => sub { ${ $_[0] } }, bool => sub {1}; sub new { bless \$_[1], $_[0]; } } { run_tests(build_class); run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) ); run_tests( build_class( trigger => sub { } ) ); #run_tests( build_class( no_inline => 1 ) ); # Will force the inlining code to check the entire arrayref when it is modified. subtype 'MyArrayRef', as 'ArrayRef', where { 1 }; run_tests( build_class( isa => 'MyArrayRef' ) ); coerce 'MyArrayRef', from 'ArrayRef', via { $_ }; run_tests( build_class( isa => 'MyArrayRef', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new( _values => [ 10, 12, 42 ] ); is_deeply( $obj->_values, [ 10, 12, 42 ], 'values can be set in constructor' ); ok( !$obj->is_empty, 'values is not empty' ); is( $obj->count, 3, 'count returns 3' ); like( exception { $obj->count(22) }, qr/Cannot call count with any arguments/, 'throws an error when passing an argument passed to count' ); is( exception { $obj->push( 1, 2, 3 ) }, undef, 'pushed three new values and lived' ); is( exception { $obj->push() }, undef, 'call to push without arguments lives' ); is( exception { is( $obj->unshift( 101, 22 ), 8, 'unshift returns size of the new array' ); }, undef, 'unshifted two values and lived' ); is_deeply( $obj->_values, [ 101, 22, 10, 12, 42, 1, 2, 3 ], 'unshift changed the value of the array in the object' ); is( exception { $obj->unshift() }, undef, 'call to unshift without arguments lives' ); is( $obj->pop, 3, 'pop returns the last value in the array' ); is_deeply( $obj->_values, [ 101, 22, 10, 12, 42, 1, 2 ], 'pop changed the value of the array in the object' ); like( exception { $obj->pop(42) }, qr/Cannot call pop with any arguments/, 'call to pop with arguments dies' ); is( $obj->shift, 101, 'shift returns the first value' ); like( exception { $obj->shift(42) }, qr/Cannot call shift with any arguments/, 'call to shift with arguments dies' ); is_deeply( $obj->_values, [ 22, 10, 12, 42, 1, 2 ], 'shift changed the value of the array in the object' ); is_deeply( [ $obj->elements ], [ 22, 10, 12, 42, 1, 2 ], 'call to elements returns values as a list' ); like( exception { $obj->elements(22) }, qr/Cannot call elements with any arguments/, 'throws an error when passing an argument passed to elements' ); $obj->_values( [ 1, 2, 3 ] ); is( $obj->get(0), 1, 'get values at index 0' ); is( $obj->get(1), 2, 'get values at index 1' ); is( $obj->get(2), 3, 'get values at index 2' ); is( $obj->get_curried, 2, 'get_curried returns value at index 1' ); like( exception { $obj->get() }, qr/Cannot call get without at least 1 argument/, 'throws an error when get is called without any arguments' ); like( exception { $obj->get( {} ) }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get(2.2) }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get('foo') }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get_curried(2) }, qr/Cannot call get with more than 1 argument/, 'throws an error when get_curried is called with an argument' ); is( exception { is( $obj->set( 1, 100 ), 100, 'set returns new value' ); }, undef, 'set value at index 1 lives' ); is( $obj->get(1), 100, 'get value at index 1 returns new value' ); like( exception { $obj->set( 1, 99, 42 ) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set is called with three arguments' ); is( exception { $obj->set_curried_1(99) }, undef, 'set_curried_1 lives' ); is( $obj->get(1), 99, 'get value at index 1 returns new value' ); like( exception { $obj->set_curried_1( 99, 42 ) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set_curried_1 is called with two arguments' ); is( exception { $obj->set_curried_2 }, undef, 'set_curried_2 lives' ); is( $obj->get(1), 98, 'get value at index 1 returns new value' ); like( exception { $obj->set_curried_2(42) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set_curried_2 is called with one argument' ); is( $obj->accessor(1), 98, 'accessor with one argument returns value at index 1' ); is( exception { is( $obj->accessor( 1 => 97 ), 97, 'accessor returns new value' ); }, undef, 'accessor as writer lives' ); like( exception { $obj->accessor; }, qr/Cannot call accessor without at least 1 argument/, 'throws an error when accessor is called without arguments' ); is( $obj->get(1), 97, 'accessor set value at index 1' ); like( exception { $obj->accessor( 1, 96, 42 ) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor is called with three arguments' ); is( $obj->accessor_curried_1, 97, 'accessor_curried_1 returns expected value when called with no arguments' ); is( exception { $obj->accessor_curried_1(95) }, undef, 'accessor_curried_1 as writer lives' ); is( $obj->get(1), 95, 'accessor_curried_1 set value at index 1' ); like( exception { $obj->accessor_curried_1( 96, 42 ) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor_curried_1 is called with two arguments' ); is( exception { $obj->accessor_curried_2 }, undef, 'accessor_curried_2 as writer lives' ); is( $obj->get(1), 90, 'accessor_curried_2 set value at index 1' ); like( exception { $obj->accessor_curried_2(42) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor_curried_2 is called with one argument' ); is( exception { $obj->clear }, undef, 'clear lives' ); ok( $obj->is_empty, 'values is empty after call to clear' ); $obj->set( 0 => 42 ); like( exception { $obj->clear(50) }, qr/Cannot call clear with any arguments/, 'throws an error when clear is called with an argument' ); ok( !$obj->is_empty, 'values is not empty after failed call to clear' ); like( exception { $obj->is_empty(50) }, qr/Cannot call is_empty with any arguments/, 'throws an error when is_empty is called with an argument' ); $obj->clear; is( $obj->push( 1, 5, 10, 42 ), 4, 'pushed 4 elements, got number of elements in the array back' ); is( exception { is( $obj->delete(2), 10, 'delete returns deleted value' ); }, undef, 'delete lives' ); is_deeply( $obj->_values, [ 1, 5, 42 ], 'delete removed the specified element' ); like( exception { $obj->delete( 2, 3 ) }, qr/Cannot call delete with more than 1 argument/, 'throws an error when delete is called with two arguments' ); is( exception { $obj->delete_curried }, undef, 'delete_curried lives' ); is_deeply( $obj->_values, [ 1, 42 ], 'delete removed the specified element' ); like( exception { $obj->delete_curried(2) }, qr/Cannot call delete with more than 1 argument/, 'throws an error when delete_curried is called with one argument' ); is( exception { $obj->insert( 1, 21 ) }, undef, 'insert lives' ); is_deeply( $obj->_values, [ 1, 21, 42 ], 'insert added the specified element' ); like( exception { $obj->insert( 1, 22, 44 ) }, qr/Cannot call insert with more than 2 arguments/, 'throws an error when insert is called with three arguments' ); is( exception { is_deeply( [ $obj->splice( 1, 0, 2, 3 ) ], [], 'return value of splice is empty list when not removing elements' ); }, undef, 'splice lives' ); is_deeply( $obj->_values, [ 1, 2, 3, 21, 42 ], 'splice added the specified elements' ); is( exception { is_deeply( [ $obj->splice( 1, 2, 99 ) ], [ 2, 3 ], 'splice returns list of removed values' ); }, undef, 'splice lives' ); is_deeply( $obj->_values, [ 1, 99, 21, 42 ], 'splice added the specified elements' ); like( exception { $obj->splice() }, qr/Cannot call splice without at least 1 argument/, 'throws an error when splice is called with no arguments' ); like( exception { $obj->splice( 1, 'foo', ) }, qr/The length argument passed to splice must be an integer/, 'throws an error when splice is called with an invalid length' ); is( exception { $obj->splice_curried_1( 2, 101 ) }, undef, 'splice_curried_1 lives' ); is_deeply( $obj->_values, [ 1, 101, 42 ], 'splice added the specified elements' ); is( exception { $obj->splice_curried_2(102) }, undef, 'splice_curried_2 lives' ); is_deeply( $obj->_values, [ 1, 102 ], 'splice added the specified elements' ); is( exception { $obj->splice_curried_all }, undef, 'splice_curried_all lives' ); is_deeply( $obj->_values, [ 1, 3, 4, 5 ], 'splice added the specified elements' ); is_deeply( scalar $obj->splice( 1, 2 ), 4, 'splice in scalar context returns last element removed' ); is_deeply( scalar $obj->splice( 1, 0, 42 ), undef, 'splice in scalar context returns undef when no elements are removed' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); is_deeply( [ $obj->sort ], [ 11, 22, 3, 5, 9 ], 'sort returns sorted values' ); is_deeply( [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ], 'sort returns values sorted by provided function' ); like( exception { $obj->sort(1) }, qr/The argument passed to sort must be a code reference/, 'throws an error when passing a non coderef to sort' ); like( exception { $obj->sort( sub { }, 27 ); }, qr/Cannot call sort with more than 1 argument/, 'throws an error when passing two arguments to sort' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); $obj->sort_in_place; is_deeply( $obj->_values, [ 11, 22, 3, 5, 9 ], 'sort_in_place sorts values' ); $obj->sort_in_place( sub { $_[0] <=> $_[1] } ); is_deeply( $obj->_values, [ 3, 5, 9, 11, 22 ], 'sort_in_place with function sorts values' ); like( exception { $obj->sort_in_place( 27 ); }, qr/The argument passed to sort_in_place must be a code reference/, 'throws an error when passing a non coderef to sort_in_place' ); like( exception { $obj->sort_in_place( sub { }, 27 ); }, qr/Cannot call sort_in_place with more than 1 argument/, 'throws an error when passing two arguments to sort_in_place' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); $obj->sort_in_place_curried; is_deeply( $obj->_values, [ 22, 11, 9, 5, 3 ], 'sort_in_place_curried sorts values' ); like( exception { $obj->sort_in_place_curried(27) }, qr/Cannot call sort_in_place with more than 1 argument/, 'throws an error when passing one argument passed to sort_in_place_curried' ); $obj->_values( [ 1 .. 5 ] ); is_deeply( [ $obj->map( sub { $_ + 1 } ) ], [ 2 .. 6 ], 'map returns the expected values' ); like( exception { $obj->map }, qr/Cannot call map without at least 1 argument/, 'throws an error when passing no arguments to map' ); like( exception { $obj->map( sub { }, 2 ); }, qr/Cannot call map with more than 1 argument/, 'throws an error when passing two arguments to map' ); like( exception { $obj->map( {} ) }, qr/The argument passed to map must be a code reference/, 'throws an error when passing a non coderef to map' ); $obj->_values( [ 1 .. 5 ] ); is_deeply( [ $obj->map_curried ], [ 2 .. 6 ], 'map_curried returns the expected values' ); like( exception { $obj->map_curried( sub { } ); }, qr/Cannot call map with more than 1 argument/, 'throws an error when passing one argument passed to map_curried' ); $obj->_values( [ 2 .. 9 ] ); is_deeply( [ $obj->grep( sub { $_ < 5 } ) ], [ 2 .. 4 ], 'grep returns the expected values' ); like( exception { $obj->grep }, qr/Cannot call grep without at least 1 argument/, 'throws an error when passing no arguments to grep' ); like( exception { $obj->grep( sub { }, 2 ); }, qr/Cannot call grep with more than 1 argument/, 'throws an error when passing two arguments to grep' ); like( exception { $obj->grep( {} ) }, qr/The argument passed to grep must be a code reference/, 'throws an error when passing a non coderef to grep' ); my $overloader = Overloader->new( sub { $_ < 5 } ); is_deeply( [ $obj->grep(\&$overloader) ], [ 2 .. 4 ], 'grep works with obj that overload code dereferencing' ); is_deeply( [ $obj->grep_curried ], [ 2 .. 4 ], 'grep_curried returns the expected values' ); like( exception { $obj->grep_curried( sub { } ); }, qr/Cannot call grep with more than 1 argument/, 'throws an error when passing one argument passed to grep_curried' ); $obj->_values( [ 2, 4, 22, 99, 101, 6 ] ); is( $obj->first( sub { $_ % 2 } ), 99, 'first returns expected value' ); like( exception { $obj->first }, qr/Cannot call first without at least 1 argument/, 'throws an error when passing no arguments to first' ); like( exception { $obj->first( sub { }, 2 ); }, qr/Cannot call first with more than 1 argument/, 'throws an error when passing two arguments to first' ); like( exception { $obj->first( {} ) }, qr/The argument passed to first must be a code reference/, 'throws an error when passing a non coderef to first' ); is( $obj->first_curried, 99, 'first_curried returns expected value' ); like( exception { $obj->first_curried( sub { } ); }, qr/Cannot call first with more than 1 argument/, 'throws an error when passing one argument passed to first_curried' ); $obj->_values( [ 1 .. 4 ] ); is( $obj->join('-'), '1-2-3-4', 'join returns expected result' ); is( $obj->join(q{}), '1234', 'join returns expected result when joining with empty string' ); like( exception { $obj->join }, qr/Cannot call join without at least 1 argument/, 'throws an error when passing no arguments to join' ); like( exception { $obj->join( '-', 2 ) }, qr/Cannot call join with more than 1 argument/, 'throws an error when passing two arguments to join' ); like( exception { $obj->join( {} ) }, qr/The argument passed to join must be a string/, 'throws an error when passing a non string to join' ); is_deeply( [ sort $obj->shuffle ], [ 1 .. 4 ], 'shuffle returns all values (cannot check for a random order)' ); like( exception { $obj->shuffle(2) }, qr/Cannot call shuffle with any arguments/, 'throws an error when passing an argument passed to shuffle' ); $obj->_values( [ 1 .. 4, 2, 5, 3, 7, 3, 3, 1 ] ); is_deeply( [ $obj->uniq ], [ 1 .. 4, 5, 7 ], 'uniq returns expected values (in original order)' ); like( exception { $obj->uniq(2) }, qr/Cannot call uniq with any arguments/, 'throws an error when passing an argument passed to uniq' ); $obj->_values( [ 1 .. 5 ] ); is( $obj->reduce( sub { $_[0] * $_[1] } ), 120, 'reduce returns expected value' ); like( exception { $obj->reduce }, qr/Cannot call reduce without at least 1 argument/, 'throws an error when passing no arguments to reduce' ); like( exception { $obj->reduce( sub { }, 2 ); }, qr/Cannot call reduce with more than 1 argument/, 'throws an error when passing two arguments to reduce' ); like( exception { $obj->reduce( {} ) }, qr/The argument passed to reduce must be a code reference/, 'throws an error when passing a non coderef to reduce' ); is( $obj->reduce_curried, 120, 'reduce_curried returns expected value' ); like( exception { $obj->reduce_curried( sub { } ); }, qr/Cannot call reduce with more than 1 argument/, 'throws an error when passing one argument passed to reduce_curried' ); $obj->_values( [ 1 .. 6 ] ); # my $it = $obj->natatime(2); # my @nat; # while ( my @v = $it->() ) { # push @nat, \@v; # } # # is_deeply( # [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], # \@nat, # 'natatime returns expected iterator' # ); # # @nat = (); # $obj->natatime( 2, sub { push @nat, [@_] } ); # # is_deeply( # [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], # \@nat, # 'natatime with function returns expected value' # ); # # like( exception { $obj->natatime( {} ) }, qr/The n value passed to natatime must be an integer/, 'throws an error when passing a non integer to natatime' ); # # like( exception { $obj->natatime( 2, {} ) }, qr/The second argument passed to natatime must be a code reference/, 'throws an error when passing a non code ref to natatime' ); # # $it = $obj->natatime_curried(); # @nat = (); # while ( my @v = $it->() ) { # push @nat, \@v; # } # # is_deeply( # [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], # \@nat, # 'natatime_curried returns expected iterator' # ); # # @nat = (); # $obj->natatime_curried( sub { push @nat, [@_] } ); # # is_deeply( # [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], # \@nat, # 'natatime_curried with function returns expected value' # ); # # like( exception { $obj->natatime_curried( {} ) }, qr/The second argument passed to natatime must be a code reference/, 'throws an error when passing a non code ref to natatime_curried' ); if ( $class->meta->get_attribute('_values')->is_lazy ) { my $obj = $class->new; is( $obj->count, 2, 'count is 2 (lazy init)' ); $obj->_clear_values; is_deeply( [ $obj->elements ], [ 42, 84 ], 'elements contains default with lazy init' ); $obj->_clear_values; $obj->push(2); is_deeply( $obj->_values, [ 42, 84, 2 ], 'push works with lazy init' ); $obj->_clear_values; $obj->unshift( 3, 4 ); is_deeply( $obj->_values, [ 3, 4, 42, 84 ], 'unshift works with lazy init' ); } } $class; } done_testing; MouseX-NativeTraits-1.09/t/070_native_traits/011_array_subtypes.t0000644€(NñY€ZÃ);0000001257712054627122027212 0ustar fuji.goroDENA\Domain Users#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; { use Any::Moose '::Util::TypeConstraints'; use List::Util qw(sum); subtype 'A1', as 'ArrayRef[Int]'; subtype 'A2', as 'ArrayRef', where { @$_ < 2 }; subtype 'A3', as 'ArrayRef[Int]', where { ( sum(@$_) || 0 ) < 5 }; subtype 'A5', as 'ArrayRef'; coerce 'A5', from 'Str', via { [ $_ ] }; } { package Foo; use Any::Moose; has array => ( traits => ['Array'], is => 'rw', isa => 'ArrayRef', handles => { push_array => 'push', }, ); has array_int => ( traits => ['Array'], is => 'rw', isa => 'ArrayRef[Int]', handles => { push_array_int => 'push', }, ); has a1 => ( traits => ['Array'], is => 'rw', isa => 'A1', handles => { push_a1 => 'push', }, ); has a2 => ( traits => ['Array'], is => 'rw', isa => 'A2', handles => { push_a2 => 'push', }, ); has a3 => ( traits => ['Array'], is => 'rw', isa => 'A3', handles => { push_a3 => 'push', }, ); has a4 => ( traits => ['Array'], is => 'rw', isa => 'ArrayRef', lazy => 1, default => 'invalid', clearer => '_clear_a4', handles => { get_a4 => 'get', push_a4 => 'push', accessor_a4 => 'accessor', }, ); has a5 => ( traits => ['Array'], is => 'rw', isa => 'A5', coerce => 1, lazy => 1, default => 'invalid', clearer => '_clear_a5', handles => { get_a5 => 'get', push_a5 => 'push', accessor_a5 => 'accessor', }, ); } my $foo = Foo->new; { $foo->array( [] ); is_deeply( $foo->array, [], "array - correct contents" ); $foo->push_array('foo'); is_deeply( $foo->array, ['foo'], "array - correct contents" ); } { $foo->array_int( [] ); is_deeply( $foo->array_int, [], "array_int - correct contents" ); isnt( exception { $foo->push_array_int('foo') }, undef, "array_int - can't push wrong type" ); is_deeply( $foo->array_int, [], "array_int - correct contents" ); $foo->push_array_int(1); is_deeply( $foo->array_int, [1], "array_int - correct contents" ); } { isnt( exception { $foo->push_a1('foo') }, undef, "a1 - can't push onto undef" ); $foo->a1( [] ); is_deeply( $foo->a1, [], "a1 - correct contents" ); isnt( exception { $foo->push_a1('foo') }, undef, "a1 - can't push wrong type" ); is_deeply( $foo->a1, [], "a1 - correct contents" ); $foo->push_a1(1); is_deeply( $foo->a1, [1], "a1 - correct contents" ); } { isnt( exception { $foo->push_a2('foo') }, undef, "a2 - can't push onto undef" ); $foo->a2( [] ); is_deeply( $foo->a2, [], "a2 - correct contents" ); $foo->push_a2('foo'); is_deeply( $foo->a2, ['foo'], "a2 - correct contents" ); isnt( exception { $foo->push_a2('bar') }, undef, "a2 - can't push more than one element" ); is_deeply( $foo->a2, ['foo'], "a2 - correct contents" ); } { isnt( exception { $foo->push_a3(1) }, undef, "a3 - can't push onto undef" ); $foo->a3( [] ); is_deeply( $foo->a3, [], "a3 - correct contents" ); isnt( exception { $foo->push_a3('foo') }, undef, "a3 - can't push non-int" ); isnt( exception { $foo->push_a3(100) }, undef, "a3 - can't violate overall type constraint" ); is_deeply( $foo->a3, [], "a3 - correct contents" ); $foo->push_a3(1); is_deeply( $foo->a3, [1], "a3 - correct contents" ); isnt( exception { $foo->push_a3(100) }, undef, "a3 - can't violate overall type constraint" ); is_deeply( $foo->a3, [1], "a3 - correct contents" ); $foo->push_a3(3); is_deeply( $foo->a3, [ 1, 3 ], "a3 - correct contents" ); } { my $expect = qr/\QAttribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value invalid/; like( exception { $foo->accessor_a4(0); }, $expect, 'invalid default is caught when trying to read via accessor' ); like( exception { $foo->accessor_a4( 0 => 42 ); }, $expect, 'invalid default is caught when trying to write via accessor' ); like( exception { $foo->push_a4(42); }, $expect, 'invalid default is caught when trying to push' ); like( exception { $foo->get_a4(42); }, $expect, 'invalid default is caught when trying to get' ); } { my $foo = Foo->new; is( $foo->accessor_a5(0), 'invalid', 'lazy default is coerced when trying to read via accessor' ); $foo->_clear_a5; $foo->accessor_a5( 1 => 'thing' ); is_deeply( $foo->a5, [ 'invalid', 'thing' ], 'lazy default is coerced when trying to write via accessor' ); $foo->_clear_a5; $foo->push_a5('thing'); is_deeply( $foo->a5, [ 'invalid', 'thing' ], 'lazy default is coerced when trying to push' ); $foo->_clear_a5; is( $foo->get_a5(0), 'invalid', 'lazy default is coerced when trying to get' ); } done_testing; MouseX-NativeTraits-1.09/t/070_native_traits/012_array_trigger.t0000644€(NñY€ZÃ);0000000146312054627122026770 0ustar fuji.goroDENA\Domain Usersuse strict; use warnings; use Test::More; { package Foo; use Mouse; our $Triggered = 0; has array => ( traits => ['Array'], is => 'rw', isa => 'ArrayRef', handles => { push_array => 'push', set_array => 'set', }, clearer => 'clear_array', trigger => sub { $Triggered++ }, ); } my $foo = Foo->new; { $foo->array( [ 1, 2, 3 ] ); is_deeply( $Foo::Triggered, 1, 'trigger was called for normal writer' ); $foo->push_array(5); is_deeply( $Foo::Triggered, 2, 'trigger was called on push' ); $foo->set_array( 1, 42 ); is_deeply( $Foo::Triggered, 3, 'trigger was called on set' ); } done_testing; MouseX-NativeTraits-1.09/t/070_native_traits/013_array_coerce.t0000644€(NñY€ZÃ);0000001102712054627122026563 0ustar fuji.goroDENA\Domain Usersuse strict; use warnings; use Test::More skip_all => 'Not supported by MouseX::NativeTraits'; use Test::More; use Test::Fatal; { package Foo; use Mouse; use Mouse::Util::TypeConstraints; subtype 'UCArray', as 'ArrayRef[Str]', where { !grep {/[a-z]/} @{$_}; }; coerce 'UCArray', from 'ArrayRef[Str]', via { [ map { uc $_ } @{$_} ]; }; has array => ( traits => ['Array'], is => 'rw', isa => 'UCArray', coerce => 1, handles => { push_array => 'push', set_array => 'set', }, ); our @TriggerArgs; has lazy => ( traits => ['Array'], is => 'rw', isa => 'UCArray', coerce => 1, lazy => 1, default => sub { ['a'] }, handles => { push_lazy => 'push', set_lazy => 'set', }, trigger => sub { @TriggerArgs = @_ }, clearer => 'clear_lazy', ); } my $foo = Foo->new; { $foo->array( [qw( A B C )] ); $foo->push_array('d'); is_deeply( $foo->array, [qw( A B C D )], 'push coerces the array' ); $foo->set_array( 1 => 'x' ); is_deeply( $foo->array, [qw( A X C D )], 'set coerces the array' ); } { $foo->push_lazy('d'); is_deeply( $foo->lazy, [qw( A D )], 'push coerces the array - lazy' ); is_deeply( \@Foo::TriggerArgs, [ $foo, [qw( A D )], ['A'] ], 'trigger receives expected arguments' ); $foo->set_lazy( 2 => 'f' ); is_deeply( $foo->lazy, [qw( A D F )], 'set coerces the array - lazy' ); is_deeply( \@Foo::TriggerArgs, [ $foo, [qw( A D F )], [qw( A D )] ], 'trigger receives expected arguments' ); } { package Thing; use Mouse; has thing => ( is => 'ro', isa => 'Int', ); } { package Bar; use Mouse; use Mouse::Util::TypeConstraints; class_type 'Thing'; coerce 'Thing' => from 'Int' => via { Thing->new( thing => $_ ) }; subtype 'ArrayRefOfThings' => as 'ArrayRef[Thing]'; coerce 'ArrayRefOfThings' => from 'ArrayRef[Int]' => via { [ map { Thing->new( thing => $_ ) } @{$_} ] }; coerce 'ArrayRefOfThings' => from 'Int' => via { [ Thing->new( thing => $_ ) ] }; has array => ( traits => ['Array'], is => 'rw', isa => 'ArrayRefOfThings', coerce => 1, handles => { push_array => 'push', unshift_array => 'unshift', set_array => 'set', insert_array => 'insert', }, ); } { my $bar = Bar->new( array => [ 1, 2, 3 ] ); $bar->push_array( 4, 5 ); is_deeply( [ map { $_->thing } @{ $bar->array } ], [ 1, 2, 3, 4, 5 ], 'push coerces new members' ); $bar->unshift_array( -1, 0 ); is_deeply( [ map { $_->thing } @{ $bar->array } ], [ -1, 0, 1, 2, 3, 4, 5 ], 'unshift coerces new members' ); $bar->set_array( 3 => 9 ); is_deeply( [ map { $_->thing } @{ $bar->array } ], [ -1, 0, 1, 9, 3, 4, 5 ], 'set coerces new members' ); $bar->insert_array( 3 => 42 ); is_deeply( [ map { $_->thing } @{ $bar->array } ], [ -1, 0, 1, 42, 9, 3, 4, 5 ], 'insert coerces new members' ); } { package Baz; use Mouse; use Mouse::Util::TypeConstraints; subtype 'SmallArrayRef' => as 'ArrayRef' => where { @{$_} <= 2 }; coerce 'SmallArrayRef' => from 'ArrayRef' => via { [ @{$_}[ -2, -1 ] ] }; has array => ( traits => ['Array'], is => 'rw', isa => 'SmallArrayRef', coerce => 1, handles => { push_array => 'push', set_array => 'set', insert_array => 'insert', }, ); } { my $baz = Baz->new( array => [ 1, 2, 3 ] ); is_deeply( $baz->array, [ 2, 3 ], 'coercion truncates array ref in constructor' ); $baz->push_array(4); is_deeply( $baz->array, [ 3, 4 ], 'coercion truncates array ref on push' ); $baz->insert_array( 1 => 5 ); is_deeply( $baz->array, [ 5, 4 ], 'coercion truncates array ref on insert' ); $baz->push_array( 7, 8, 9 ); is_deeply( $baz->array, [ 8, 9 ], 'coercion truncates array ref on push' ); } done_testing; MouseX-NativeTraits-1.09/t/070_native_traits/020_trait_bool.t0000644€(NñY€ZÃ);0000000554012054627122026264 0ustar fuji.goroDENA\Domain Users#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Any::Moose (); use Any::Moose '::Util::TypeConstraints'; BEGIN { eval 'use Test::' . any_moose(); } { my %handles = ( illuminate => 'set', darken => 'unset', flip_switch => 'toggle', is_dark => 'not', ); my $name = 'Foo1'; sub build_class { my %attr = @_; my $class = any_moose('::Meta::Class')->create( $name++, superclasses => [any_moose '::Object'], ); my @traits = 'Bool'; push @traits, 'NoInlineAttribute' if delete $attr{no_inline}; $class->add_attribute( is_lit => ( traits => \@traits, is => 'rw', isa => 'Bool', default => 0, handles => \%handles, clearer => '_clear_is_list', %attr, ), ); return ( $class->name, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); #run_tests( build_class( no_inline => 1 ) ); # Will force the inlining code to check the entire hashref when it is modified. subtype 'MyBool', as 'Bool', where { 1 }; run_tests( build_class( isa => 'MyBool' ) ); coerce 'MyBool', from 'Bool', via { $_ }; run_tests( build_class( isa => 'MyBool', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new; ok( $obj->illuminate, 'set returns true' ); ok( $obj->is_lit, 'set is_lit to 1 using ->illuminate' ); ok( !$obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->illuminate(1) }, qr/Cannot call set with any arguments/, 'set throws an error when an argument is passed' ); ok( !$obj->darken, 'unset returns false' ); ok( !$obj->is_lit, 'set is_lit to 0 using ->darken' ); ok( $obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->darken(1) }, qr/Cannot call unset with any arguments/, 'unset throws an error when an argument is passed' ); ok( $obj->flip_switch, 'toggle returns new value' ); ok( $obj->is_lit, 'toggle is_lit back to 1 using ->flip_switch' ); ok( !$obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->flip_switch(1) }, qr/Cannot call toggle with any arguments/, 'toggle throws an error when an argument is passed' ); $obj->flip_switch; ok( !$obj->is_lit, 'toggle is_lit back to 0 again using ->flip_switch' ); ok( $obj->is_dark, 'check if is_dark does the right thing' ); } $class; } done_testing; MouseX-NativeTraits-1.09/t/070_native_traits/030_trait_code.t0000644€(NñY€ZÃ);0000000515012054627122026241 0ustar fuji.goroDENA\Domain Usersuse strict; use warnings; use Test::More; use Test::Fatal; use Any::Moose (); use Any::Moose '::Util::TypeConstraints'; BEGIN { eval 'use Test::' . any_moose(); } { my $name = 'Foo1'; sub build_class { my ( $attr1, $attr2, $attr3, $no_inline ) = @_; my $class = any_moose('::Meta::Class')->create( $name++, superclasses => [any_moose '::Object'], ); my @traits = 'Code'; push @traits, 'NoInlineAttribute' if $no_inline; $class->add_attribute( callback => ( traits => \@traits, isa => 'CodeRef', required => 1, handles => { 'invoke_callback' => 'execute' }, %{ $attr1 || {} }, ) ); $class->add_attribute( callback_method => ( traits => \@traits, isa => 'CodeRef', required => 1, handles => { 'invoke_method_callback' => 'execute_method' }, %{ $attr2 || {} }, ) ); $class->add_attribute( multiplier => ( traits => \@traits, isa => 'CodeRef', required => 1, handles => { 'multiply' => 'execute' }, %{ $attr3 || {} }, ) ); return $class->name; } } { my $i; my %subs = ( callback => sub { ++$i }, callback_method => sub { shift->multiply(@_) }, multiplier => sub { $_[0] * 2 }, ); run_tests( build_class, \$i, \%subs ); #run_tests( build_class( undef, undef, undef, 1 ), \$i, \%subs ); run_tests( build_class( { lazy => 1, default => sub { $subs{callback} } }, { lazy => 1, default => sub { $subs{callback_method} } }, { lazy => 1, default => sub { $subs{multiplier} } }, ), \$i, ); } sub run_tests { my ( $class, $iref, @args ) = @_; ok( !$class->can($_), "Code trait didn't create reader method for $_" ) for qw(callback callback_method multiplier); with_immutable { ${$iref} = 0; my $obj = $class->new(@args); $obj->invoke_callback; is( ${$iref}, 1, '$i is 1 after invoke_callback' ); is( $obj->invoke_method_callback(3), 6, 'invoke_method_callback calls multiply with @_' ); is( $obj->multiply(3), 6, 'multiple double value' ); } $class; } done_testing; MouseX-NativeTraits-1.09/t/070_native_traits/040_trait_counter.t0000644€(NñY€ZÃ);0000000754412054627122027020 0ustar fuji.goroDENA\Domain Users#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Any::Moose (); use Any::Moose '::Util::TypeConstraints'; BEGIN { eval 'use Test::' . any_moose(); } { my %handles = ( inc_counter => 'inc', inc_counter_2 => [ inc => 2 ], dec_counter => 'dec', dec_counter_2 => [ dec => 2 ], reset_counter => 'reset', set_counter => 'set', set_counter_42 => [ set => 42 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my $class = any_moose('::Meta::Class')->create( $name++, superclasses => [any_moose '::Object'], ); my @traits = 'Counter'; push @traits, 'NoInlineAttribute' if delete $attr{no_inline}; $class->add_attribute( counter => ( traits => \@traits, is => 'ro', isa => 'Int', default => 0, handles => \%handles, clearer => '_clear_counter', %attr, ), ); return ( $class->name, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); #run_tests( build_class( no_inline => 1 ) ); # Will force the inlining code to check the entire hashref when it is modified. subtype 'MyInt', as 'Int', where { 1 }; run_tests( build_class( isa => 'MyInt' ) ); coerce 'MyInt', from 'Int', via { $_ }; run_tests( build_class( isa => 'MyInt', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new(); is( $obj->counter, 0, '... got the default value' ); is( $obj->inc_counter, 1, 'inc returns new value' ); is( $obj->counter, 1, '... got the incremented value' ); is( $obj->inc_counter, 2, 'inc returns new value' ); is( $obj->counter, 2, '... got the incremented value (again)' ); like( exception { $obj->inc_counter( 1, 2 ) }, qr/Cannot call inc with more than 1 argument/, 'inc throws an error when two arguments are passed' ); is( $obj->dec_counter, 1, 'dec returns new value' ); is( $obj->counter, 1, '... got the decremented value' ); like( exception { $obj->dec_counter( 1, 2 ) }, qr/Cannot call dec with more than 1 argument/, 'dec throws an error when two arguments are passed' ); is( $obj->reset_counter, 0, 'reset returns new value' ); is( $obj->counter, 0, '... got the original value' ); like( exception { $obj->reset_counter(2) }, qr/Cannot call reset with any arguments/, 'reset throws an error when an argument is passed' ); is( $obj->set_counter(5), 5, 'set returns new value' ); is( $obj->counter, 5, '... set the value' ); like( exception { $obj->set_counter( 1, 2 ) }, qr/Cannot call set with more than 1 argument/, 'set throws an error when two arguments are passed' ); $obj->inc_counter(2); is( $obj->counter, 7, '... increment by arg' ); $obj->dec_counter(5); is( $obj->counter, 2, '... decrement by arg' ); $obj->inc_counter_2; is( $obj->counter, 4, '... curried increment' ); $obj->dec_counter_2; is( $obj->counter, 2, '... curried deccrement' ); $obj->set_counter_42; is( $obj->counter, 42, '... curried set' ); if ( $class->meta->get_attribute('counter')->is_lazy ) { my $obj = $class->new; $obj->inc_counter; is( $obj->counter, 1, 'inc increments - with lazy default' ); $obj->_clear_counter; $obj->dec_counter; is( $obj->counter, -1, 'dec decrements - with lazy default' ); } } $class; } done_testing; MouseX-NativeTraits-1.09/t/070_native_traits/050_trait_hash.t0000644€(NñY€ZÃ);0000002004312054627122026252 0ustar fuji.goroDENA\Domain Users#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Any::Moose (); use Any::Moose '::Util::TypeConstraints'; BEGIN { eval 'use Test::' . any_moose(); } { my %handles = ( option_accessor => 'accessor', quantity => [ accessor => 'quantity' ], clear_options => 'clear', num_options => 'count', delete_option => 'delete', is_defined => 'defined', options_elements => 'elements', has_option => 'exists', get_option => 'get', has_no_options => 'is_empty', keys => 'keys', values => 'values', key_value => 'kv', set_option => 'set', ); my $name = 'Foo1'; sub build_class { my %attr = @_; my $class = any_moose('::Meta::Class')->create( $name++, superclasses => [any_moose '::Object'], ); my @traits = 'Hash'; push @traits, 'NoInlineAttribute' if delete $attr{no_inline}; $class->add_attribute( options => ( traits => \@traits, is => 'rw', isa => 'HashRef[Str]', default => sub { {} }, handles => \%handles, clearer => '_clear_options', %attr, ), ); return ( $class->name, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1, default => sub { { x => 1 } } ) ); run_tests( build_class( trigger => sub { } ) ); #run_tests( build_class( no_inline => 1 ) ); # Will force the inlining code to check the entire hashref when it is modified. subtype 'MyHashRef', as 'HashRef[Str]', where { 1 }; run_tests( build_class( isa => 'MyHashRef' ) ); coerce 'MyHashRef', from 'HashRef', via { $_ }; run_tests( build_class( isa => 'MyHashRef', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new( options => {} ); ok( $obj->has_no_options, '... we have no options' ); is( $obj->num_options, 0, '... we have no options' ); is_deeply( $obj->options, {}, '... no options yet' ); ok( !$obj->has_option('foo'), '... we have no foo option' ); is( exception { is( $obj->set_option( foo => 'bar' ), 'bar', 'set return single new value in scalar context' ); }, undef, '... set the option okay' ); ok( $obj->is_defined('foo'), '... foo is defined' ); ok( !$obj->has_no_options, '... we have options' ); is( $obj->num_options, 1, '... we have 1 option(s)' ); ok( $obj->has_option('foo'), '... we have a foo option' ); is_deeply( $obj->options, { foo => 'bar' }, '... got options now' ); is( exception { $obj->set_option( bar => 'baz' ); }, undef, '... set the option okay' ); is( $obj->num_options, 2, '... we have 2 option(s)' ); is_deeply( $obj->options, { foo => 'bar', bar => 'baz' }, '... got more options now' ); is( $obj->get_option('foo'), 'bar', '... got the right option' ); is_deeply( [ $obj->get_option(qw(foo bar)) ], [qw(bar baz)], "get multiple options at once" ); is( scalar( $obj->get_option(qw( foo bar)) ), "baz", '... got last option in scalar context' ); is( exception { $obj->set_option( oink => "blah", xxy => "flop" ); }, undef, '... set the option okay' ); is( $obj->num_options, 4, "4 options" ); is_deeply( [ $obj->get_option(qw(foo bar oink xxy)) ], [qw(bar baz blah flop)], "get multiple options at once" ); is( exception { is( scalar $obj->delete_option('bar'), 'baz', 'delete returns deleted value' ); }, undef, '... deleted the option okay' ); is( exception { is_deeply( [ $obj->delete_option( 'oink', 'xxy' ) ], [ 'blah', 'flop' ], 'delete returns all deleted values in list context' ); }, undef, '... deleted multiple option okay' ); is( $obj->num_options, 1, '... we have 1 option(s)' ); is_deeply( $obj->options, { foo => 'bar' }, '... got more options now' ); $obj->clear_options; is_deeply( $obj->options, {}, "... cleared options" ); is( exception { $obj->quantity(4); }, undef, '... options added okay with defaults' ); is( $obj->quantity, 4, 'reader part of curried accessor works' ); is( $obj->option_accessor('quantity'), 4, 'accessor as reader' ); is_deeply( $obj->options, { quantity => 4 }, '... returns what we expect' ); $obj->option_accessor( size => 42 ); like( exception { $obj->option_accessor; }, qr/Cannot call accessor without at least 1 argument/, 'error when calling accessor with no arguments' ); is_deeply( $obj->options, { quantity => 4, size => 42 }, 'accessor as writer' ); is( exception { $class->new( options => { foo => 'BAR' } ); }, undef, '... good constructor params' ); isnt( exception { $obj->set_option( bar => {} ); }, undef, '... could not add a hash ref where an string is expected' ); isnt( exception { $class->new( options => { foo => [] } ); }, undef, '... bad constructor params' ); $obj->options( {} ); is_deeply( [ $obj->set_option( oink => "blah", xxy => "flop" ) ], [ 'blah', 'flop' ], 'set returns newly set values in order of keys provided' ); is_deeply( [ sort $obj->keys ], [ 'oink', 'xxy' ], 'keys returns expected keys' ); is_deeply( [ sort $obj->values ], [ 'blah', 'flop' ], 'values returns expected values' ); my @key_value = sort { $a->[0] cmp $b->[0] } $obj->key_value; is_deeply( \@key_value, [ sort { $a->[0] cmp $b->[0] }[ 'xxy', 'flop' ], [ 'oink', 'blah' ] ], '... got the right key value pairs' ) or do { require Data::Dumper; diag( Data::Dumper::Dumper( \@key_value ) ); }; my %options_elements = $obj->options_elements; is_deeply( \%options_elements, { 'oink' => 'blah', 'xxy' => 'flop' }, '... got the right hash elements' ); if ( $class->meta->get_attribute('options')->is_lazy ) { my $obj = $class->new; $obj->set_option( y => 2 ); is_deeply( $obj->options, { x => 1, y => 2 }, 'set_option with lazy default' ); $obj->_clear_options; ok( $obj->has_option('x'), 'key for x exists - lazy default' ); $obj->_clear_options; ok( $obj->is_defined('x'), 'key for x is defined - lazy default' ); $obj->_clear_options; is_deeply( [ $obj->key_value ], [ [ x => 1 ] ], 'kv returns lazy default' ); $obj->_clear_options; $obj->option_accessor( y => 2 ); is_deeply( [ sort $obj->keys ], [ 'x', 'y' ], 'accessor triggers lazy default generator' ); } } $class; } done_testing; MouseX-NativeTraits-1.09/t/070_native_traits/051_hash_subtypes.t0000644€(NñY€ZÃ);0000001147312054627122027015 0ustar fuji.goroDENA\Domain Users#!/usr/bin/env perl use strict; use warnings; use Test::More; use Test::Fatal; { use Mouse::Util::TypeConstraints; use List::Util qw( sum ); subtype 'H1', as 'HashRef[Int]'; subtype 'H2', as 'HashRef', where { scalar keys %{$_} < 2 }; subtype 'H3', as 'HashRef[Int]', where { ( sum( values %{$_} ) || 0 ) < 5 }; subtype 'H5', as 'HashRef'; coerce 'H5', from 'Str', via { { key => $_ } }; no Mouse::Util::TypeConstraints; } { package Foo; use Mouse; has hash_int => ( traits => ['Hash'], is => 'rw', isa => 'HashRef[Int]', handles => { set_hash_int => 'set', }, ); has h1 => ( traits => ['Hash'], is => 'rw', isa => 'H1', handles => { set_h1 => 'set', }, ); has h2 => ( traits => ['Hash'], is => 'rw', isa => 'H2', handles => { set_h2 => 'set', }, ); has h3 => ( traits => ['Hash'], is => 'rw', isa => 'H3', handles => { set_h3 => 'set', }, ); has h4 => ( traits => ['Hash'], is => 'rw', isa => 'HashRef', lazy => 1, default => 'invalid', clearer => '_clear_h4', handles => { get_h4 => 'get', accessor_h4 => 'accessor', }, ); has h5 => ( traits => ['Hash'], is => 'rw', isa => 'H5', coerce => 1, lazy => 1, default => 'invalid', clearer => '_clear_h5', handles => { get_h5 => 'get', accessor_h5 => 'accessor', }, ); } my $foo = Foo->new; { $foo->hash_int( {} ); is_deeply( $foo->hash_int, {}, "hash_int - correct contents" ); isnt( exception { $foo->set_hash_int( x => 'foo' ) }, undef, "hash_int - can't set wrong type" ); is_deeply( $foo->hash_int, {}, "hash_int - correct contents" ); $foo->set_hash_int( x => 1 ); is_deeply( $foo->hash_int, { x => 1 }, "hash_int - correct contents" ); } { isnt( exception { $foo->set_h1('foo') }, undef, "h1 - can't set onto undef" ); $foo->h1( {} ); is_deeply( $foo->h1, {}, "h1 - correct contents" ); isnt( exception { $foo->set_h1( x => 'foo' ) }, undef, "h1 - can't set wrong type" ); is_deeply( $foo->h1, {}, "h1 - correct contents" ); $foo->set_h1( x => 1 ); is_deeply( $foo->h1, { x => 1 }, "h1 - correct contents" ); } { isnt( exception { $foo->set_h2('foo') }, undef, "h2 - can't set onto undef" ); $foo->h2( {} ); is_deeply( $foo->h2, {}, "h2 - correct contents" ); $foo->set_h2( x => 'foo' ); is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" ); isnt( exception { $foo->set_h2( y => 'bar' ) }, undef, "h2 - can't set more than one element" ); is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" ); } { isnt( exception { $foo->set_h3(1) }, undef, "h3 - can't set onto undef" ); $foo->h3( {} ); is_deeply( $foo->h3, {}, "h3 - correct contents" ); isnt( exception { $foo->set_h3( x => 'foo' ) }, undef, "h3 - can't set non-int" ); isnt( exception { $foo->set_h3( x => 100 ) }, undef, "h3 - can't violate overall type constraint" ); is_deeply( $foo->h3, {}, "h3 - correct contents" ); $foo->set_h3( x => 1 ); is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" ); isnt( exception { $foo->set_h3( x => 100 ) }, undef, "h3 - can't violate overall type constraint" ); is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" ); $foo->set_h3( y => 3 ); is_deeply( $foo->h3, { x => 1, y => 3 }, "h3 - correct contents" ); } { my $expect = qr/\QAttribute (h4) does not pass the type constraint because: Validation failed for 'HashRef' with value invalid/; like( exception { $foo->accessor_h4('key'); }, $expect, 'invalid default is caught when trying to read via accessor' ); like( exception { $foo->accessor_h4( size => 42 ); }, $expect, 'invalid default is caught when trying to write via accessor' ); like( exception { $foo->get_h4(42); }, $expect, 'invalid default is caught when trying to get' ); } { my $foo = Foo->new; is( $foo->accessor_h5('key'), 'invalid', 'lazy default is coerced when trying to read via accessor' ); $foo->_clear_h5; $foo->accessor_h5( size => 42 ); is_deeply( $foo->h5, { key => 'invalid', size => 42 }, 'lazy default is coerced when trying to write via accessor' ); $foo->_clear_h5; is( $foo->get_h5('key'), 'invalid', 'lazy default is coerced when trying to get' ); } done_testing; MouseX-NativeTraits-1.09/t/070_native_traits/052_hash_trigger.t0000644€(NñY€ZÃ);0000000147212054627122026601 0ustar fuji.goroDENA\Domain Usersuse strict; use warnings; use Test::More; { package Foo; use Mouse; our $Triggered = 0; has hash => ( traits => ['Hash'], is => 'rw', isa => 'HashRef', handles => { delete_key => 'delete', set_key => 'set', }, clearer => 'clear_key', trigger => sub { $Triggered++ }, ); } my $foo = Foo->new; { $foo->hash( { x => 1, y => 2 } ); is_deeply( $Foo::Triggered, 1, 'trigger was called for normal writer' ); $foo->set_key( z => 5 ); is_deeply( $Foo::Triggered, 2, 'trigger was called on set' ); $foo->delete_key('y'); is_deeply( $Foo::Triggered, 3, 'trigger was called on delete' ); } done_testing; MouseX-NativeTraits-1.09/t/070_native_traits/053_hash_coerce.t0000644€(NñY€ZÃ);0000000536312054627122026402 0ustar fuji.goroDENA\Domain Usersuse strict; use warnings; use Test::More skip_all => 'Not supported by MouseX::NativeTraits'; use Test::More; { package Foo; use Mouse; use Mouse::Util::TypeConstraints; subtype 'UCHash', as 'HashRef[Str]', where { !grep {/[a-z]/} values %{$_}; }; coerce 'UCHash', from 'HashRef[Str]', via { $_ = uc $_ for values %{$_}; $_; }; has hash => ( traits => ['Hash'], is => 'rw', isa => 'UCHash', coerce => 1, handles => { set_key => 'set', }, ); our @TriggerArgs; has lazy => ( traits => ['Hash'], is => 'rw', isa => 'UCHash', coerce => 1, lazy => 1, default => sub { { x => 'a' } }, handles => { set_lazy => 'set', }, trigger => sub { @TriggerArgs = @_ }, clearer => 'clear_lazy', ); } my $foo = Foo->new; { $foo->hash( { x => 'A', y => 'B' } ); $foo->set_key( z => 'c' ); is_deeply( $foo->hash, { x => 'A', y => 'B', z => 'C' }, 'set coerces the hash' ); } { $foo->set_lazy( y => 'b' ); is_deeply( $foo->lazy, { x => 'A', y => 'B' }, 'set coerces the hash - lazy' ); is_deeply( \@Foo::TriggerArgs, [ $foo, { x => 'A', y => 'B' }, { x => 'A' } ], 'trigger receives expected arguments' ); } { package Thing; use Mouse; has thing => ( is => 'ro', isa => 'Str', ); } { package Bar; use Mouse; use Mouse::Util::TypeConstraints; class_type 'Thing'; coerce 'Thing' => from 'Str' => via { Thing->new( thing => $_ ) }; subtype 'HashRefOfThings' => as 'HashRef[Thing]'; coerce 'HashRefOfThings' => from 'HashRef[Str]' => via { my %new; for my $k ( keys %{$_} ) { $new{$k} = Thing->new( thing => $_->{$k} ); } return \%new; }; coerce 'HashRefOfThings' => from 'Str' => via { [ Thing->new( thing => $_ ) ] }; has hash => ( traits => ['Hash'], is => 'rw', isa => 'HashRefOfThings', coerce => 1, handles => { set_hash => 'set', get_hash => 'get', }, ); } { my $bar = Bar->new( hash => { foo => 1, bar => 2 } ); is( $bar->get_hash('foo')->thing, 1, 'constructor coerces hash reference' ); $bar->set_hash( baz => 3, quux => 4 ); is( $bar->get_hash('baz')->thing, 3, 'set coerces new hash values' ); is( $bar->get_hash('quux')->thing, 4, 'set coerces new hash values' ); } done_testing; MouseX-NativeTraits-1.09/t/070_native_traits/060_trait_number.t0000644€(NñY€ZÃ);0000001101312054627122026615 0ustar fuji.goroDENA\Domain Users#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Any::Moose (); use Any::Moose '::Util::TypeConstraints'; BEGIN { eval 'use Test::' . any_moose(); } { my $any_moose_is_mouse = any_moose() eq 'Mouse'; my %handles = ( abs => 'abs', add => 'add', inc => [ add => 1 ], div => 'div', cut_in_half => [ div => 2 ], mod => 'mod', odd => [ mod => 2 ], mul => 'mul', #set => 'set', sub => 'sub', dec => [ sub => 1 ], ); if(!$any_moose_is_mouse) { $handles{set} = 'set'; } my $name = 'Foo1'; sub build_class { my %attr = @_; my $class = any_moose('::Meta::Class')->create( $name++, superclasses => [any_moose '::Object'], ); my @traits = 'Number'; push @traits, 'NoInlineAttribute' if delete $attr{no_inline}; $class->add_attribute( integer => ( traits => \@traits, is => 'ro', isa => 'Int', default => 5, handles => \%handles, ($any_moose_is_mouse ? (writer => 'set') : ()), clearer => '_clear_integer', %attr, ), ); return ( $class->name, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); #run_tests( build_class( no_inline => 1 ) ); # Will force the inlining code to check the entire hashref when it is modified. subtype 'MyInt', as 'Int', where { 1 }; run_tests( build_class( isa => 'MyInt' ) ); coerce 'MyInt', from 'Int', via { $_ }; run_tests( build_class( isa => 'MyInt', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new; is( $obj->integer, 5, 'Default to five' ); is( $obj->add(10), 15, 'add returns new value' ); is( $obj->integer, 15, 'Add ten for fithteen' ); like( exception { $obj->add( 10, 2 ) }, qr/Cannot call add with more than 1 argument/, 'add throws an error when 2 arguments are passed' ); is( $obj->sub(3), 12, 'sub returns new value' ); is( $obj->integer, 12, 'Subtract three for 12' ); like( exception { $obj->sub( 10, 2 ) }, qr/Cannot call sub with more than 1 argument/, 'sub throws an error when 2 arguments are passed' ); is( $obj->set(10), 10, 'set returns new value' ); is( $obj->integer, 10, 'Set to ten' ); isnt exception { $obj->set(10, 2) }, undef; # XXX: Mouse specific #like( exception { $obj->set( 10, 2 ) }, qr/Cannot call set with more than 1 argument/, 'set throws an error when 2 arguments are passed' ); is( $obj->div(2), 5, 'div returns new value' ); is( $obj->integer, 5, 'divide by 2' ); like( exception { $obj->div( 10, 2 ) }, qr/Cannot call div with more than 1 argument/, 'div throws an error when 2 arguments are passed' ); is( $obj->mul(2), 10, 'mul returns new value' ); is( $obj->integer, 10, 'multiplied by 2' ); like( exception { $obj->mul( 10, 2 ) }, qr/Cannot call mul with more than 1 argument/, 'mul throws an error when 2 arguments are passed' ); is( $obj->mod(2), 0, 'mod returns new value' ); is( $obj->integer, 0, 'Mod by 2' ); like( exception { $obj->mod( 10, 2 ) }, qr/Cannot call mod with more than 1 argument/, 'mod throws an error when 2 arguments are passed' ); $obj->set(7); $obj->mod(5); is( $obj->integer, 2, 'Mod by 5' ); $obj->set(-1); is( $obj->abs, 1, 'abs returns new value' ); like( exception { $obj->abs(10) }, qr/Cannot call abs with any arguments/, 'abs throws an error when an argument is passed' ); is( $obj->integer, 1, 'abs 1' ); $obj->set(12); $obj->inc; is( $obj->integer, 13, 'inc 12' ); $obj->dec; is( $obj->integer, 12, 'dec 13' ); if ( $class->meta->get_attribute('integer')->is_lazy ) { my $obj = $class->new; $obj->add(2); is( $obj->integer, 7, 'add with lazy default' ); $obj->_clear_integer; $obj->mod(2); is( $obj->integer, 1, 'mod with lazy default' ); } } $class; } done_testing; MouseX-NativeTraits-1.09/t/070_native_traits/070_trait_string.t0000644€(NñY€ZÃ);0000002342112054627122026642 0ustar fuji.goroDENA\Domain Users#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Any::Moose (); use Any::Moose '::Util::TypeConstraints'; BEGIN { eval 'use Test::' . any_moose(); } { my %handles = ( inc => 'inc', append => 'append', append_curried => [ append => '!' ], prepend => 'prepend', prepend_curried => [ prepend => '-' ], replace => 'replace', replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], chop => 'chop', chomp => 'chomp', clear => 'clear', match => 'match', match_curried => [ match => qr/\D/ ], length => 'length', substr => 'substr', substr_curried_1 => [ substr => (1) ], substr_curried_2 => [ substr => ( 1, 3 ) ], substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my $class = any_moose('::Meta::Class')->create( $name++, superclasses => [any_moose '::Object'], ); my @traits = 'String'; push @traits, 'NoInlineAttribute' if delete $attr{no_inline}; $class->add_attribute( _string => ( traits => \@traits, is => 'rw', isa => 'Str', default => q{}, handles => \%handles, clearer => '_clear_string', %attr, ), ); return ( $class->name, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1, default => q{} ) ); run_tests( build_class( trigger => sub { } ) ); #run_tests( build_class( no_inline => 1 ) ); # Will force the inlining code to check the entire hashref when it is modified. subtype 'MyStr', as 'Str', where { 1 }; run_tests( build_class( isa => 'MyStr' ) ); coerce 'MyStr', from 'Str', via { $_ }; run_tests( build_class( isa => 'MyStr', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new(); is( $obj->length, 0, 'length returns zero' ); $obj->_string('a'); is( $obj->length, 1, 'length returns 1 for new string' ); like( exception { $obj->length(42) }, qr/Cannot call length with any arguments/, 'length throws an error when an argument is passed' ); is( $obj->inc, 'b', 'inc returns new value' ); is( $obj->_string, 'b', 'a becomes b after inc' ); like( exception { $obj->inc(42) }, qr/Cannot call inc with any arguments/, 'inc throws an error when an argument is passed' ); is( $obj->append('foo'), 'bfoo', 'append returns new value' ); is( $obj->_string, 'bfoo', 'appended to the string' ); like( exception { $obj->append( 'foo', 2 ) }, qr/Cannot call append with more than 1 argument/, 'append throws an error when two arguments are passed' ); $obj->append_curried; is( $obj->_string, 'bfoo!', 'append_curried appended to the string' ); like( exception { $obj->append_curried('foo') }, qr/Cannot call append with more than 1 argument/, 'append_curried throws an error when two arguments are passed' ); $obj->_string("has nl$/"); is( $obj->chomp, 1, 'chomp returns number of characters removed' ); is( $obj->_string, 'has nl', 'chomped string' ); is( $obj->chomp, 0, 'chomp returns number of characters removed' ); is( $obj->_string, 'has nl', 'chomp is a no-op when string has no line ending' ); like( exception { $obj->chomp(42) }, qr/Cannot call chomp with any arguments/, 'chomp throws an error when an argument is passed' ); is( $obj->chop, 'l', 'chop returns character removed' ); is( $obj->_string, 'has n', 'chopped string' ); like( exception { $obj->chop(42) }, qr/Cannot call chop with any arguments/, 'chop throws an error when an argument is passed' ); $obj->_string('x'); is( $obj->prepend('bar'), 'barx', 'prepend returns new value' ); is( $obj->_string, 'barx', 'prepended to string' ); $obj->prepend_curried; is( $obj->_string, '-barx', 'prepend_curried prepended to string' ); is( $obj->replace( qr/([ao])/, sub { uc($1) } ), '-bArx', 'replace returns new value' ); is( $obj->_string, '-bArx', 'substitution using coderef for replacement' ); $obj->replace( qr/A/, 'X' ); is( $obj->_string, '-bXrx', 'substitution using string as replacement' ); $obj->_string('foo'); $obj->replace( qr/oo/, q{} ); is( $obj->_string, 'f', 'replace accepts an empty string as second argument' ); $obj->replace( q{}, 'a' ); is( $obj->_string, 'af', 'replace accepts an empty string as first argument' ); like( exception { $obj->replace( {}, 'x' ) }, qr/The first argument passed to replace must be a string or regexp reference/, 'replace throws an error when the first argument is not a string or regexp' ); like( exception { $obj->replace( qr/x/, {} ) }, qr/The second argument passed to replace must be a string or code reference/, 'replace throws an error when the first argument is not a string or regexp' ); $obj->_string('Mousex'); $obj->replace_curried; is( $obj->_string, 'MouseX', 'capitalize last' ); $obj->_string('abcdef'); is_deeply( [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], 'match -barx against /[aq]/ returns matches' ); is_deeply( [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], 'match -barx against /[aq]/ returns matches' ); ok( scalar $obj->match('b'), 'match with string as argument returns true' ); ok( scalar $obj->match(q{}), 'match with empty string as argument returns true' ); like( exception { $obj->match }, qr/Cannot call match without at least 1 argument/, 'match throws an error when no arguments are passed' ); like( exception { $obj->match( {} ) }, qr/The argument passed to match must be a string or regexp reference/, 'match throws an error when an invalid argument is passed' ); $obj->_string('1234'); ok( !$obj->match_curried, 'match_curried returns false' ); $obj->_string('one two three four'); ok( $obj->match_curried, 'match curried returns true' ); $obj->clear; is( $obj->_string, q{}, 'clear' ); like( exception { $obj->clear(42) }, qr/Cannot call clear with any arguments/, 'clear throws an error when an argument is passed' ); $obj->_string('some long string'); is( $obj->substr(1), 'ome long string', 'substr as getter with one argument' ); $obj->_string('some long string'); is( $obj->substr( 1, 3 ), 'ome', 'substr as getter with two arguments' ); is( $obj->substr( 1, 3, 'ong' ), 'ome', 'substr as setter returns replaced string' ); is( $obj->_string, 'song long string', 'substr as setter with three arguments' ) or diag $obj->dump; $obj->substr( 1, 3, '' ); is( $obj->_string, 's long string', 'substr as setter with three arguments, replacment is empty string' ); like( exception { $obj->substr }, qr/Cannot call substr without at least 1 argument/, 'substr throws an error when no argumemts are passed' ); like( exception { $obj->substr( 1, 2, 3, 4 ) }, qr/Cannot call substr with more than 3 arguments/, 'substr throws an error when four argumemts are passed' ); like( exception { $obj->substr( {} ) }, qr/The first argument passed to substr must be an integer/, 'substr throws an error when first argument is not an integer' ); like( exception { $obj->substr( 1, {} ) }, qr/The second argument passed to substr must be an integer/, 'substr throws an error when second argument is not an integer' ); like( exception { $obj->substr( 1, 2, {} ) }, qr/The third argument passed to substr must be a string/, 'substr throws an error when third argument is not a string' ); $obj->_string('some long string'); is( $obj->substr_curried_1, 'ome long string', 'substr_curried_1 returns expected value' ); is( $obj->substr_curried_1(3), 'ome', 'substr_curried_1 with one argument returns expected value' ); $obj->substr_curried_1( 3, 'ong' ); is( $obj->_string, 'song long string', 'substr_curried_1 as setter with two arguments' ); $obj->_string('some long string'); is( $obj->substr_curried_2, 'ome', 'substr_curried_2 returns expected value' ); $obj->substr_curried_2('ong'); is( $obj->_string, 'song long string', 'substr_curried_2 as setter with one arguments' ); $obj->_string('some long string'); $obj->substr_curried_3; is( $obj->_string, 'song long string', 'substr_curried_3 as setter' ); if ( $class->meta->get_attribute('_string')->is_lazy ) { my $obj = $class->new; $obj->append('foo'); is( $obj->_string, 'foo', 'append with lazy default' ); } } $class; } done_testing; MouseX-NativeTraits-1.09/t/070_native_traits/100_array_from_role.t0000644€(NñY€ZÃ);0000000143112054627122027302 0ustar fuji.goroDENA\Domain Users#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; { package Foo; use Mouse; has 'bar' => ( is => 'rw' ); package Stuffed::Role; use Mouse::Role; has 'options' => ( traits => ['Array'], is => 'ro', isa => 'ArrayRef[Foo]', ); package Bulkie::Role; use Mouse::Role; has 'stuff' => ( traits => ['Array'], is => 'ro', isa => 'ArrayRef', handles => { get_stuff => 'get', } ); package Stuff; use Mouse; ::is( ::exception { with 'Stuffed::Role'; }, undef, '... this should work correctly' ); ::is( ::exception { with 'Bulkie::Role'; }, undef, '... this should work correctly' ); } done_testing; MouseX-NativeTraits-1.09/t/070_native_traits/101_remove_attribute.t0000644€(NñY€ZÃ);0000000172512054627122027507 0ustar fuji.goroDENA\Domain Users#!/usr/bin/perl use strict; use warnings; use Test::More skip_all => 'Not supported by MouseX::NativeTraits'; use Test::More; use Test::Fatal; { package MyHomePage; use Mouse; has 'counter' => ( traits => ['Counter'], is => 'ro', isa => 'Int', default => 0, handles => { inc_counter => 'inc', dec_counter => 'dec', reset_counter => 'reset', } ); } my $page = MyHomePage->new(); isa_ok( $page, 'MyHomePage' ); can_ok( $page, $_ ) for qw[ counter dec_counter inc_counter reset_counter ]; is( exception { $page->meta->remove_attribute('counter'); }, undef, '... removed the counter attribute okay' ); ok( !$page->meta->has_attribute('counter'), '... no longer has the attribute' ); ok( !$page->can($_), "... our class no longer has the $_ method" ) for qw[ counter dec_counter inc_counter reset_counter ]; done_testing; MouseX-NativeTraits-1.09/t/070_native_traits/102_collection_with_roles.t0000644€(NñY€ZÃ);0000000422112054627122030514 0ustar fuji.goroDENA\Domain Users#!/usr/bin/perl use strict; use warnings; use Test::More; { package Subject; use Mouse::Role; has observers => ( traits => ['Array'], is => 'ro', isa => 'ArrayRef[Observer]', auto_deref => 1, default => sub { [] }, handles => { 'add_observer' => 'push', 'count_observers' => 'count', }, ); sub notify { my ($self) = @_; foreach my $observer ( $self->observers() ) { $observer->update($self); } } } { package Observer; use Mouse::Role; requires 'update'; } { package Counter; use Mouse; with 'Subject'; has count => ( traits => ['Counter'], is => 'ro', isa => 'Int', default => 0, handles => { inc_counter => 'inc', dec_counter => 'dec', }, ); after qw(inc_counter dec_counter) => sub { my ($self) = @_; $self->notify(); }; } { package Display; use Test::More; use Mouse; with 'Observer'; sub update { my ( $self, $subject ) = @_; like $subject->count, qr{^-?\d+$}, 'Observed number ' . $subject->count; } } package main; my $count = Counter->new(); ok( $count->can('add_observer'), 'add_observer method added' ); ok( $count->can('count_observers'), 'count_observers method added' ); ok( $count->can('inc_counter'), 'inc_counter method added' ); ok( $count->can('dec_counter'), 'dec_counter method added' ); $count->add_observer( Display->new() ); is( $count->count_observers, 1, 'Only one observer' ); is( $count->count, 0, 'Default to zero' ); $count->inc_counter; is( $count->count, 1, 'Increment to one ' ); $count->inc_counter for ( 1 .. 6 ); is( $count->count, 7, 'Increment up to seven' ); $count->dec_counter; is( $count->count, 6, 'Decrement to 6' ); $count->dec_counter for ( 1 .. 5 ); is( $count->count, 1, 'Decrement to 1' ); $count->dec_counter for ( 1 .. 2 ); is( $count->count, -1, 'Negative numbers' ); $count->inc_counter; is( $count->count, 0, 'Back to zero' ); done_testing; MouseX-NativeTraits-1.09/t/070_native_traits/103_custom_instance.t0000644€(NñY€ZÃ);0000002133312054627122027324 0ustar fuji.goroDENA\Domain Users#!/usr/bin/env perl use strict; use warnings; use Test::More skip_all => 'not supproted by MouseX::NativeTraits'; use Test::More; use Test::Fatal; use Test::Mouse; { package ValueContainer; use Mouse; has value => ( is => 'rw', ); } { package Foo::Meta::Instance; use Mouse::Role; around get_slot_value => sub { my $orig = shift; my $self = shift; my ($instance, $slot_name) = @_; my $value = $self->$orig(@_); if ($value->isa('ValueContainer')) { $value = $value->value; } return $value; }; around inline_get_slot_value => sub { my $orig = shift; my $self = shift; my $value = $self->$orig(@_); return q[do {] . "\n" . q[ my $value = ] . $value . q[;] . "\n" . q[ if ($value->isa('ValueContainer')) {] . "\n" . q[ $value = $value->value;] . "\n" . q[ }] . "\n" . q[ $value] . "\n" . q[}]; }; sub inline_get_is_lvalue { 0 } } { package Foo; use Mouse; Mouse::Util::MetaRole::apply_metaroles( for => __PACKAGE__, class_metaroles => { instance => ['Foo::Meta::Instance'], } ); ::is( ::exception { has array => ( traits => ['Array'], isa => 'ArrayRef', default => sub { [] }, handles => { array_count => 'count', array_elements => 'elements', array_is_empty => 'is_empty', array_push => 'push', array_push_curried => [ push => 42, 84 ], array_unshift => 'unshift', array_unshift_curried => [ unshift => 42, 84 ], array_pop => 'pop', array_shift => 'shift', array_get => 'get', array_get_curried => [ get => 1 ], array_set => 'set', array_set_curried_1 => [ set => 1 ], array_set_curried_2 => [ set => ( 1, 98 ) ], array_accessor => 'accessor', array_accessor_curried_1 => [ accessor => 1 ], array_accessor_curried_2 => [ accessor => ( 1, 90 ) ], array_clear => 'clear', array_delete => 'delete', array_delete_curried => [ delete => 1 ], array_insert => 'insert', array_insert_curried => [ insert => ( 1, 101 ) ], array_splice => 'splice', array_splice_curried_1 => [ splice => 1 ], array_splice_curried_2 => [ splice => 1, 2 ], array_splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], array_sort => 'sort', array_sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ], array_sort_in_place => 'sort_in_place', array_sort_in_place_curried => [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], array_map => 'map', array_map_curried => [ map => ( sub { $_ + 1 } ) ], array_grep => 'grep', array_grep_curried => [ grep => ( sub { $_ < 5 } ) ], array_first => 'first', array_first_curried => [ first => ( sub { $_ % 2 } ) ], array_join => 'join', array_join_curried => [ join => '-' ], array_shuffle => 'shuffle', array_uniq => 'uniq', array_reduce => 'reduce', array_reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ], array_natatime => 'natatime', array_natatime_curried => [ natatime => 2 ], }, ); }, undef, "native array trait inlines properly" ); ::is( ::exception { has bool => ( traits => ['Bool'], isa => 'Bool', default => 0, handles => { bool_illuminate => 'set', bool_darken => 'unset', bool_flip_switch => 'toggle', bool_is_dark => 'not', }, ); }, undef, "native bool trait inlines properly" ); ::is( ::exception { has code => ( traits => ['Code'], isa => 'CodeRef', default => sub { sub { } }, handles => { code_execute => 'execute', code_execute_method => 'execute_method', }, ); }, undef, "native code trait inlines properly" ); ::is( ::exception { has counter => ( traits => ['Counter'], isa => 'Int', default => 0, handles => { inc_counter => 'inc', inc_counter_2 => [ inc => 2 ], dec_counter => 'dec', dec_counter_2 => [ dec => 2 ], reset_counter => 'reset', set_counter => 'set', set_counter_42 => [ set => 42 ], }, ); }, undef, "native counter trait inlines properly" ); ::is( ::exception { has hash => ( traits => ['Hash'], isa => 'HashRef', default => sub { {} }, handles => { hash_option_accessor => 'accessor', hash_quantity => [ accessor => 'quantity' ], hash_clear_options => 'clear', hash_num_options => 'count', hash_delete_option => 'delete', hash_is_defined => 'defined', hash_options_elements => 'elements', hash_has_option => 'exists', hash_get_option => 'get', hash_has_no_options => 'is_empty', hash_key_value => 'kv', hash_set_option => 'set', }, ); }, undef, "native hash trait inlines properly" ); ::is( ::exception { has number => ( traits => ['Number'], isa => 'Num', default => 0, handles => { num_abs => 'abs', num_add => 'add', num_inc => [ add => 1 ], num_div => 'div', num_cut_in_half => [ div => 2 ], num_mod => 'mod', num_odd => [ mod => 2 ], num_mul => 'mul', num_set => 'set', num_sub => 'sub', num_dec => [ sub => 1 ], }, ); }, undef, "native number trait inlines properly" ); ::is( ::exception { has string => ( traits => ['String'], is => 'ro', isa => 'Str', default => '', handles => { string_inc => 'inc', string_append => 'append', string_append_curried => [ append => '!' ], string_prepend => 'prepend', string_prepend_curried => [ prepend => '-' ], string_replace => 'replace', string_replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], string_chop => 'chop', string_chomp => 'chomp', string_clear => 'clear', string_match => 'match', string_match_curried => [ match => qr/\D/ ], string_length => 'length', string_substr => 'substr', string_substr_curried_1 => [ substr => (1) ], string_substr_curried_2 => [ substr => ( 1, 3 ) ], string_substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], }, ); }, undef, "native string trait inlines properly" ); } with_immutable { { my $foo = Foo->new(string => 'a'); is($foo->string, 'a'); $foo->string_append('b'); is($foo->string, 'ab'); } { my $foo = Foo->new(string => ''); $foo->{string} = ValueContainer->new(value => 'a'); is($foo->string, 'a'); $foo->string_append('b'); is($foo->string, 'ab'); } } 'Foo'; done_testing; MouseX-NativeTraits-1.09/xt/0000755€(NñY€ZÃ);0000000000012054627374020313 5ustar fuji.goroDENA\Domain UsersMouseX-NativeTraits-1.09/xt/01_podspell.t0000644€(NñY€ZÃ);0000000052012054627122022606 0ustar fuji.goroDENA\Domain Users#!perl -w use strict; use Test::More; use Test::Spelling; add_stopwords(map { split /[\s\:\-]/ } ); $ENV{LANG} = 'C'; all_pod_files_spelling_ok('lib'); __DATA__ Goro Fuji (gfx) gfuji(at)cpan.org MouseX::NativeTraits incrementing decrementing Stevan clearers cpan gfx Num Str versa uniq indices dec kv isa arity metaclass attr MouseX-NativeTraits-1.09/xt/02_pod.t0000644€(NñY€ZÃ);0000000023312054627122021550 0ustar fuji.goroDENA\Domain Users#!perl -w use strict; use Test::More; eval q{use Test::Pod 1.14}; plan skip_all => 'Test::Pod 1.14 required for testing POD' if $@; all_pod_files_ok(); MouseX-NativeTraits-1.09/xt/04_synopsis.t0000644€(NñY€ZÃ);0000000022312054627122022656 0ustar fuji.goroDENA\Domain Users#!perl -w use strict; use Test::More; eval q{use Test::Synopsis}; plan skip_all => 'Test::Synopsis required for testing' if $@; all_synopsis_ok();