MooseX-AttributeHelpers-0.23/0000755000175000017500000000000011317443272016000 5ustar autarchautarchMooseX-AttributeHelpers-0.23/t/0000755000175000017500000000000011317443272016243 5ustar autarchautarchMooseX-AttributeHelpers-0.23/t/003_basic_hash.t0000644000175000017500000001144111253523274021077 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 50; use Test::Exception; BEGIN { use_ok('MooseX::AttributeHelpers'); } { package Stuff; use Moose; use MooseX::AttributeHelpers; has 'options' => ( metaclass => 'Collection::Hash', is => 'ro', isa => 'HashRef[Str]', default => sub { {} }, provides => { 'set' => 'set_option', 'get' => 'get_option', 'empty' => 'has_options', 'count' => 'num_options', 'clear' => 'clear_options', 'delete' => 'delete_option', 'exists' => 'has_option', 'defined' => 'is_defined', 'accessor' => 'option_accessor', 'kv' => 'key_value', 'elements' => 'options_elements', }, curries => { 'accessor' => { quantity => ['quantity'], }, } ); } my $stuff = Stuff->new(); isa_ok($stuff, 'Stuff'); can_ok($stuff, $_) for qw[ set_option get_option has_options num_options delete_option clear_options is_defined has_option quantity option_accessor ]; ok(!$stuff->has_options, '... we have no options'); is($stuff->num_options, 0, '... we have no options'); is_deeply($stuff->options, {}, '... no options yet'); ok(!$stuff->has_option('foo'), '... we have no foo option'); lives_ok { $stuff->set_option(foo => 'bar'); } '... set the option okay'; ok($stuff->is_defined('foo'), '... foo is defined'); ok($stuff->has_options, '... we have options'); is($stuff->num_options, 1, '... we have 1 option(s)'); ok($stuff->has_option('foo'), '... we have a foo option'); is_deeply($stuff->options, { foo => 'bar' }, '... got options now'); lives_ok { $stuff->set_option(bar => 'baz'); } '... set the option okay'; is($stuff->num_options, 2, '... we have 2 option(s)'); is_deeply($stuff->options, { foo => 'bar', bar => 'baz' }, '... got more options now'); is($stuff->get_option('foo'), 'bar', '... got the right option'); is_deeply([ $stuff->get_option(qw(foo bar)) ], [qw(bar baz)], "get multiple options at once"); lives_ok { $stuff->set_option(oink => "blah", xxy => "flop"); } '... set the option okay'; is($stuff->num_options, 4, "4 options"); is_deeply([ $stuff->get_option(qw(foo bar oink xxy)) ], [qw(bar baz blah flop)], "get multiple options at once"); lives_ok { $stuff->delete_option('bar'); } '... deleted the option okay'; lives_ok { $stuff->delete_option('oink'); } '... deleted the option okay'; lives_ok { $stuff->delete_option('xxy'); } '... deleted the option okay'; is($stuff->num_options, 1, '... we have 1 option(s)'); is_deeply($stuff->options, { foo => 'bar' }, '... got more options now'); $stuff->clear_options; is_deeply($stuff->options, { }, "... cleared options" ); lives_ok { $stuff->quantity(4); } '... options added okay with defaults'; is($stuff->quantity, 4, 'reader part of curried accessor works'); is_deeply($stuff->options, {quantity => 4}, '... returns what we expect'); lives_ok { Stuff->new(options => { foo => 'BAR' }); } '... good constructor params'; ## check some errors dies_ok { $stuff->set_option(bar => {}); } '... could not add a hash ref where an string is expected'; dies_ok { Stuff->new(options => { foo => [] }); } '... bad constructor params'; dies_ok { my $stuff = Stuff->new; $stuff->option_accessor(); } '... accessor dies on 0 args'; dies_ok { my $stuff = Stuff->new; $stuff->option_accessor(1 => 2, 3); } '... accessor dies on 3 args'; dies_ok { my $stuff = Stuff->new; $stuff->option_accessor(1 => 2, 3 => 4); } '... accessor dies on 4 args'; ## test the meta my $options = $stuff->meta->get_attribute('options'); isa_ok($options, 'MooseX::AttributeHelpers::Collection::Hash'); is_deeply($options->provides, { 'set' => 'set_option', 'get' => 'get_option', 'empty' => 'has_options', 'count' => 'num_options', 'clear' => 'clear_options', 'delete' => 'delete_option', 'defined' => 'is_defined', 'exists' => 'has_option', 'accessor' => 'option_accessor', 'kv' => 'key_value', 'elements' => 'options_elements', }, '... got the right provides mapping'); is($options->type_constraint->type_parameter, 'Str', '... got the right container type'); $stuff->set_option( oink => "blah", xxy => "flop" ); my @key_value = $stuff->key_value; is_deeply( \@key_value, [ [ 'xxy', 'flop' ], [ 'quantity', 4 ], [ 'oink', 'blah' ] ], '... got the right key value pairs' ); my %options_elements = $stuff->options_elements; is_deeply( \%options_elements, { 'oink' => 'blah', 'quantity' => 4, 'xxy' => 'flop' }, '... got the right hash elements' ); MooseX-AttributeHelpers-0.23/t/001_basic_counter.t0000644000175000017500000000326011166253053021627 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 18; BEGIN { use_ok('MooseX::AttributeHelpers'); } { package MyHomePage; use Moose; has 'counter' => ( metaclass => 'Counter', is => 'ro', isa => 'Int', default => sub { 0 }, provides => { inc => 'inc_counter', dec => 'dec_counter', reset => 'reset_counter', set => 'set_counter' } ); } my $page = MyHomePage->new(); isa_ok($page, 'MyHomePage'); can_ok($page, $_) for qw[ dec_counter inc_counter reset_counter set_counter ]; is($page->counter, 0, '... got the default value'); $page->inc_counter; is($page->counter, 1, '... got the incremented value'); $page->inc_counter; is($page->counter, 2, '... got the incremented value (again)'); $page->dec_counter; is($page->counter, 1, '... got the decremented value'); $page->reset_counter; is($page->counter, 0, '... got the original value'); $page->set_counter(5); is($page->counter, 5, '... set the value'); $page->inc_counter(2); is($page->counter, 7, '... increment by arg'); $page->dec_counter(5); is($page->counter, 2, '... decrement by arg'); # check the meta .. my $counter = $page->meta->get_attribute('counter'); isa_ok($counter, 'MooseX::AttributeHelpers::Counter'); is($counter->helper_type, 'Num', '... got the expected helper type'); is($counter->type_constraint->name, 'Int', '... got the expected type constraint'); is_deeply($counter->provides, { inc => 'inc_counter', dec => 'dec_counter', reset => 'reset_counter', set => 'set_counter' }, '... got the right provides methods'); MooseX-AttributeHelpers-0.23/t/007_basic_string.t0000644000175000017500000000655711253523274021502 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 30; BEGIN { use_ok('MooseX::AttributeHelpers'); } { package MyHomePage; use Moose; has 'string' => ( metaclass => 'String', is => 'rw', isa => 'Str', default => sub { '' }, provides => { inc => 'inc_string', append => 'append_string', prepend => 'prepend_string', match => 'match_string', replace => 'replace_string', chop => 'chop_string', chomp => 'chomp_string', clear => 'clear_string', substr => 'sub_string', length => 'length_string', }, curries => { append => {exclaim => [ '!' ]}, replace => {capitalize_last => [ qr/(.)$/, sub { uc $1 } ]}, match => {invalid_number => [ qr/\D/ ]}, substr => {shift_chars => sub { $_[1]->($_[0], 0, $_[2], '') } }, } ); } my $page = MyHomePage->new(); isa_ok($page, 'MyHomePage'); is($page->string, '', '... got the default value'); is($page->length_string, 0, '... length is zero'); $page->string('a'); is($page->length_string, 1, '... new string has length of one'); $page->inc_string; is($page->string, 'b', '... got the incremented value'); $page->inc_string; is($page->string, 'c', '... got the incremented value (again)'); $page->append_string("foo$/"); is($page->string, "cfoo$/", 'appended to string'); $page->chomp_string; is($page->string, "cfoo", 'chomped string'); $page->chomp_string; is($page->string, "cfoo", 'chomped is noop'); $page->chop_string; is($page->string, "cfo", 'chopped string'); $page->prepend_string("bar"); is($page->string, 'barcfo', 'prepended to string'); is_deeply( [ $page->match_string(qr/([ao])/) ], [ "a" ], "match" ); $page->replace_string(qr/([ao])/, sub { uc($1) }); is($page->string, 'bArcfo', "substitution"); is($page->length_string, 6, 'right length'); $page->exclaim; is($page->string, 'bArcfo!', 'exclaim!'); is($page->sub_string(2), 'rcfo!', 'substr(offset)'); is($page->sub_string(2, 2), 'rc', 'substr(offset, length)'); is($page->sub_string(2, 2, ''), 'rc', 'substr(offset, length, replacement)'); is($page->string, 'bAfo!', 'replacement got inserted'); is($page->shift_chars(2), 'bA', 'curried substr'); is($page->string, 'fo!', 'replacement got inserted'); $page->string('Moosex'); $page->capitalize_last; is($page->string, 'MooseX', 'capitalize last'); $page->string('1234'); ok(!$page->invalid_number, 'string "isn\'t an invalid number'); $page->string('one two three four'); ok($page->invalid_number, 'string an invalid number'); $page->clear_string; is($page->string, '', "clear"); # check the meta .. my $string = $page->meta->get_attribute('string'); isa_ok($string, 'MooseX::AttributeHelpers::String'); is($string->helper_type, 'Str', '... got the expected helper type'); is($string->type_constraint->name, 'Str', '... got the expected type constraint'); is_deeply($string->provides, { inc => 'inc_string', append => 'append_string', prepend => 'prepend_string', match => 'match_string', replace => 'replace_string', chop => 'chop_string', chomp => 'chomp_string', clear => 'clear_string', substr => 'sub_string', length => 'length_string', }, '... got the right provides methods'); MooseX-AttributeHelpers-0.23/t/010_array_from_role.t0000644000175000017500000000157611166253053022201 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 3; use Test::Exception; BEGIN { use_ok('MooseX::AttributeHelpers'); } { package Foo; use Moose; has 'bar' => (is => 'rw'); package Stuffed::Role; use Moose::Role; has 'options' => ( metaclass => 'Collection::Array', is => 'ro', isa => 'ArrayRef[Foo]', ); package Bulkie::Role; use Moose::Role; has 'stuff' => ( metaclass => 'Collection::Array', is => 'ro', isa => 'ArrayRef', provides => { 'get' => 'get_stuff' } ); package Stuff; use Moose; ::lives_ok { with 'Stuffed::Role'; } '... this should work correctly'; ::lives_ok { with 'Bulkie::Role'; } '... this should work correctly'; } MooseX-AttributeHelpers-0.23/t/020_remove_attribute.t0000644000175000017500000000170111166253053022366 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 12; use Test::Exception; BEGIN { use_ok('MooseX::AttributeHelpers'); } { package MyHomePage; use Moose; has 'counter' => ( metaclass => 'Counter', is => 'ro', isa => 'Int', default => sub { 0 }, provides => { inc => 'inc_counter', dec => 'dec_counter', reset => 'reset_counter', } ); } my $page = MyHomePage->new(); isa_ok($page, 'MyHomePage'); can_ok($page, $_) for qw[ counter dec_counter inc_counter reset_counter ]; lives_ok { $page->meta->remove_attribute('counter') } '... 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 ]; MooseX-AttributeHelpers-0.23/t/204_trait_number.t0000644000175000017500000000362711253523274021520 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 26; use Test::Moose; BEGIN { use_ok('MooseX::AttributeHelpers'); } { package Real; use Moose; has 'integer' => ( traits => [qw/MooseX::AttributeHelpers::Trait::Number/], is => 'ro', isa => 'Int', default => sub { 5 }, provides => { set => 'set', add => 'add', sub => 'sub', mul => 'mul', div => 'div', mod => 'mod', abs => 'abs', }, curries => { add => {inc => [ 1 ]}, sub => {dec => [ 1 ]}, mod => {odd => [ 2 ]}, div => {cut_in_half => [ 2 ]} } ); } my $real = Real->new; isa_ok($real, 'Real'); can_ok($real, $_) for qw[ set add sub mul div mod abs inc dec odd cut_in_half ]; is $real->integer, 5, 'Default to five'; $real->add(10); is $real->integer, 15, 'Add ten for fithteen'; $real->sub(3); is $real->integer, 12, 'Subtract three for 12'; $real->set(10); is $real->integer, 10, 'Set to ten'; $real->div(2); is $real->integer, 5, 'divide by 2'; $real->mul(2); is $real->integer, 10, 'multiplied by 2'; $real->mod(2); is $real->integer, 0, 'Mod by 2'; $real->set(7); $real->mod(5); is $real->integer, 2, 'Mod by 5'; $real->set(-1); $real->abs; is $real->integer, 1, 'abs 1'; $real->set(12); $real->inc; is $real->integer, 13, 'inc 12'; $real->dec; is $real->integer, 12, 'dec 13'; ## test the meta my $attr = $real->meta->get_attribute('integer'); does_ok($attr, 'MooseX::AttributeHelpers::Trait::Number'); is_deeply($attr->provides, { set => 'set', add => 'add', sub => 'sub', mul => 'mul', div => 'div', mod => 'mod', abs => 'abs', }, '... got the right provides mapping'); MooseX-AttributeHelpers-0.23/t/000_load.t0000644000175000017500000000017111166253053017723 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 1; BEGIN { use_ok('MooseX::AttributeHelpers'); }MooseX-AttributeHelpers-0.23/t/004_basic_number.t0000644000175000017500000000353211166253053021445 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 26; BEGIN { use_ok('MooseX::AttributeHelpers'); } { package Real; use Moose; has 'integer' => ( metaclass => 'Number', is => 'ro', isa => 'Int', default => sub { 5 }, provides => { set => 'set', add => 'add', sub => 'sub', mul => 'mul', div => 'div', mod => 'mod', abs => 'abs', }, curries => { add => {inc => [ 1 ]}, sub => {dec => [ 1 ]}, mod => {odd => [ 2 ]}, div => {cut_in_half => [ 2 ]} } ); } my $real = Real->new; isa_ok($real, 'Real'); can_ok($real, $_) for qw[ set add sub mul div mod abs inc dec odd cut_in_half ]; is $real->integer, 5, 'Default to five'; $real->add(10); is $real->integer, 15, 'Add ten for fithteen'; $real->sub(3); is $real->integer, 12, 'Subtract three for 12'; $real->set(10); is $real->integer, 10, 'Set to ten'; $real->div(2); is $real->integer, 5, 'divide by 2'; $real->mul(2); is $real->integer, 10, 'multiplied by 2'; $real->mod(2); is $real->integer, 0, 'Mod by 2'; $real->set(7); $real->mod(5); is $real->integer, 2, 'Mod by 5'; $real->set(-1); $real->abs; is $real->integer, 1, 'abs 1'; $real->set(12); $real->inc; is $real->integer, 13, 'inc 12'; $real->dec; is $real->integer, 12, 'dec 13'; ## test the meta my $attr = $real->meta->get_attribute('integer'); isa_ok($attr, 'MooseX::AttributeHelpers::Number'); is_deeply($attr->provides, { set => 'set', add => 'add', sub => 'sub', mul => 'mul', div => 'div', mod => 'mod', abs => 'abs', }, '... got the right provides mapping'); MooseX-AttributeHelpers-0.23/t/100_collection_with_roles.t0000644000175000017500000000450311166253053023402 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 29; BEGIN { use_ok('MooseX::AttributeHelpers'); } package Subject; use Moose::Role; use MooseX::AttributeHelpers; has observers => ( metaclass => 'Collection::Array', is => 'ro', isa => 'ArrayRef[Observer]', auto_deref => 1, default => sub { [] }, provides => { 'push' => 'add_observer', count => 'count_observers' } ); sub notify { my ($self) = @_; foreach my $observer ( $self->observers() ) { $observer->update($self); } } ############################################################################### package Observer; use Moose::Role; requires 'update'; ############################################################################### package Counter; use Moose; use MooseX::AttributeHelpers; with 'Subject'; has count => ( metaclass => 'Counter', is => 'ro', isa => 'Int', default => 0, provides => { inc => 'inc_counter', dec => 'dec_counter', } ); after 'inc_counter','dec_counter' => sub { my ($self) = @_; $self->notify(); }; ############################################################################### package Display; use Test::More; use Moose; 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');MooseX-AttributeHelpers-0.23/t/205_trait_list.t0000644000175000017500000001054311253523274021177 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 35; use Test::Exception; use Test::Moose 'does_ok'; BEGIN { use_ok('MooseX::AttributeHelpers'); } { package Stuff; use Moose; has '_options' => ( traits => [qw/MooseX::AttributeHelpers::Trait::Collection::List/], is => 'ro', isa => 'ArrayRef[Int]', init_arg => 'options', default => sub { [] }, provides => { 'count' => 'num_options', 'empty' => 'has_options', 'map' => 'map_options', 'grep' => 'filter_options', 'find' => 'find_option', 'elements' => 'options', 'join' => 'join_options', 'get' => 'get_option_at', 'first' => 'get_first_option', 'last' => 'get_last_option', 'sort' => 'sorted_options', }, curries => { 'grep' => {less_than_five => [ sub { $_ < 5 } ]}, 'map' => {up_by_one => [ sub { $_ + 1 } ]}, 'join' => {dashify => [ '-' ]}, 'sort' => {descending => [ sub { $_[1] <=> $_[0] } ]}, } ); has animals => ( is => 'rw', isa => 'ArrayRef[Str]', metaclass => 'Collection::List', curries => { grep => { double_length_of => sub { my ($self, $body, $arg) = @_; $body->($self, sub { length($_) == length($arg) * 2 }); } } } ) } my $stuff = Stuff->new(options => [ 1 .. 10 ]); isa_ok($stuff, 'Stuff'); can_ok($stuff, $_) for qw[ _options num_options has_options map_options filter_options find_option options join_options get_option_at sorted_options ]; is_deeply($stuff->_options, [1 .. 10], '... got options'); ok($stuff->has_options, '... we have options'); is($stuff->num_options, 10, '... got 2 options'); cmp_ok($stuff->get_option_at(0), '==', 1, '... get option 0'); cmp_ok($stuff->get_first_option, '==', 1, '... get first'); cmp_ok($stuff->get_last_option, '==', 10, '... get last'); is_deeply( [ $stuff->filter_options(sub { $_[0] % 2 == 0 }) ], [ 2, 4, 6, 8, 10 ], '... got the right filtered values' ); is_deeply( [ $stuff->map_options(sub { $_[0] * 2 }) ], [ 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 ], '... got the right mapped values' ); is($stuff->find_option(sub { $_[0] % 2 == 0 }), 2, '.. found the right option'); is_deeply([ $stuff->options ], [1 .. 10], '... got the list of options'); is($stuff->join_options(':'), '1:2:3:4:5:6:7:8:9:10', '... joined the list of options by :'); is_deeply([ $stuff->sorted_options ], [sort (1..10)], '... got sorted options (default sort order)'); is_deeply([ $stuff->sorted_options( sub { $_[1] <=> $_[0] } ) ], [sort { $b <=> $a } (1..10)], '... got sorted options (descending sort order) '); throws_ok { $stuff->sorted_options('foo') } qr/Argument must be a code reference/, 'error when sort receives a non-coderef argument'; # test the currying is_deeply([ $stuff->less_than_five() ], [1 .. 4]); is_deeply([ $stuff->up_by_one() ], [2 .. 11]); is($stuff->dashify, '1-2-3-4-5-6-7-8-9-10'); $stuff->animals([ qw/cat duck horse cattle gorilla elephant flamingo kangaroo/ ]); # 4 * 2 = 8 is_deeply( [ sort $stuff->double_length_of('fish') ], [ sort qw/elephant flamingo kangaroo/ ], 'returns all elements with double length of string "fish"' ); is_deeply([$stuff->descending], [reverse 1 .. 10]); ## test the meta my $options = $stuff->meta->get_attribute('_options'); does_ok($options, 'MooseX::AttributeHelpers::Trait::Collection::List'); is_deeply($options->provides, { 'map' => 'map_options', 'grep' => 'filter_options', 'find' => 'find_option', 'count' => 'num_options', 'empty' => 'has_options', 'elements' => 'options', 'join' => 'join_options', 'get' => 'get_option_at', 'first' => 'get_first_option', 'last' => 'get_last_option', 'sort' => 'sorted_options', }, '... got the right provides mapping'); is($options->type_constraint->type_parameter, 'Int', '... got the right container type'); dies_ok { $stuff->sort_in_place_options( undef ); } '... sort rejects arg of invalid type'; MooseX-AttributeHelpers-0.23/t/pod.t0000644000175000017500000000036611166253053017215 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Pod tests run only authors" unless -e "inc/.author"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); MooseX-AttributeHelpers-0.23/t/012_basic_bool.t0000644000175000017500000000202711166253053021105 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 8; use MooseX::AttributeHelpers; { package Room; use Moose; has 'is_lit' => ( metaclass => 'Bool', is => 'rw', isa => 'Bool', default => sub { 0 }, provides => { set => 'illuminate', unset => 'darken', toggle => 'flip_switch', not => 'is_dark' } ) } my $room = Room->new; $room->illuminate; ok $room->is_lit, 'set is_lit to 1 using ->illuminate'; ok !$room->is_dark, 'check if is_dark does the right thing'; $room->darken; ok !$room->is_lit, 'set is_lit to 0 using ->darken'; ok $room->is_dark, 'check if is_dark does the right thing'; $room->flip_switch; ok $room->is_lit, 'toggle is_lit back to 1 using ->flip_switch'; ok !$room->is_dark, 'check if is_dark does the right thing'; $room->flip_switch; ok !$room->is_lit, 'toggle is_lit back to 0 again using ->flip_switch'; ok $room->is_dark, 'check if is_dark does the right thing'; MooseX-AttributeHelpers-0.23/t/207_trait_string.t0000644000175000017500000000666711253523274021550 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 30; use Test::Moose 'does_ok'; BEGIN { use_ok('MooseX::AttributeHelpers'); } { package MyHomePage; use Moose; has 'string' => ( traits => [qw/MooseX::AttributeHelpers::Trait::String/], is => 'rw', isa => 'Str', default => sub { '' }, provides => { inc => 'inc_string', append => 'append_string', prepend => 'prepend_string', match => 'match_string', replace => 'replace_string', chop => 'chop_string', chomp => 'chomp_string', clear => 'clear_string', substr => 'sub_string', length => 'length_string', }, curries => { append => {exclaim => [ '!' ]}, replace => {capitalize_last => [ qr/(.)$/, sub { uc $1 } ]}, match => {invalid_number => [ qr/\D/ ]}, substr => {shift_chars => sub { $_[1]->($_[0], 0, $_[2], '') } }, } ); } my $page = MyHomePage->new(); isa_ok($page, 'MyHomePage'); is($page->string, '', '... got the default value'); is($page->length_string, 0, '... length is zero'); $page->string('a'); is($page->length_string, 1, '... new string has length of one'); $page->inc_string; is($page->string, 'b', '... got the incremented value'); $page->inc_string; is($page->string, 'c', '... got the incremented value (again)'); $page->append_string("foo$/"); is($page->string, "cfoo$/", 'appended to string'); $page->chomp_string; is($page->string, "cfoo", 'chomped string'); $page->chomp_string; is($page->string, "cfoo", 'chomped is noop'); $page->chop_string; is($page->string, "cfo", 'chopped string'); $page->prepend_string("bar"); is($page->string, 'barcfo', 'prepended to string'); is($page->length_string, 6, 'right length'); is_deeply( [ $page->match_string(qr/([ao])/) ], [ "a" ], "match" ); $page->replace_string(qr/([ao])/, sub { uc($1) }); is($page->string, 'bArcfo', "substitution"); $page->exclaim; is($page->string, 'bArcfo!', 'exclaim!'); is($page->sub_string(2), 'rcfo!', 'substr(offset)'); is($page->sub_string(2, 2), 'rc', 'substr(offset, length)'); is($page->sub_string(2, 2, ''), 'rc', 'substr(offset, length, replacement)'); is($page->string, 'bAfo!', 'replacement got inserted'); is($page->shift_chars(2), 'bA', 'curried substr'); is($page->string, 'fo!', 'replacement got inserted'); $page->string('Moosex'); $page->capitalize_last; is($page->string, 'MooseX', 'capitalize last'); $page->string('1234'); ok(!$page->invalid_number, 'string "isn\'t an invalid number'); $page->string('one two three four'); ok($page->invalid_number, 'string an invalid number'); $page->clear_string; is($page->string, '', "clear"); # check the meta .. my $string = $page->meta->get_attribute('string'); does_ok($string, 'MooseX::AttributeHelpers::Trait::String'); is($string->helper_type, 'Str', '... got the expected helper type'); is($string->type_constraint->name, 'Str', '... got the expected type constraint'); is_deeply($string->provides, { inc => 'inc_string', append => 'append_string', prepend => 'prepend_string', match => 'match_string', replace => 'replace_string', chop => 'chop_string', chomp => 'chomp_string', clear => 'clear_string', substr => 'sub_string', length => 'length_string', }, '... got the right provides methods'); MooseX-AttributeHelpers-0.23/t/208_trait_bool.t0000644000175000017500000000207211253523274021160 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 8; use MooseX::AttributeHelpers; { package Room; use Moose; has 'is_lit' => ( traits => ['MooseX::AttributeHelpers::Trait::Bool'], is => 'rw', isa => 'Bool', default => sub { 0 }, provides => { set => 'illuminate', unset => 'darken', toggle => 'flip_switch', not => 'is_dark' } ) } my $room = Room->new; $room->illuminate; ok $room->is_lit, 'set is_lit to 1 using ->illuminate'; ok !$room->is_dark, 'check if is_dark does the right thing'; $room->darken; ok !$room->is_lit, 'set is_lit to 0 using ->darken'; ok $room->is_dark, 'check if is_dark does the right thing'; $room->flip_switch; ok $room->is_lit, 'toggle is_lit back to 1 using ->flip_switch'; ok !$room->is_dark, 'check if is_dark does the right thing'; $room->flip_switch; ok !$room->is_lit, 'toggle is_lit back to 0 again using ->flip_switch'; ok $room->is_dark, 'check if is_dark does the right thing'; MooseX-AttributeHelpers-0.23/t/202_trait_array.t0000644000175000017500000001552711253523274021346 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 69; use Test::Exception; use Test::Moose 'does_ok'; BEGIN { use_ok('MooseX::AttributeHelpers'); } { package Stuff; use Moose; has 'options' => ( traits => [qw/MooseX::AttributeHelpers::Trait::Collection::Array/], is => 'ro', isa => 'ArrayRef[Str]', default => sub { [] }, provides => { 'push' => 'add_options', 'pop' => 'remove_last_option', 'shift' => 'remove_first_option', 'unshift' => 'insert_options', 'get' => 'get_option_at', 'set' => 'set_option_at', 'count' => 'num_options', 'empty' => 'has_options', 'clear' => 'clear_options', 'splice' => 'splice_options', 'sort_in_place' => 'sort_options_in_place', 'accessor' => 'option_accessor', }, curries => { 'push' => { add_options_with_speed => ['funrolls', 'funbuns'] }, 'unshift' => { prepend_prerequisites_along_with => ['first', 'second'] }, 'sort_in_place' => { descending_options => [ sub { $_[1] <=> $_[0] } ], }, } ); } my $stuff = Stuff->new(options => [ 10, 12 ]); isa_ok($stuff, 'Stuff'); can_ok($stuff, $_) for qw[ add_options remove_last_option remove_first_option insert_options get_option_at set_option_at num_options clear_options has_options sort_options_in_place option_accessor ]; is_deeply($stuff->options, [10, 12], '... got options'); ok($stuff->has_options, '... we have options'); is($stuff->num_options, 2, '... got 2 options'); is($stuff->remove_last_option, 12, '... removed the last option'); is($stuff->remove_first_option, 10, '... removed the last option'); is_deeply($stuff->options, [], '... no options anymore'); ok(!$stuff->has_options, '... no options'); is($stuff->num_options, 0, '... got no options'); lives_ok { $stuff->add_options(1, 2, 3); } '... set the option okay'; is_deeply($stuff->options, [1, 2, 3], '... got options now'); ok($stuff->has_options, '... no options'); is($stuff->num_options, 3, '... got 3 options'); is($stuff->get_option_at(0), 1, '... get option at index 0'); is($stuff->get_option_at(1), 2, '... get option at index 1'); is($stuff->get_option_at(2), 3, '... get option at index 2'); lives_ok { $stuff->set_option_at(1, 100); } '... set the option okay'; is($stuff->get_option_at(1), 100, '... get option at index 1'); lives_ok { $stuff->add_options(10, 15); } '... set the option okay'; is_deeply($stuff->options, [1, 100, 3, 10, 15], '... got more options now'); is($stuff->num_options, 5, '... got 5 options'); is($stuff->remove_last_option, 15, '... removed the last option'); is($stuff->num_options, 4, '... got 4 options'); is_deeply($stuff->options, [1, 100, 3, 10], '... got diff options now'); lives_ok { $stuff->insert_options(10, 20); } '... set the option okay'; is($stuff->num_options, 6, '... got 6 options'); is_deeply($stuff->options, [10, 20, 1, 100, 3, 10], '... got diff options now'); is($stuff->get_option_at(0), 10, '... get option at index 0'); is($stuff->get_option_at(1), 20, '... get option at index 1'); is($stuff->get_option_at(3), 100, '... get option at index 3'); is($stuff->remove_first_option, 10, '... getting the first option'); is($stuff->num_options, 5, '... got 5 options'); is($stuff->get_option_at(0), 20, '... get option at index 0'); $stuff->clear_options; is_deeply( $stuff->options, [], "... clear options" ); $stuff->add_options(5, 1, 2, 3); $stuff->sort_options_in_place; is_deeply( $stuff->options, [1, 2, 3, 5], "... sort options in place (default sort order)" ); $stuff->sort_options_in_place( sub { $_[1] <=> $_[0] } ); is_deeply( $stuff->options, [5, 3, 2, 1], "... sort options in place (descending order)" ); $stuff->clear_options(); $stuff->add_options(5, 1, 2, 3); lives_ok { $stuff->descending_options(); } '... curried sort in place lives ok'; is_deeply( $stuff->options, [5, 3, 2, 1], "... sort currying" ); throws_ok { $stuff->sort_options_in_place('foo') } qr/Argument must be a code reference/, 'error when sort_in_place receives a non-coderef argument'; $stuff->clear_options; lives_ok { $stuff->add_options('tree'); } '... set the options okay'; lives_ok { $stuff->add_options_with_speed('compatible', 'safe'); } '... add options with speed okay'; is_deeply($stuff->options, [qw/tree funrolls funbuns compatible safe/], 'check options after add_options_with_speed'); lives_ok { $stuff->prepend_prerequisites_along_with(); } '... add prerequisite options okay'; $stuff->clear_options; $stuff->add_options( 1, 2 ); lives_ok { $stuff->splice_options( 1, 0, 'foo' ); } '... splice_options works'; is_deeply( $stuff->options, [ 1, 'foo', 2 ], 'splice added expected option' ); is($stuff->option_accessor(1 => 'foo++'), 'foo++'); is($stuff->option_accessor(1), 'foo++'); ## check some errors #dies_ok { # $stuff->insert_options(undef); #} '... could not add an undef where a string is expected'; # #dies_ok { # $stuff->set_option(5, {}); #} '... could not add a hash ref where a string is expected'; dies_ok { Stuff->new(options => [ undef, 10, undef, 20 ]); } '... bad constructor params'; dies_ok { my $stuff = Stuff->new(); $stuff->add_options(undef); } '... rejects push of an invalid type'; dies_ok { my $stuff = Stuff->new(); $stuff->insert_options(undef); } '... rejects unshift of an invalid type'; dies_ok { my $stuff = Stuff->new(); $stuff->set_option_at( 0, undef ); } '... rejects set of an invalid type'; dies_ok { my $stuff = Stuff->new(); $stuff->sort_in_place_options( undef ); } '... sort rejects arg of invalid type'; dies_ok { my $stuff = Stuff->new(); $stuff->option_accessor(); } '... accessor rejects 0 args'; dies_ok { my $stuff = Stuff->new(); $stuff->option_accessor(1, 2, 3); } '... accessor rejects 3 args'; ## test the meta my $options = $stuff->meta->get_attribute('options'); does_ok($options, 'MooseX::AttributeHelpers::Trait::Collection::Array'); is_deeply($options->provides, { 'push' => 'add_options', 'pop' => 'remove_last_option', 'shift' => 'remove_first_option', 'unshift' => 'insert_options', 'get' => 'get_option_at', 'set' => 'set_option_at', 'count' => 'num_options', 'empty' => 'has_options', 'clear' => 'clear_options', 'splice' => 'splice_options', 'sort_in_place' => 'sort_options_in_place', 'accessor' => 'option_accessor', }, '... got the right provides mapping'); is($options->type_constraint->type_parameter, 'Str', '... got the right container type'); MooseX-AttributeHelpers-0.23/t/206_trait_bag.t0000644000175000017500000000361611253523274020761 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 20; use Test::Exception; use Test::Moose 'does_ok'; BEGIN { use_ok('MooseX::AttributeHelpers'); } { package Stuff; use Moose; use MooseX::AttributeHelpers; has 'word_histogram' => ( traits => [qw/MooseX::AttributeHelpers::Trait::Collection::Bag/], is => 'ro', provides => { 'add' => 'add_word', 'get' => 'get_count_for', 'empty' => 'has_any_words', 'count' => 'num_words', 'delete' => 'delete_word', } ); } my $stuff = Stuff->new(); isa_ok($stuff, 'Stuff'); can_ok($stuff, $_) for qw[ add_word get_count_for has_any_words num_words delete_word ]; ok(!$stuff->has_any_words, '... we have no words'); is($stuff->num_words, 0, '... we have no words'); lives_ok { $stuff->add_word('bar'); } '... set the words okay'; ok($stuff->has_any_words, '... we have words'); is($stuff->num_words, 1, '... we have 1 word(s)'); is($stuff->get_count_for('bar'), 1, '... got words now'); lives_ok { $stuff->add_word('foo'); $stuff->add_word('bar') for 0 .. 3; $stuff->add_word('baz') for 0 .. 10; } '... set the words okay'; is($stuff->num_words, 3, '... we still have 1 word(s)'); is($stuff->get_count_for('foo'), 1, '... got words now'); is($stuff->get_count_for('bar'), 5, '... got words now'); is($stuff->get_count_for('baz'), 11, '... got words now'); ## test the meta my $words = $stuff->meta->get_attribute('word_histogram'); does_ok($words, 'MooseX::AttributeHelpers::Trait::Collection::Bag'); is_deeply($words->provides, { 'add' => 'add_word', 'get' => 'get_count_for', 'empty' => 'has_any_words', 'count' => 'num_words', 'delete' => 'delete_word', }, '... got the right provides mapping'); MooseX-AttributeHelpers-0.23/t/201_trait_counter.t0000644000175000017500000000337011253523274021677 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 18; use Test::Moose 'does_ok'; BEGIN { use_ok('MooseX::AttributeHelpers'); } { package MyHomePage; use Moose; has 'counter' => ( traits => [qw/MooseX::AttributeHelpers::Trait::Counter/], is => 'ro', isa => 'Int', default => sub { 0 }, provides => { inc => 'inc_counter', dec => 'dec_counter', reset => 'reset_counter', set => 'set_counter' } ); } my $page = MyHomePage->new(); isa_ok($page, 'MyHomePage'); can_ok($page, $_) for qw[ dec_counter inc_counter reset_counter set_counter ]; is($page->counter, 0, '... got the default value'); $page->inc_counter; is($page->counter, 1, '... got the incremented value'); $page->inc_counter; is($page->counter, 2, '... got the incremented value (again)'); $page->dec_counter; is($page->counter, 1, '... got the decremented value'); $page->reset_counter; is($page->counter, 0, '... got the original value'); $page->set_counter(5); is($page->counter, 5, '... set the value'); $page->inc_counter(2); is($page->counter, 7, '... increment by arg'); $page->dec_counter(5); is($page->counter, 2, '... decrement by arg'); # check the meta .. my $counter = $page->meta->get_attribute('counter'); does_ok($counter, 'MooseX::AttributeHelpers::Trait::Counter'); is($counter->helper_type, 'Num', '... got the expected helper type'); is($counter->type_constraint->name, 'Int', '... got the expected type constraint'); is_deeply($counter->provides, { inc => 'inc_counter', dec => 'dec_counter', reset => 'reset_counter', set => 'set_counter' }, '... got the right provides methods'); MooseX-AttributeHelpers-0.23/t/002_basic_array.t0000644000175000017500000001542011211117454021263 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 69; use Test::Exception; BEGIN { use_ok('MooseX::AttributeHelpers'); } { package Stuff; use Moose; has 'options' => ( metaclass => 'Collection::Array', is => 'ro', isa => 'ArrayRef[Str]', default => sub { [] }, provides => { 'push' => 'add_options', 'pop' => 'remove_last_option', 'shift' => 'remove_first_option', 'unshift' => 'insert_options', 'get' => 'get_option_at', 'set' => 'set_option_at', 'count' => 'num_options', 'empty' => 'has_options', 'clear' => 'clear_options', 'splice' => 'splice_options', 'sort_in_place' => 'sort_options_in_place', 'accessor' => 'option_accessor', }, curries => { 'push' => { add_options_with_speed => ['funrolls', 'funbuns'] }, 'unshift' => { prepend_prerequisites_along_with => ['first', 'second'] }, 'sort_in_place' => { descending_options => [ sub { $_[1] <=> $_[0] } ], }, } ); } my $stuff = Stuff->new(options => [ 10, 12 ]); isa_ok($stuff, 'Stuff'); can_ok($stuff, $_) for qw[ add_options remove_last_option remove_first_option insert_options get_option_at set_option_at num_options clear_options has_options sort_options_in_place option_accessor ]; is_deeply($stuff->options, [10, 12], '... got options'); ok($stuff->has_options, '... we have options'); is($stuff->num_options, 2, '... got 2 options'); is($stuff->remove_last_option, 12, '... removed the last option'); is($stuff->remove_first_option, 10, '... removed the last option'); is_deeply($stuff->options, [], '... no options anymore'); ok(!$stuff->has_options, '... no options'); is($stuff->num_options, 0, '... got no options'); lives_ok { $stuff->add_options(1, 2, 3); } '... set the option okay'; is_deeply($stuff->options, [1, 2, 3], '... got options now'); ok($stuff->has_options, '... no options'); is($stuff->num_options, 3, '... got 3 options'); is($stuff->get_option_at(0), 1, '... get option at index 0'); is($stuff->get_option_at(1), 2, '... get option at index 1'); is($stuff->get_option_at(2), 3, '... get option at index 2'); lives_ok { $stuff->set_option_at(1, 100); } '... set the option okay'; is($stuff->get_option_at(1), 100, '... get option at index 1'); lives_ok { $stuff->add_options(10, 15); } '... set the option okay'; is_deeply($stuff->options, [1, 100, 3, 10, 15], '... got more options now'); is($stuff->num_options, 5, '... got 5 options'); is($stuff->remove_last_option, 15, '... removed the last option'); is($stuff->num_options, 4, '... got 4 options'); is_deeply($stuff->options, [1, 100, 3, 10], '... got diff options now'); lives_ok { $stuff->insert_options(10, 20); } '... set the option okay'; is($stuff->num_options, 6, '... got 6 options'); is_deeply($stuff->options, [10, 20, 1, 100, 3, 10], '... got diff options now'); is($stuff->get_option_at(0), 10, '... get option at index 0'); is($stuff->get_option_at(1), 20, '... get option at index 1'); is($stuff->get_option_at(3), 100, '... get option at index 3'); is($stuff->remove_first_option, 10, '... getting the first option'); is($stuff->num_options, 5, '... got 5 options'); is($stuff->get_option_at(0), 20, '... get option at index 0'); $stuff->clear_options; is_deeply( $stuff->options, [], "... clear options" ); $stuff->add_options(5, 1, 2, 3); $stuff->sort_options_in_place; is_deeply( $stuff->options, [1, 2, 3, 5], "... sort options in place (default sort order)" ); $stuff->sort_options_in_place( sub { $_[1] <=> $_[0] } ); is_deeply( $stuff->options, [5, 3, 2, 1], "... sort options in place (descending order)" ); $stuff->clear_options(); $stuff->add_options(5, 1, 2, 3); lives_ok { $stuff->descending_options(); } '... curried sort in place lives ok'; is_deeply( $stuff->options, [5, 3, 2, 1], "... sort currying" ); throws_ok { $stuff->sort_options_in_place('foo') } qr/Argument must be a code reference/, 'error when sort_in_place receives a non-coderef argument'; $stuff->clear_options; lives_ok { $stuff->add_options('tree'); } '... set the options okay'; lives_ok { $stuff->add_options_with_speed('compatible', 'safe'); } '... add options with speed okay'; is_deeply($stuff->options, [qw/tree funrolls funbuns compatible safe/], 'check options after add_options_with_speed'); lives_ok { $stuff->prepend_prerequisites_along_with(); } '... add prerequisite options okay'; $stuff->clear_options; $stuff->add_options( 1, 2 ); lives_ok { $stuff->splice_options( 1, 0, 'foo' ); } '... splice_options works'; is_deeply( $stuff->options, [ 1, 'foo', 2 ], 'splice added expected option' ); is($stuff->option_accessor(1 => 'foo++'), 'foo++'); is($stuff->option_accessor(1), 'foo++'); ## check some errors #dies_ok { # $stuff->insert_options(undef); #} '... could not add an undef where a string is expected'; # #dies_ok { # $stuff->set_option(5, {}); #} '... could not add a hash ref where a string is expected'; dies_ok { Stuff->new(options => [ undef, 10, undef, 20 ]); } '... bad constructor params'; dies_ok { my $stuff = Stuff->new(); $stuff->add_options(undef); } '... rejects push of an invalid type'; dies_ok { my $stuff = Stuff->new(); $stuff->insert_options(undef); } '... rejects unshift of an invalid type'; dies_ok { my $stuff = Stuff->new(); $stuff->set_option_at( 0, undef ); } '... rejects set of an invalid type'; dies_ok { my $stuff = Stuff->new(); $stuff->sort_in_place_options( undef ); } '... sort rejects arg of invalid type'; dies_ok { my $stuff = Stuff->new(); $stuff->option_accessor(); } '... accessor rejects 0 args'; dies_ok { my $stuff = Stuff->new(); $stuff->option_accessor(1, 2, 3); } '... accessor rejects 3 args'; ## test the meta my $options = $stuff->meta->get_attribute('options'); isa_ok($options, 'MooseX::AttributeHelpers::Collection::Array'); is_deeply($options->provides, { 'push' => 'add_options', 'pop' => 'remove_last_option', 'shift' => 'remove_first_option', 'unshift' => 'insert_options', 'get' => 'get_option_at', 'set' => 'set_option_at', 'count' => 'num_options', 'empty' => 'has_options', 'clear' => 'clear_options', 'splice' => 'splice_options', 'sort_in_place' => 'sort_options_in_place', 'accessor' => 'option_accessor', }, '... got the right provides mapping'); is($options->type_constraint->type_parameter, 'Str', '... got the right container type'); MooseX-AttributeHelpers-0.23/t/006_basic_bag.t0000644000175000017500000000350611166253053020711 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 20; use Test::Exception; BEGIN { use_ok('MooseX::AttributeHelpers'); } { package Stuff; use Moose; use MooseX::AttributeHelpers; has 'word_histogram' => ( metaclass => 'Collection::Bag', is => 'ro', provides => { 'add' => 'add_word', 'get' => 'get_count_for', 'empty' => 'has_any_words', 'count' => 'num_words', 'delete' => 'delete_word', } ); } my $stuff = Stuff->new(); isa_ok($stuff, 'Stuff'); can_ok($stuff, $_) for qw[ add_word get_count_for has_any_words num_words delete_word ]; ok(!$stuff->has_any_words, '... we have no words'); is($stuff->num_words, 0, '... we have no words'); lives_ok { $stuff->add_word('bar'); } '... set the words okay'; ok($stuff->has_any_words, '... we have words'); is($stuff->num_words, 1, '... we have 1 word(s)'); is($stuff->get_count_for('bar'), 1, '... got words now'); lives_ok { $stuff->add_word('foo'); $stuff->add_word('bar') for 0 .. 3; $stuff->add_word('baz') for 0 .. 10; } '... set the words okay'; is($stuff->num_words, 3, '... we still have 1 word(s)'); is($stuff->get_count_for('foo'), 1, '... got words now'); is($stuff->get_count_for('bar'), 5, '... got words now'); is($stuff->get_count_for('baz'), 11, '... got words now'); ## test the meta my $words = $stuff->meta->get_attribute('word_histogram'); isa_ok($words, 'MooseX::AttributeHelpers::Collection::Bag'); is_deeply($words->provides, { 'add' => 'add_word', 'get' => 'get_count_for', 'empty' => 'has_any_words', 'count' => 'num_words', 'delete' => 'delete_word', }, '... got the right provides mapping'); MooseX-AttributeHelpers-0.23/t/005_basic_list.t0000644000175000017500000001043311166253053021127 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 35; use Test::Exception; BEGIN { use_ok('MooseX::AttributeHelpers'); } { package Stuff; use Moose; has '_options' => ( metaclass => 'Collection::List', is => 'ro', isa => 'ArrayRef[Int]', init_arg => 'options', default => sub { [] }, provides => { 'count' => 'num_options', 'empty' => 'has_options', 'map' => 'map_options', 'grep' => 'filter_options', 'find' => 'find_option', 'elements' => 'options', 'join' => 'join_options', 'get' => 'get_option_at', 'first' => 'get_first_option', 'last' => 'get_last_option', 'sort' => 'sorted_options', }, curries => { 'grep' => {less_than_five => [ sub { $_ < 5 } ]}, 'map' => {up_by_one => [ sub { $_ + 1 } ]}, 'join' => {dashify => [ '-' ]}, 'sort' => {descending => [ sub { $_[1] <=> $_[0] } ]}, } ); has animals => ( is => 'rw', isa => 'ArrayRef[Str]', metaclass => 'Collection::List', curries => { grep => { double_length_of => sub { my ($self, $body, $arg) = @_; $body->($self, sub { length($_) == length($arg) * 2 }); } } } ) } my $stuff = Stuff->new(options => [ 1 .. 10 ]); isa_ok($stuff, 'Stuff'); can_ok($stuff, $_) for qw[ _options num_options has_options map_options filter_options find_option options join_options get_option_at sorted_options ]; is_deeply($stuff->_options, [1 .. 10], '... got options'); ok($stuff->has_options, '... we have options'); is($stuff->num_options, 10, '... got 2 options'); cmp_ok($stuff->get_option_at(0), '==', 1, '... get option 0'); cmp_ok($stuff->get_first_option, '==', 1, '... get first'); cmp_ok($stuff->get_last_option, '==', 10, '... get last'); is_deeply( [ $stuff->filter_options(sub { $_[0] % 2 == 0 }) ], [ 2, 4, 6, 8, 10 ], '... got the right filtered values' ); is_deeply( [ $stuff->map_options(sub { $_[0] * 2 }) ], [ 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 ], '... got the right mapped values' ); is($stuff->find_option(sub { $_[0] % 2 == 0 }), 2, '.. found the right option'); is_deeply([ $stuff->options ], [1 .. 10], '... got the list of options'); is($stuff->join_options(':'), '1:2:3:4:5:6:7:8:9:10', '... joined the list of options by :'); is_deeply([ $stuff->sorted_options ], [sort (1..10)], '... got sorted options (default sort order)'); is_deeply([ $stuff->sorted_options( sub { $_[1] <=> $_[0] } ) ], [sort { $b <=> $a } (1..10)], '... got sorted options (descending sort order) '); throws_ok { $stuff->sorted_options('foo') } qr/Argument must be a code reference/, 'error when sort receives a non-coderef argument'; # test the currying is_deeply([ $stuff->less_than_five() ], [1 .. 4]); is_deeply([ $stuff->up_by_one() ], [2 .. 11]); is($stuff->dashify, '1-2-3-4-5-6-7-8-9-10'); $stuff->animals([ qw/cat duck horse cattle gorilla elephant flamingo kangaroo/ ]); # 4 * 2 = 8 is_deeply( [ sort $stuff->double_length_of('fish') ], [ sort qw/elephant flamingo kangaroo/ ], 'returns all elements with double length of string "fish"' ); is_deeply([$stuff->descending], [reverse 1 .. 10]); ## test the meta my $options = $stuff->meta->get_attribute('_options'); isa_ok($options, 'MooseX::AttributeHelpers::Collection::List'); is_deeply($options->provides, { 'map' => 'map_options', 'grep' => 'filter_options', 'find' => 'find_option', 'count' => 'num_options', 'empty' => 'has_options', 'elements' => 'options', 'join' => 'join_options', 'get' => 'get_option_at', 'first' => 'get_first_option', 'last' => 'get_last_option', 'sort' => 'sorted_options', }, '... got the right provides mapping'); is($options->type_constraint->type_parameter, 'Int', '... got the right container type'); dies_ok { $stuff->sort_in_place_options( undef ); } '... sort rejects arg of invalid type'; MooseX-AttributeHelpers-0.23/t/011_counter_with_defaults.t0000644000175000017500000000231711166253053023413 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 14; BEGIN { use_ok('MooseX::AttributeHelpers'); } { package MyHomePage; use Moose; has 'counter' => (metaclass => 'Counter'); } my $page = MyHomePage->new(); isa_ok($page, 'MyHomePage'); can_ok($page, $_) for qw[ dec_counter inc_counter reset_counter ]; is($page->counter, 0, '... got the default value'); $page->inc_counter; is($page->counter, 1, '... got the incremented value'); $page->inc_counter; is($page->counter, 2, '... got the incremented value (again)'); $page->dec_counter; is($page->counter, 1, '... got the decremented value'); $page->reset_counter; is($page->counter, 0, '... got the original value'); # check the meta .. my $counter = $page->meta->get_attribute('counter'); isa_ok($counter, 'MooseX::AttributeHelpers::Counter'); is($counter->helper_type, 'Num', '... got the expected helper type'); is($counter->type_constraint->name, 'Num', '... got the expected default type constraint'); is_deeply($counter->provides, { inc => 'inc_counter', dec => 'dec_counter', reset => 'reset_counter', set => 'set_counter', }, '... got the right default provides methods'); MooseX-AttributeHelpers-0.23/t/pod_coverage.t0000644000175000017500000000042611166253053021065 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Pod tests run only authors" unless -e "inc/.author"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; all_pod_coverage_ok(); MooseX-AttributeHelpers-0.23/t/203_trait_hash.t0000644000175000017500000001104011253523274021136 0ustar autarchautarch#!/usr/bin/perl use strict; use warnings; use Test::More tests => 47; use Test::Exception; use Test::Moose 'does_ok'; BEGIN { use_ok('MooseX::AttributeHelpers'); } { package Stuff; use Moose; use MooseX::AttributeHelpers; has 'options' => ( traits => [qw/MooseX::AttributeHelpers::Trait::Collection::Hash/], is => 'ro', isa => 'HashRef[Str]', default => sub { {} }, provides => { 'set' => 'set_option', 'get' => 'get_option', 'empty' => 'has_options', 'count' => 'num_options', 'clear' => 'clear_options', 'delete' => 'delete_option', 'exists' => 'has_option', 'defined' => 'is_defined', 'accessor' => 'option_accessor', 'kv' => 'key_value', 'elements' => 'options_elements', }, curries => { 'accessor' => { quantity => ['quantity'], }, } ); } my $stuff = Stuff->new(); isa_ok($stuff, 'Stuff'); can_ok($stuff, $_) for qw[ set_option get_option has_options num_options delete_option clear_options is_defined has_option quantity option_accessor ]; ok(!$stuff->has_options, '... we have no options'); is($stuff->num_options, 0, '... we have no options'); is_deeply($stuff->options, {}, '... no options yet'); ok(!$stuff->has_option('foo'), '... we have no foo option'); lives_ok { $stuff->set_option(foo => 'bar'); } '... set the option okay'; ok($stuff->is_defined('foo'), '... foo is defined'); ok($stuff->has_options, '... we have options'); is($stuff->num_options, 1, '... we have 1 option(s)'); ok($stuff->has_option('foo'), '... we have a foo option'); is_deeply($stuff->options, { foo => 'bar' }, '... got options now'); lives_ok { $stuff->set_option(bar => 'baz'); } '... set the option okay'; is($stuff->num_options, 2, '... we have 2 option(s)'); is_deeply($stuff->options, { foo => 'bar', bar => 'baz' }, '... got more options now'); is($stuff->get_option('foo'), 'bar', '... got the right option'); is_deeply([ $stuff->get_option(qw(foo bar)) ], [qw(bar baz)], "get multiple options at once"); lives_ok { $stuff->set_option(oink => "blah", xxy => "flop"); } '... set the option okay'; is($stuff->num_options, 4, "4 options"); is_deeply([ $stuff->get_option(qw(foo bar oink xxy)) ], [qw(bar baz blah flop)], "get multiple options at once"); lives_ok { $stuff->delete_option('bar'); } '... deleted the option okay'; lives_ok { $stuff->delete_option('oink'); } '... deleted the option okay'; lives_ok { $stuff->delete_option('xxy'); } '... deleted the option okay'; is($stuff->num_options, 1, '... we have 1 option(s)'); is_deeply($stuff->options, { foo => 'bar' }, '... got more options now'); $stuff->clear_options; is_deeply($stuff->options, { }, "... cleared options" ); lives_ok { $stuff->quantity(4); } '... options added okay with defaults'; is($stuff->quantity, 4, 'reader part of curried accessor works'); is_deeply($stuff->options, {quantity => 4}, '... returns what we expect'); lives_ok { Stuff->new(options => { foo => 'BAR' }); } '... good constructor params'; ## check some errors dies_ok { $stuff->set_option(bar => {}); } '... could not add a hash ref where an string is expected'; dies_ok { Stuff->new(options => { foo => [] }); } '... bad constructor params'; ## test the meta my $options = $stuff->meta->get_attribute('options'); does_ok($options, 'MooseX::AttributeHelpers::Trait::Collection::Hash'); is_deeply($options->provides, { 'set' => 'set_option', 'get' => 'get_option', 'empty' => 'has_options', 'count' => 'num_options', 'clear' => 'clear_options', 'delete' => 'delete_option', 'defined' => 'is_defined', 'exists' => 'has_option', 'accessor' => 'option_accessor', 'kv' => 'key_value', 'elements' => 'options_elements', }, '... got the right provides mapping'); is($options->type_constraint->type_parameter, 'Str', '... got the right container type'); $stuff->set_option( oink => "blah", xxy => "flop" ); my @key_value = $stuff->key_value; is_deeply( \@key_value, [ [ 'xxy', 'flop' ], [ 'quantity', 4 ], [ 'oink', 'blah' ] ], '... got the right key value pairs' ); my %options_elements = $stuff->options_elements; is_deeply( \%options_elements, { 'oink' => 'blah', 'quantity' => 4, 'xxy' => 'flop' }, '... got the right hash elements' ); MooseX-AttributeHelpers-0.23/ChangeLog0000644000175000017500000001405011317442730017550 0ustar autarchautarchRevision history for Perl extension MooseX-AttributeHelpers 0.23 Fri Jan 1, 2010 - A small internals fix to prevent breakage with the next version of Moose. (Dave Rolsky) 0.22 Mon Sep 14, 2009 - Fix to work with Moose 0.90. Ignore meta when auto-providing a method provider's methods. (Dave Rolsky) 0.21 Sun July 19, 2009 - Add length to String (Florian Ragwitz). - Specify build dependency on Test::Moose (Closes RT#47258) (Florian Ragwitz). - Fix the error message you get on unknown 'curries' parameters to tell you what it really expected (Florian Ragwitz). - Doc typo fix in Collection::Bag (Sartak). 0.20 Thu June 25, 2009 - MXAH is moving into core. This module will be deprecated when that finally happens. - Remove register_implementation methods from the traits because we don't want to conflict with cored AttributeHelpers. You'll need to specify the full package name for traits -- MooseX::AttributeHelpers::Trait::Counter instead of Counter - New provided method for hashs: elements (Returns the key, value pairs in the hash as a flattened list) (plu) 0.19 Sun June 14, 2009 - No functional changes from 0.18_01 0.18_01 Mon June 1, 2009 - Turn our metaclasses into traits, though metaclasses still exist for backwards compatibility (Sartak and doy) - Add accessor to Hash and Array (Sartak) - Let the user know which constraint they have violated in the confessed message (nperez) 0.17 Fri April 19, 2009 - Add defined to Hash (Evan Carroll). 0.16 Sun April 5, 2009 - Add substr to String (Florian Ragwitz). 0.15 Thu March 26, 2009 - The splice helper for arrays was completely broken. Reported by Abhijit Mahabal. RT #43343. 0.14 Thu October 2, 2008 - Run pod tests only for authors 0.13 Mon September 1, 2008 - No code changes, just a stable release for Moose 0.56. 0.12_01 Wed August 20, 2008 - fixed some missing Pod::Coverage (stevan) - fixes to work with Moose 0.55_01 and Class::MOP 0.64_01 (nothingmuch) 0.12 Sun. Jun 29, 2008 - Move get from Array to List (gphat) - Add first and last to List (gphat) - Doc fixes (gphat) - fix failing tests due to using DateTime (jasonmay) 0.11 Thurs. Jun 26, 2008 - add the ability to curry method providers (thanks to jasonmay) - Counter: add set and allow inc and dec to accept args - add Bool as an attribute helper (thanks to jasonmay) - bump all modules to version 0.11 for consistency (Sartak) 0.09 Sat. May 24, 2008 - remove Module::Build in favor of Module::Install * MooseX::AttributeHelpers::MethodProvider::Hash - delete with multiple keys will now work (thanks to frodwith) * MooseX::AttributeHelpers::MethodProvider::List - add "join" and "elements" provided methods (thanks to Sartak) * MooseX::AttributeHelpers::MethodProvider::Array - add "splice" provided method 0.08 Sat. April 12, 2008 ~~ updates copyright year on all modules ~~ * MooseX::AttributeHelpers::MethodProvider::Hash - fixed bug in non-type constraint version of set method (thanks to frodwith) 0.07 Tues. Jan. 1, 2008 * MooseX::AttributeHelpers::String - Initial version * MooseX::AttributeHelpers::Hash - get and set now support aggregate operations 0.06 Tues. Dec. 7, 2007 * MooseX::AttributeHelpers::Base - added the &remove_accessors method to comply with the Class::MOP::Attribute interface - added test for this - the &install_accessors method now also properly assocaites the methods with the attribute, so they are accessible via introspection now. 0.05 Sat. Nov. 24, 2007 - update Class::MOP dependency - hide the Moose::Meta::Attribute::Custom::* package declarations from search.cpan.org (when did they change things to start seeing these?? *sigh*) 0.04 Fri. Nov. 23, 2007 * MooseX::AttributeHelpers::Base - changing this to use the new Class::MOP::Attribute reader and write method ref stuff. - fixed this to use find_or_create_type_constraint instead of trying to parse stuff on our own. * MooseX::AttributeHelpers::Collection - this is pretty much empty subclass now cause of the find_or_create_type_constraint fix above + MooseX::AttributeHelpers::Collection::ImmutableHash + MooseX::AttributeHelpers::Collection::Bag - added these two new collection types - added method provider roles for them - added tests for them * MooseX::AttributeHelpers::MethodProvider::Hash - this is now composed from the ImmutableHash method provider * t/ - fixed the plans on all the tests 0.03 Mon. Sept. 17, 2007 ~~ more misc. doc updates ~~ * MooseX::AttributeHelpers::Counter - now provides default attribute options for 'is', 'isa', 'provides', and 'default' if not specified. * MooseX::AttributeHelpers::Base - added attribute $name to the params passed to process_options_or_provides(), which gives us more flexibility when writing additional helpers - removed check for 'provides' and 'isa' attr options before _process_options. It should be called always. * MooseX::AttributeHelpers::MethodProvider::Array - added `delete` and `insert` methods 0.02 Thurs. Sept. 13, 2007 ~~ some misc. doc updates ~~ * MooseX::AttributeHelpers::Base - now providing subrefs for the reader and writer methods to all the method provider constructors (this should speed things up quite a bit). - all method providers now use this internally * MooseX::AttributeHelpers::Counter - added the 'reset' method * MooseX::AttributeHelpers::Collection::Array - Extracted the List method provider role from Array and made Array consume List. + MooseX::AttributeHelpers::Collection::List - created the Collection::List metaclass derived from parts of the old Collection::Array 0.01 Mon. Aug. 13, 2007 - module released to CPAN MooseX-AttributeHelpers-0.23/inc/0000755000175000017500000000000011317443272016551 5ustar autarchautarchMooseX-AttributeHelpers-0.23/inc/Module/0000755000175000017500000000000011317443272017776 5ustar autarchautarchMooseX-AttributeHelpers-0.23/inc/Module/Install.pm0000644000175000017500000002411411317443271021743 0ustar autarchautarch#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 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 = '0.91'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } # 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 # 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)); use Cwd (); use File::Find (); use File::Path (); use FindBin; 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; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; 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 import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; unless ( -f $self->{file} ) { 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"}; } *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; # Save to the singleton $MAIN = $self; return 1; } 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 ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # 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) = @_; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $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; } sub _read { local *FH; if ( $] >= 5.006 ) { open( FH, '<', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "< $_[0]" ) or die "open($_[0]): $!"; } my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } 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; } sub _write { local *FH; if ( $] >= 5.006 ) { open( FH, '>', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "> $_[0]" ) or die "open($_[0]): $!"; } foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _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($_[0]) <=> _version($_[1]); } # 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 - 2009 Adam Kennedy. MooseX-AttributeHelpers-0.23/inc/Module/Install/0000755000175000017500000000000011317443272021404 5ustar autarchautarchMooseX-AttributeHelpers-0.23/inc/Module/Install/WriteAll.pm0000644000175000017500000000222211317443272023463 0ustar autarchautarch#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91';; @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} ) { $self->makemaker_args( PL_FILES => {} ); } # 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; MooseX-AttributeHelpers-0.23/inc/Module/Install/Fetch.pm0000644000175000017500000000462711317443272023004 0ustar autarchautarch#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; MooseX-AttributeHelpers-0.23/inc/Module/Install/Base.pm0000644000175000017500000000176611317443272022626 0ustar autarchautarch#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '0.91'; } # 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->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 154 MooseX-AttributeHelpers-0.23/inc/Module/Install/Can.pm0000644000175000017500000000333311317443272022445 0ustar autarchautarch#line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 MooseX-AttributeHelpers-0.23/inc/Module/Install/Metadata.pm0000644000175000017500000003530411317443272023467 0ustar autarchautarch#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract author 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 }; 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; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } 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 reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', 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()' ); $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } 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"); } # 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) ); } 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 perl_version_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ^ (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; $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; $author =~ s{E}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } sub license_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ( =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b .*? ) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = $1; my @phrases = ( 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => '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, 'BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s{\s+}{\\s+}g; if ( $license_text =~ /\b$pattern\b/i ) { $self->license($license); return 1; } } } warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } sub _extract_bugtracker { my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g; 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 on rt.cpan.org 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+([\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; } ###################################################################### # 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; MooseX-AttributeHelpers-0.23/inc/Module/Install/Makefile.pm0000644000175000017500000001600311317443272023457 0ustar autarchautarch#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @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, always use defaults if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } sub makemaker_args { my $self = shift; my $args = ( $self->{makemaker_args} ||= {} ); %$args = ( %$args, @_ ); return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = sShift; 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 ); } my %test_dir = (); sub _wanted_t { /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; if ( $self->tests ) { die "tests_recursive will not work if tests are already defined"; } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } %test_dir = (); require File::Find; File::Find::find( \&_wanted_t, $dir ); $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } 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 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); } 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.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{VERSION} = $self->version; $args->{NAME} =~ s/-/::/g; if ( $self->tests ) { $args->{test} = { TESTS => $self->tests }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } # Merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->configure_requires, $self->build_requires, $self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # merge both kinds of requires into prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $prereq->{$file}; } } 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"; } $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: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $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; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; 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 394 MooseX-AttributeHelpers-0.23/inc/Module/Install/Win32.pm0000644000175000017500000000340311317443272022644 0ustar autarchautarch#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; MooseX-AttributeHelpers-0.23/META.yml0000644000175000017500000001051711317443272017255 0ustar autarchautarch--- abstract: 'Extend your attribute interfaces (deprecated)' author: - 'Stevan Little ' build_requires: ExtUtils::MakeMaker: 6.42 Test::Exception: 0.21 Test::Moose: 0 Test::More: 0.62 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 0.91' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: MooseX-AttributeHelpers no_index: directory: - inc - t provides: MooseX::AttributeHelpers: file: lib/MooseX/AttributeHelpers.pm version: 0.23 MooseX::AttributeHelpers::Bool: file: lib/MooseX/AttributeHelpers/Bool.pm version: 0.23 MooseX::AttributeHelpers::Collection::Array: file: lib/MooseX/AttributeHelpers/Collection/Array.pm version: 0.23 MooseX::AttributeHelpers::Collection::Bag: file: lib/MooseX/AttributeHelpers/Collection/Bag.pm version: 0.23 MooseX::AttributeHelpers::Collection::Hash: file: lib/MooseX/AttributeHelpers/Collection/Hash.pm version: 0.23 MooseX::AttributeHelpers::Collection::ImmutableHash: file: lib/MooseX/AttributeHelpers/Collection/ImmutableHash.pm version: 0.23 MooseX::AttributeHelpers::Collection::List: file: lib/MooseX/AttributeHelpers/Collection/List.pm version: 0.23 MooseX::AttributeHelpers::Counter: file: lib/MooseX/AttributeHelpers/Counter.pm version: 0.23 MooseX::AttributeHelpers::Meta::Method::Curried: file: lib/MooseX/AttributeHelpers/Meta/Method/Curried.pm version: 0.23 MooseX::AttributeHelpers::Meta::Method::Provided: file: lib/MooseX/AttributeHelpers/Meta/Method/Provided.pm version: 0.23 MooseX::AttributeHelpers::MethodProvider::Array: file: lib/MooseX/AttributeHelpers/MethodProvider/Array.pm version: 0.23 MooseX::AttributeHelpers::MethodProvider::Bag: file: lib/MooseX/AttributeHelpers/MethodProvider/Bag.pm version: 0.23 MooseX::AttributeHelpers::MethodProvider::Bool: file: lib/MooseX/AttributeHelpers/MethodProvider/Bool.pm version: 0.23 MooseX::AttributeHelpers::MethodProvider::Counter: file: lib/MooseX/AttributeHelpers/MethodProvider/Counter.pm version: 0.23 MooseX::AttributeHelpers::MethodProvider::Hash: file: lib/MooseX/AttributeHelpers/MethodProvider/Hash.pm version: 0.23 MooseX::AttributeHelpers::MethodProvider::ImmutableHash: file: lib/MooseX/AttributeHelpers/MethodProvider/ImmutableHash.pm version: 0.23 MooseX::AttributeHelpers::MethodProvider::List: file: lib/MooseX/AttributeHelpers/MethodProvider/List.pm version: 0.23 MooseX::AttributeHelpers::MethodProvider::String: file: lib/MooseX/AttributeHelpers/MethodProvider/String.pm version: 0.23 MooseX::AttributeHelpers::Number: file: lib/MooseX/AttributeHelpers/Number.pm version: 0.23 MooseX::AttributeHelpers::String: file: lib/MooseX/AttributeHelpers/String.pm version: 0.23 MooseX::AttributeHelpers::Trait::Base: file: lib/MooseX/AttributeHelpers/Trait/Base.pm version: 0.23 MooseX::AttributeHelpers::Trait::Bool: file: lib/MooseX/AttributeHelpers/Trait/Bool.pm version: 0.23 MooseX::AttributeHelpers::Trait::Collection: file: lib/MooseX/AttributeHelpers/Trait/Collection.pm version: 0.23 MooseX::AttributeHelpers::Trait::Collection::Array: file: lib/MooseX/AttributeHelpers/Trait/Collection/Array.pm version: 0.23 MooseX::AttributeHelpers::Trait::Collection::Bag: file: lib/MooseX/AttributeHelpers/Trait/Collection/Bag.pm version: 0.23 MooseX::AttributeHelpers::Trait::Collection::Hash: file: lib/MooseX/AttributeHelpers/Trait/Collection/Hash.pm version: 0.23 MooseX::AttributeHelpers::Trait::Collection::ImmutableHash: file: lib/MooseX/AttributeHelpers/Trait/Collection/ImmutableHash.pm version: 0.23 MooseX::AttributeHelpers::Trait::Collection::List: file: lib/MooseX/AttributeHelpers/Trait/Collection/List.pm version: 0.23 MooseX::AttributeHelpers::Trait::Counter: file: lib/MooseX/AttributeHelpers/Trait/Counter.pm version: 0.23 MooseX::AttributeHelpers::Trait::Number: file: lib/MooseX/AttributeHelpers/Trait/Number.pm version: 0.23 MooseX::AttributeHelpers::Trait::String: file: lib/MooseX/AttributeHelpers/Trait/String.pm version: 0.23 requires: Moose: 0.56 resources: license: http://dev.perl.org/licenses/ version: 0.23 MooseX-AttributeHelpers-0.23/README0000644000175000017500000000103711317442720016656 0ustar autarchautarchMooseX::AttributeHelpers version 0.23 =========================== See the individual module documentation for more information INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES This module requires these other modules and libraries: Moose COPYRIGHT AND LICENCE Copyright (C) 2007-2009 Infinity Interactive, Inc. http://www.iinteractive.com This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. MooseX-AttributeHelpers-0.23/MANIFEST0000644000175000017500000000430711253524365017137 0ustar autarchautarchChangeLog inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/MooseX/AttributeHelpers.pm lib/MooseX/AttributeHelpers/Bool.pm lib/MooseX/AttributeHelpers/Collection/Array.pm lib/MooseX/AttributeHelpers/Collection/Bag.pm lib/MooseX/AttributeHelpers/Collection/Hash.pm lib/MooseX/AttributeHelpers/Collection/ImmutableHash.pm lib/MooseX/AttributeHelpers/Collection/List.pm lib/MooseX/AttributeHelpers/Counter.pm lib/MooseX/AttributeHelpers/Meta/Method/Curried.pm lib/MooseX/AttributeHelpers/Meta/Method/Provided.pm lib/MooseX/AttributeHelpers/MethodProvider/Array.pm lib/MooseX/AttributeHelpers/MethodProvider/Bag.pm lib/MooseX/AttributeHelpers/MethodProvider/Bool.pm lib/MooseX/AttributeHelpers/MethodProvider/Counter.pm lib/MooseX/AttributeHelpers/MethodProvider/Hash.pm lib/MooseX/AttributeHelpers/MethodProvider/ImmutableHash.pm lib/MooseX/AttributeHelpers/MethodProvider/List.pm lib/MooseX/AttributeHelpers/MethodProvider/String.pm lib/MooseX/AttributeHelpers/Number.pm lib/MooseX/AttributeHelpers/String.pm lib/MooseX/AttributeHelpers/Trait/Base.pm lib/MooseX/AttributeHelpers/Trait/Bool.pm lib/MooseX/AttributeHelpers/Trait/Collection.pm lib/MooseX/AttributeHelpers/Trait/Collection/Array.pm lib/MooseX/AttributeHelpers/Trait/Collection/Bag.pm lib/MooseX/AttributeHelpers/Trait/Collection/Hash.pm lib/MooseX/AttributeHelpers/Trait/Collection/ImmutableHash.pm lib/MooseX/AttributeHelpers/Trait/Collection/List.pm lib/MooseX/AttributeHelpers/Trait/Counter.pm lib/MooseX/AttributeHelpers/Trait/Number.pm lib/MooseX/AttributeHelpers/Trait/String.pm Makefile.PL MANIFEST This list of files META.yml README t/000_load.t t/001_basic_counter.t t/002_basic_array.t t/003_basic_hash.t t/004_basic_number.t t/005_basic_list.t t/006_basic_bag.t t/007_basic_string.t t/010_array_from_role.t t/011_counter_with_defaults.t t/012_basic_bool.t t/020_remove_attribute.t t/100_collection_with_roles.t t/201_trait_counter.t t/202_trait_array.t t/203_trait_hash.t t/204_trait_number.t t/205_trait_list.t t/206_trait_bag.t t/207_trait_string.t t/208_trait_bool.t t/pod.t t/pod_coverage.t MooseX-AttributeHelpers-0.23/Makefile.PL0000644000175000017500000000045111253523274017752 0ustar autarchautarchuse inc::Module::Install; name 'MooseX-AttributeHelpers'; license 'perl'; all_from 'lib/MooseX/AttributeHelpers.pm'; requires 'Moose' => '0.56'; build_requires 'Test::More' => '0.62'; build_requires 'Test::Exception' => '0.21'; build_requires 'Test::Moose'; auto_provides; WriteAll(); MooseX-AttributeHelpers-0.23/lib/0000755000175000017500000000000011317443272016546 5ustar autarchautarchMooseX-AttributeHelpers-0.23/lib/MooseX/0000755000175000017500000000000011317443272017760 5ustar autarchautarchMooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers.pm0000644000175000017500000001313211317443255023605 0ustar autarchautarch package MooseX::AttributeHelpers; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; use Moose 0.56 (); use MooseX::AttributeHelpers::Meta::Method::Provided; use MooseX::AttributeHelpers::Meta::Method::Curried; use MooseX::AttributeHelpers::Trait::Bool; use MooseX::AttributeHelpers::Trait::Counter; use MooseX::AttributeHelpers::Trait::Number; use MooseX::AttributeHelpers::Trait::String; use MooseX::AttributeHelpers::Trait::Collection::List; use MooseX::AttributeHelpers::Trait::Collection::Array; use MooseX::AttributeHelpers::Trait::Collection::Hash; use MooseX::AttributeHelpers::Trait::Collection::ImmutableHash; use MooseX::AttributeHelpers::Trait::Collection::Bag; use MooseX::AttributeHelpers::Counter; use MooseX::AttributeHelpers::Number; use MooseX::AttributeHelpers::String; use MooseX::AttributeHelpers::Bool; use MooseX::AttributeHelpers::Collection::List; use MooseX::AttributeHelpers::Collection::Array; use MooseX::AttributeHelpers::Collection::Hash; use MooseX::AttributeHelpers::Collection::ImmutableHash; use MooseX::AttributeHelpers::Collection::Bag; 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers - Extend your attribute interfaces (deprecated) =head1 SYNOPSIS package MyClass; use Moose; use MooseX::AttributeHelpers; has 'mapping' => ( metaclass => 'Collection::Hash', is => 'rw', isa => 'HashRef[Str]', default => sub { {} }, provides => { exists => 'exists_in_mapping', keys => 'ids_in_mapping', get => 'get_mapping', set => 'set_mapping', }, curries => { set => { set_quantity => [ 'quantity' ] } } ); # ... my $obj = MyClass->new; $obj->set_quantity(10); # quantity => 10 $obj->set_mapping(4, 'foo'); # 4 => 'foo' $obj->set_mapping(5, 'bar'); # 5 => 'bar' $obj->set_mapping(6, 'baz'); # 6 => 'baz' # prints 'bar' print $obj->get_mapping(5) if $obj->exists_in_mapping(5); # prints '4, 5, 6' print join ', ', $obj->ids_in_mapping; =head1 DESCRIPTION B. This distribution should not be used by any new code.> While L attributes provide you with a way to name your accessors, readers, writers, clearers and predicates, this library provides commonly used attribute helper methods for more specific types of data. As seen in the L, you specify the extension via the C parameter. Available meta classes are: =head1 PARAMETERS =head2 provides This points to a hashref that uses C for the keys and C for the values. The method will be added to the object itself and do what you want. =head2 curries This points to a hashref that uses C for the keys and has two choices for the value: You can supply C<< {method => [ @args ]} >> for the values. The method will be added to the object itself (always using C<@args> as the beginning arguments). Another approach to curry a method provider is to supply a coderef instead of an arrayref. The code ref takes C<$self>, C<$body>, and any additional arguments passed to the final method. # ... curries => { grep => { times_with_day => sub { my ($self, $body, $datetime) = @_; $body->($self, sub { $_->ymd eq $datetime->ymd }); } } } # ... $obj->times_with_day(DateTime->now); # takes datetime argument, checks day =head1 METHOD PROVIDERS =over =item L Common numerical operations. =item L Common methods for string operations. =item L Methods for incrementing and decrementing a counter attribute. =item L Common methods for boolean values. =item L Common methods for hash references. =item L Common methods for inspecting hash references. =item L Common methods for array references. =item L Common list methods for array references. =back =head1 CAVEAT This is an early release of this module. Right now it is in great need of documentation and tests in the test suite. However, we have used this module to great success at C<$work> where it has been tested very thoroughly and deployed into a major production site. I plan on getting better docs and tests in the next few releases, but until then please refer to the few tests we do have and feel free email and/or message me on irc.perl.org if you have any questions. =head1 TODO We need tests and docs badly. =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 AUTHOR Stevan Little Estevan@iinteractive.comE B Robert (rlb3) Boone Paul (frodwith) Driver Shawn (Sartak) Moore Chris (perigrin) Prather Robert (phaylon) Sedlacek Tom (dec) Lanyon Yuval Kogman Jason May Cory (gphat) Watson Florian (rafl) Ragwitz Evan Carroll Jesse (doy) Luehrs =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/0000755000175000017500000000000011317443272023246 5ustar autarchautarchMooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Meta/0000755000175000017500000000000011317443272024134 5ustar autarchautarchMooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Meta/Method/0000755000175000017500000000000011317443272025354 5ustar autarchautarchMooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Meta/Method/Provided.pm0000644000175000017500000000154211317442720027465 0ustar autarchautarch package MooseX::AttributeHelpers::Meta::Method::Provided; use Moose; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; extends 'Moose::Meta::Method'; 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::Meta::Method::Provided =head1 DESCRIPTION This is an extension of Moose::Meta::Method to mark I methods. =head1 METHODS =over 4 =item B =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Meta/Method/Curried.pm0000644000175000017500000000153711317442720027312 0ustar autarchautarch package MooseX::AttributeHelpers::Meta::Method::Curried; use Moose; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; extends 'Moose::Meta::Method'; 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::Meta::Method::Curried =head1 DESCRIPTION This is an extension of Moose::Meta::Method to mark I methods. =head1 METHODS =over 4 =item B =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Number.pm0000644000175000017500000000447311317442720025041 0ustar autarchautarchpackage MooseX::AttributeHelpers::Number; use Moose; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; extends 'Moose::Meta::Attribute'; with 'MooseX::AttributeHelpers::Trait::Number'; no Moose; # register the alias ... package # hide me from search.cpan.org Moose::Meta::Attribute::Custom::Number; sub register_implementation { 'MooseX::AttributeHelpers::Number' } 1; =pod =head1 NAME MooseX::AttributeHelpers::Number =head1 SYNOPSIS package Real; use Moose; use MooseX::AttributeHelpers; has 'integer' => ( metaclass => 'Number', is => 'ro', isa => 'Int', default => sub { 5 }, provides => { 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 METHODS =over 4 =item B =item B =item B =back =head1 PROVIDED METHODS It is important to note that all those methods do in place modification of the value stored in the attribute. =over 4 =item I Alternate way to set the value. =item I Adds the current value of the attribute to C<$value>. =item I Subtracts the current value of the attribute to C<$value>. =item I Multiplies the current value of the attribute to C<$value>. =item I
Divides the current value of the attribute to C<$value>. =item I Modulus the current value of the attribute to C<$value>. =item I Sets the current value of the attribute to its absolute value. =back =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 AUTHOR Robert Boone =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Counter.pm0000644000175000017500000000225711317442720025226 0ustar autarchautarch package MooseX::AttributeHelpers::Counter; use Moose; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; extends 'Moose::Meta::Attribute'; with 'MooseX::AttributeHelpers::Trait::Counter'; no Moose; # register the alias ... package # hide me from search.cpan.org Moose::Meta::Attribute::Custom::Counter; sub register_implementation { 'MooseX::AttributeHelpers::Counter' } 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::Counter =head1 METHODS =over 4 =item B =item B =item B =item B =item B Run before its superclass method. =item B Run after its superclass method. =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Trait/0000755000175000017500000000000011317443272024331 5ustar autarchautarchMooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Trait/Number.pm0000644000175000017500000000707511317442720026125 0ustar autarchautarchpackage MooseX::AttributeHelpers::Trait::Number; use Moose::Role; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; with 'MooseX::AttributeHelpers::Trait::Base'; sub helper_type { 'Num' } # NOTE: # we don't use the method provider for this # module since many of the names of the provied # methods would conflict with keywords # - SL has 'method_constructors' => ( is => 'ro', isa => 'HashRef', lazy => 1, default => sub { return +{ set => sub { my ($attr, $reader, $writer) = @_; return sub { $writer->($_[0], $_[1]) }; }, add => sub { my ($attr, $reader, $writer) = @_; return sub { $writer->($_[0], $reader->($_[0]) + $_[1]) }; }, sub => sub { my ($attr, $reader, $writer) = @_; return sub { $writer->($_[0], $reader->($_[0]) - $_[1]) }; }, mul => sub { my ($attr, $reader, $writer) = @_; return sub { $writer->($_[0], $reader->($_[0]) * $_[1]) }; }, div => sub { my ($attr, $reader, $writer) = @_; return sub { $writer->($_[0], $reader->($_[0]) / $_[1]) }; }, mod => sub { my ($attr, $reader, $writer) = @_; return sub { $writer->($_[0], $reader->($_[0]) % $_[1]) }; }, abs => sub { my ($attr, $reader, $writer) = @_; return sub { $writer->($_[0], abs($reader->($_[0])) ) }; }, } } ); no Moose::Role; 1; =pod =head1 NAME MooseX::AttributeHelpers::Number =head1 SYNOPSIS package Real; use Moose; use MooseX::AttributeHelpers; has 'integer' => ( metaclass => 'Number', is => 'ro', isa => 'Int', default => sub { 5 }, provides => { 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 METHODS =over 4 =item B =item B =item B =back =head1 PROVIDED METHODS It is important to note that all those methods do in place modification of the value stored in the attribute. =over 4 =item I Alternate way to set the value. =item I Adds the current value of the attribute to C<$value>. =item I Subtracts the current value of the attribute to C<$value>. =item I Multiplies the current value of the attribute to C<$value>. =item I
Divides the current value of the attribute to C<$value>. =item I Modulus the current value of the attribute to C<$value>. =item I Sets the current value of the attribute to its absolute value. =back =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 AUTHOR Robert Boone =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Trait/Counter.pm0000644000175000017500000000701711317442720026310 0ustar autarchautarch package MooseX::AttributeHelpers::Trait::Counter; use Moose::Role; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; use MooseX::AttributeHelpers::MethodProvider::Counter; with 'MooseX::AttributeHelpers::Trait::Base'; has 'method_provider' => ( is => 'ro', isa => 'ClassName', predicate => 'has_method_provider', default => 'MooseX::AttributeHelpers::MethodProvider::Counter', ); sub helper_type { 'Num' } before 'process_options_for_provides' => sub { my ($self, $options, $name) = @_; # Set some default attribute options here unless already defined if ((my $type = $self->helper_type) && !exists $options->{isa}){ $options->{isa} = $type; } $options->{is} = 'ro' unless exists $options->{is}; $options->{default} = 0 unless exists $options->{default}; }; after 'check_provides_values' => sub { my $self = shift; my $provides = $self->provides; unless (scalar keys %$provides) { my $method_constructors = $self->method_constructors; my $attr_name = $self->name; foreach my $method (keys %$method_constructors) { $provides->{$method} = ($method . '_' . $attr_name); } } }; no Moose::Role; 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::Counter =head1 SYNOPSIS package MyHomePage; use Moose; use MooseX::AttributeHelpers; has 'counter' => ( metaclass => 'Counter', is => 'ro', isa => 'Num', default => sub { 0 }, provides => { inc => 'inc_counter', dec => 'dec_counter', reset => 'reset_counter', } ); 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 decremeneted. If your attribute definition does not include any of I, I, I or I but does use the C metaclass, then this module applies defaults as in the L above. This allows for a very basic counter definition: has 'foo' => (metaclass => 'Counter'); $obj->inc_foo; =head1 METHODS =over 4 =item B =item B =item B =item B =item B Run before its superclass method. =item B Run after its superclass method. =back =head1 PROVIDED METHODS It is important to note that all those methods do in place modification of the value stored in the attribute. =over 4 =item I Set the counter to the specified value. =item I Increments the value stored in this slot by 1. Providing an argument will cause the counter to be increased by specified amount. =item I Decrements the value stored in this slot by 1. Providing an argument will cause the counter to be increased by specified amount. =item I Resets the value stored in this slot to it's default value. =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Trait/Collection/0000755000175000017500000000000011317443272026424 5ustar autarchautarchMooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Trait/Collection/List.pm0000644000175000017500000000321511317442720027673 0ustar autarchautarch package MooseX::AttributeHelpers::Trait::Collection::List; use Moose::Role; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; use MooseX::AttributeHelpers::MethodProvider::List; with 'MooseX::AttributeHelpers::Trait::Collection'; has 'method_provider' => ( is => 'ro', isa => 'ClassName', predicate => 'has_method_provider', default => 'MooseX::AttributeHelpers::MethodProvider::List' ); sub helper_type { 'ArrayRef' } no Moose::Role; 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::Collection::List =head1 SYNOPSIS package Stuff; use Moose; use MooseX::AttributeHelpers; has 'options' => ( metaclass => 'Collection::List', is => 'ro', isa => 'ArrayRef[Int]', default => sub { [] }, provides => { map => 'map_options', grep => 'filter_options', } ); =head1 DESCRIPTION This module provides an List attribute which provides a number of list operations. See L for more details. =head1 METHODS =over 4 =item B =item B =item B =item B =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Trait/Collection/Array.pm0000644000175000017500000000323511317442720030040 0ustar autarchautarch package MooseX::AttributeHelpers::Trait::Collection::Array; use Moose::Role; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; use MooseX::AttributeHelpers::MethodProvider::Array; with 'MooseX::AttributeHelpers::Trait::Collection'; has 'method_provider' => ( is => 'ro', isa => 'ClassName', predicate => 'has_method_provider', default => 'MooseX::AttributeHelpers::MethodProvider::Array' ); sub helper_type { 'ArrayRef' } no Moose::Role; 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::Collection::Array =head1 SYNOPSIS package Stuff; use Moose; use MooseX::AttributeHelpers; has 'options' => ( metaclass => 'Collection::Array', is => 'ro', isa => 'ArrayRef[Int]', default => sub { [] }, provides => { 'push' => 'add_options', 'pop' => 'remove_last_option', } ); =head1 DESCRIPTION This module provides an Array attribute which provides a number of array operations. See L for more details. =head1 METHODS =over 4 =item B =item B =item B =item B =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Trait/Collection/Hash.pm0000644000175000017500000000337711317442720027654 0ustar autarchautarch package MooseX::AttributeHelpers::Trait::Collection::Hash; use Moose::Role; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; use MooseX::AttributeHelpers::MethodProvider::Hash; with 'MooseX::AttributeHelpers::Trait::Collection'; has 'method_provider' => ( is => 'ro', isa => 'ClassName', predicate => 'has_method_provider', default => 'MooseX::AttributeHelpers::MethodProvider::Hash' ); sub helper_type { 'HashRef' } no Moose::Role; 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::Collection::Hash =head1 SYNOPSIS package Stuff; use Moose; use MooseX::AttributeHelpers; has 'options' => ( metaclass => 'Collection::Hash', is => 'ro', isa => 'HashRef[Str]', default => sub { {} }, provides => { 'set' => 'set_option', 'get' => 'get_option', 'empty' => 'has_options', 'count' => 'num_options', 'delete' => 'delete_option', } ); =head1 DESCRIPTION This module provides a Hash attribute which provides a number of hash-like operations. See L for more details. =head1 METHODS =over 4 =item B =item B =item B =item B =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Trait/Collection/ImmutableHash.pm0000644000175000017500000000341511317442720031505 0ustar autarchautarch package MooseX::AttributeHelpers::Trait::Collection::ImmutableHash; use Moose::Role; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; use MooseX::AttributeHelpers::MethodProvider::ImmutableHash; with 'MooseX::AttributeHelpers::Trait::Collection'; has 'method_provider' => ( is => 'ro', isa => 'ClassName', predicate => 'has_method_provider', default => 'MooseX::AttributeHelpers::MethodProvider::ImmutableHash' ); sub helper_type { 'HashRef' } no Moose::Role; 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::Collection::ImmutableHash =head1 SYNOPSIS package Stuff; use Moose; use MooseX::AttributeHelpers; has 'options' => ( metaclass => 'Collection::ImmutableHash', is => 'ro', isa => 'HashRef[Str]', default => sub { {} }, provides => { 'get' => 'get_option', 'empty' => 'has_options', 'keys' => 'get_option_list', } ); =head1 DESCRIPTION This module provides a immutable HashRef attribute which provides a number of hash-line operations. See L for more details. =head1 METHODS =over 4 =item B =item B =item B =item B =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Trait/Collection/Bag.pm0000644000175000017500000000434711317442720027460 0ustar autarchautarch package MooseX::AttributeHelpers::Trait::Collection::Bag; use Moose::Role; use Moose::Util::TypeConstraints; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; use MooseX::AttributeHelpers::MethodProvider::Bag; with 'MooseX::AttributeHelpers::Trait::Collection'; has 'method_provider' => ( is => 'ro', isa => 'ClassName', predicate => 'has_method_provider', default => 'MooseX::AttributeHelpers::MethodProvider::Bag' ); subtype 'Bag' => as 'HashRef[Int]'; sub helper_type { 'Bag' } before 'process_options_for_provides' => sub { my ($self, $options, $name) = @_; # Set some default attribute options here unless already defined if ((my $type = $self->helper_type) && !exists $options->{isa}){ $options->{isa} = $type; } $options->{default} = sub { +{} } unless exists $options->{default}; }; no Moose::Role; no Moose::Util::TypeConstraints; 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::Collection::Bag =head1 SYNOPSIS package Stuff; use Moose; use MooseX::AttributeHelpers; has 'word_histogram' => ( metaclass => 'Collection::Bag', is => 'ro', isa => 'Bag', # optional ... as is defalt provides => { 'add' => 'add_word', 'get' => 'get_count_for', 'empty' => 'has_any_words', 'count' => 'num_words', 'delete' => 'delete_word', } ); =head1 DESCRIPTION This module provides a Bag attribute which provides a number of bag-like operations. See L for more details. =head1 METHODS =over 4 =item B =item B =item B =item B =item B =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Trait/String.pm0000644000175000017500000000775711317442720026152 0ustar autarchautarch package MooseX::AttributeHelpers::Trait::String; use Moose::Role; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; use MooseX::AttributeHelpers::MethodProvider::String; with 'MooseX::AttributeHelpers::Trait::Base'; has 'method_provider' => ( is => 'ro', isa => 'ClassName', predicate => 'has_method_provider', default => 'MooseX::AttributeHelpers::MethodProvider::String', ); sub helper_type { 'Str' } before 'process_options_for_provides' => sub { my ($self, $options, $name) = @_; # Set some default attribute options here unless already defined if ((my $type = $self->helper_type) && !exists $options->{isa}){ $options->{isa} = $type; } $options->{is} = 'rw' unless exists $options->{is}; $options->{default} = '' unless exists $options->{default}; }; after 'check_provides_values' => sub { my $self = shift; my $provides = $self->provides; unless (scalar keys %$provides) { my $method_constructors = $self->method_constructors; my $attr_name = $self->name; foreach my $method (keys %$method_constructors) { $provides->{$method} = ($method . '_' . $attr_name); } } }; no Moose::Role; 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::String =head1 SYNOPSIS package MyHomePage; use Moose; use MooseX::AttributeHelpers; has 'text' => ( metaclass => 'String', is => 'rw', isa => 'Str', default => sub { '' }, provides => { append => "add_text", replace => "replace_text", } ); 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. If your attribute definition does not include any of I, I, I or I but does use the C metaclass, then this module applies defaults as in the L above. This allows for a very basic counter definition: has 'foo' => (metaclass => 'String'); $obj->append_foo; =head1 METHODS =over 4 =item B =item B =item B =item B =item B Run before its superclass method. =item B Run after its superclass method. =back =head1 PROVIDED METHODS It is important to note that all those methods do in place modification of the value stored in the attribute. =over 4 =item I Increments the value stored in this slot using the magical string autoincrement operator. Note that Perl doesn't provide analogeous behavior in C<-->, so C is not available. =item I C<$string> Append a string, like C<.=>. =item I C<$string> Prepend a string. =item I C<$pattern> C<$replacement> Performs a regexp substitution (L). There is no way to provide the C flag, but code references will be accepted for the replacement, causing the regex to be modified with a single C. C can be applied using the C operator. =item I C<$pattern> Like I but without the replacement. Provided mostly for completeness. =item C L =item C L =item C Sets the string to the empty string (not the value passed to C). =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Trait/Base.pm0000644000175000017500000001534411317442720025545 0ustar autarchautarch package MooseX::AttributeHelpers::Trait::Base; use Moose::Role; use Moose::Util::TypeConstraints; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; requires 'helper_type'; # this is the method map you define ... has 'provides' => ( is => 'ro', isa => 'HashRef', default => sub {{}} ); has 'curries' => ( is => 'ro', isa => 'HashRef', default => sub {{}} ); # these next two are the possible methods # you can use in the 'provides' map. # provide a Class or Role which we can # collect the method providers from # requires_attr 'method_provider' # or you can provide a HASH ref of anon subs # yourself. This will also collect and store # the methods from a method_provider as well has 'method_constructors' => ( is => 'ro', isa => 'HashRef', lazy => 1, default => sub { my $self = shift; return +{} unless $self->has_method_provider; # or grab them from the role/class my $method_provider = $self->method_provider->meta; return +{ map { $_ => $method_provider->get_method($_) } grep { $_ ne 'meta' } $method_provider->get_method_list }; }, ); ## Methods called prior to instantiation sub process_options_for_provides { my ($self, $options) = @_; if (my $type = $self->helper_type) { (exists $options->{isa}) || confess "You must define a type with the $type metaclass"; my $isa = $options->{isa}; unless (blessed($isa) && $isa->isa('Moose::Meta::TypeConstraint')) { $isa = Moose::Util::TypeConstraints::find_or_create_type_constraint($isa); } ($isa->is_a_type_of($type)) || confess "The type constraint for a $type ($options->{isa}) must be a subtype of $type"; } } before '_process_options' => sub { my ($self, $name, $options) = @_; $self->process_options_for_provides($options, $name); }; ## methods called after instantiation sub check_provides_values { my $self = shift; my $method_constructors = $self->method_constructors; foreach my $key (keys %{$self->provides}) { (exists $method_constructors->{$key}) || confess "$key is an unsupported method type"; } foreach my $key (keys %{$self->curries}) { (exists $method_constructors->{$key}) || confess "$key is an unsupported method type"; } } sub _curry { my $self = shift; my $code = shift; my @args = @_; return sub { my $self = shift; $code->($self, @args, @_) }; } sub _curry_sub { my $self = shift; my $body = shift; my $code = shift; return sub { my $self = shift; $code->($self, $body, @_) }; } after 'install_accessors' => sub { my $attr = shift; my $class = $attr->associated_class; # grab the reader and writer methods # as well, this will be useful for # our method provider constructors my $attr_reader = $attr->get_read_method_ref; my $attr_writer = $attr->get_write_method_ref; # before we install them, lets # make sure they are valid $attr->check_provides_values; my $method_constructors = $attr->method_constructors; my $class_name = $class->name; while (my ($constructor, $constructed) = each %{$attr->curries}) { my $method_code; while (my ($curried_name, $curried_arg) = each(%$constructed)) { if ($class->has_method($curried_name)) { confess "The method ($curried_name) already ". "exists in class (" . $class->name . ")"; } my $body = $method_constructors->{$constructor}->( $attr, $attr_reader, $attr_writer, ); if (ref $curried_arg eq 'ARRAY') { $method_code = $attr->_curry($body, @$curried_arg); } elsif (ref $curried_arg eq 'CODE') { $method_code = $attr->_curry_sub($body, $curried_arg); } else { confess "curries parameter must be ref type ARRAY or CODE"; } my $method = MooseX::AttributeHelpers::Meta::Method::Curried->wrap( $method_code, package_name => $class_name, name => $curried_name, ); $attr->associate_method($method); $class->add_method($curried_name => $method); } } foreach my $key (keys %{$attr->provides}) { my $method_name = $attr->provides->{$key}; if ($class->has_method($method_name)) { confess "The method ($method_name) already exists in class (" . $class->name . ")"; } my $method = MooseX::AttributeHelpers::Meta::Method::Provided->wrap( $method_constructors->{$key}->( $attr, $attr_reader, $attr_writer, ), package_name => $class_name, name => $method_name, ); $attr->associate_method($method); $class->add_method($method_name => $method); } }; after 'remove_accessors' => sub { my $attr = shift; my $class = $attr->associated_class; # provides accessors foreach my $key (keys %{$attr->provides}) { my $method_name = $attr->provides->{$key}; my $method = $class->get_method($method_name); $class->remove_method($method_name) if blessed($method) && $method->isa('MooseX::AttributeHelpers::Meta::Method::Provided'); } # curries accessors foreach my $key (keys %{$attr->curries}) { my $method_name = $attr->curries->{$key}; my $method = $class->get_method($method_name); $class->remove_method($method_name) if blessed($method) && $method->isa('MooseX::AttributeHelpers::Meta::Method::Provided'); } }; no Moose::Role; no Moose::Util::TypeConstraints; 1; __END__ =head1 NAME MooseX::AttributeHelpers::Trait::Base - base role for helpers =head1 METHODS =head2 check_provides_values Confirms that provides (and curries) has all valid possibilities in it. =head2 process_options_for_provides Ensures that the type constraint (C) matches the helper type. =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 AUTHORS Yuval Kogman Shawn M Moore Jesse Luehrs =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Trait/Bool.pm0000644000175000017500000000510411317442720025557 0ustar autarchautarchpackage MooseX::AttributeHelpers::Trait::Bool; use Moose::Role; use MooseX::AttributeHelpers::MethodProvider::Bool; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; with 'MooseX::AttributeHelpers::Trait::Base'; sub helper_type { 'Bool' } # NOTE: # we don't use the method provider for this # module since many of the names of the provied # methods would conflict with keywords # - SL has 'method_provider' => ( is => 'ro', isa => 'ClassName', predicate => 'has_method_provider', default => 'MooseX::AttributeHelpers::MethodProvider::Bool' ); before 'process_options_for_provides' => sub { my ($self, $options, $name) = @_; # Set some default attribute options here unless already defined if ((my $type = $self->helper_type) && !exists $options->{isa}){ $options->{isa} = $type; } }; no Moose::Role; 1; =pod =head1 NAME MooseX::AttributeHelpers::Bool =head1 SYNOPSIS package Room; use Moose; use MooseX::AttributeHelpers; has 'is_lit' => ( metaclass => 'Bool', is => 'rw', isa => 'Bool', default => sub { 0 }, provides => { set => 'illuminate', unset => 'darken', toggle => 'flip_switch', not => 'is_dark' } ); 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 METHODS =over 4 =item B =item B =item B =item B =item B =back =head1 PROVIDED METHODS It is important to note that all those methods do in place modification of the value stored in the attribute. =over 4 =item I Sets the value to C<1>. =item I Set the value to C<0>. =item I Toggle the value. If it's true, set to false, and vice versa. =item I Equivalent of 'not C<$value>'. =back =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 AUTHOR Jason May =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Trait/Collection.pm0000644000175000017500000000176111317442720026764 0ustar autarchautarch package MooseX::AttributeHelpers::Trait::Collection; use Moose::Role; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; with 'MooseX::AttributeHelpers::Trait::Base'; no Moose::Role; 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::Collection - Base class for all collection type helpers =head1 DESCRIPTION Documentation to come. =head1 METHODS =over 4 =item B =item B =item B =item B =item B =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Collection/0000755000175000017500000000000011317443272025341 5ustar autarchautarchMooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Collection/List.pm0000644000175000017500000000312411317442720026607 0ustar autarchautarch package MooseX::AttributeHelpers::Collection::List; use Moose; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; extends 'Moose::Meta::Attribute'; with 'MooseX::AttributeHelpers::Trait::Collection::List'; no Moose; # register the alias ... package # hide me from search.cpan.org Moose::Meta::Attribute::Custom::Collection::List; sub register_implementation { 'MooseX::AttributeHelpers::Collection::List' } 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::Collection::List =head1 SYNOPSIS package Stuff; use Moose; use MooseX::AttributeHelpers; has 'options' => ( metaclass => 'Collection::List', is => 'ro', isa => 'ArrayRef[Int]', default => sub { [] }, provides => { map => 'map_options', grep => 'filter_options', } ); =head1 DESCRIPTION This module provides an List attribute which provides a number of list operations. See L for more details. =head1 METHODS =over 4 =item B =item B =item B =item B =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Collection/Array.pm0000644000175000017500000000314511317442720026755 0ustar autarchautarch package MooseX::AttributeHelpers::Collection::Array; use Moose; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; extends 'Moose::Meta::Attribute'; with 'MooseX::AttributeHelpers::Trait::Collection::Array'; no Moose; # register the alias ... package # hide me from search.cpan.org Moose::Meta::Attribute::Custom::Collection::Array; sub register_implementation { 'MooseX::AttributeHelpers::Collection::Array' } 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::Collection::Array =head1 SYNOPSIS package Stuff; use Moose; use MooseX::AttributeHelpers; has 'options' => ( metaclass => 'Collection::Array', is => 'ro', isa => 'ArrayRef[Int]', default => sub { [] }, provides => { 'push' => 'add_options', 'pop' => 'remove_last_option', } ); =head1 DESCRIPTION This module provides an Array attribute which provides a number of array operations. See L for more details. =head1 METHODS =over 4 =item B =item B =item B =item B =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Collection/Hash.pm0000644000175000017500000000330711317442720026562 0ustar autarchautarch package MooseX::AttributeHelpers::Collection::Hash; use Moose; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; extends 'Moose::Meta::Attribute'; with 'MooseX::AttributeHelpers::Trait::Collection::Hash'; no Moose; # register the alias ... package # hide me from search.cpan.org Moose::Meta::Attribute::Custom::Collection::Hash; sub register_implementation { 'MooseX::AttributeHelpers::Collection::Hash' } 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::Collection::Hash =head1 SYNOPSIS package Stuff; use Moose; use MooseX::AttributeHelpers; has 'options' => ( metaclass => 'Collection::Hash', is => 'ro', isa => 'HashRef[Str]', default => sub { {} }, provides => { 'set' => 'set_option', 'get' => 'get_option', 'empty' => 'has_options', 'count' => 'num_options', 'delete' => 'delete_option', } ); =head1 DESCRIPTION This module provides a Hash attribute which provides a number of hash-like operations. See L for more details. =head1 METHODS =over 4 =item B =item B =item B =item B =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Collection/ImmutableHash.pm0000644000175000017500000000333611317442720030424 0ustar autarchautarch package MooseX::AttributeHelpers::Collection::ImmutableHash; use Moose; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; extends 'Moose::Meta::Attribute'; with 'MooseX::AttributeHelpers::Trait::Collection::ImmutableHash'; no Moose; # register the alias ... package # hide me from search.cpan.org Moose::Meta::Attribute::Custom::Collection::ImmutableHash; sub register_implementation { 'MooseX::AttributeHelpers::Collection::ImmutableHash' } 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::Collection::ImmutableHash =head1 SYNOPSIS package Stuff; use Moose; use MooseX::AttributeHelpers; has 'options' => ( metaclass => 'Collection::ImmutableHash', is => 'ro', isa => 'HashRef[Str]', default => sub { {} }, provides => { 'get' => 'get_option', 'empty' => 'has_options', 'keys' => 'get_option_list', } ); =head1 DESCRIPTION This module provides a immutable HashRef attribute which provides a number of hash-line operations. See L for more details. =head1 METHODS =over 4 =item B =item B =item B =item B =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Collection/Bag.pm0000644000175000017500000000336111317442720026370 0ustar autarchautarch package MooseX::AttributeHelpers::Collection::Bag; use Moose; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; extends 'Moose::Meta::Attribute'; with 'MooseX::AttributeHelpers::Trait::Collection::Bag'; no Moose; # register the alias ... package # hide me from search.cpan.org Moose::Meta::Attribute::Custom::Collection::Bag; sub register_implementation { 'MooseX::AttributeHelpers::Collection::Bag' } 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::Collection::Bag =head1 SYNOPSIS package Stuff; use Moose; use MooseX::AttributeHelpers; has 'word_histogram' => ( metaclass => 'Collection::Bag', is => 'ro', isa => 'Bag', # optional ... as is default provides => { 'add' => 'add_word', 'get' => 'get_count_for', 'empty' => 'has_any_words', 'count' => 'num_words', 'delete' => 'delete_word', } ); =head1 DESCRIPTION This module provides a Bag attribute which provides a number of bag-like operations. See L for more details. =head1 METHODS =over 4 =item B =item B =item B =item B =item B =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/MethodProvider/0000755000175000017500000000000011317443272026201 5ustar autarchautarchMooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/MethodProvider/List.pm0000644000175000017500000001414011317442720027447 0ustar autarchautarchpackage MooseX::AttributeHelpers::MethodProvider::List; use Moose::Role; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; sub count : method { my ($attr, $reader, $writer) = @_; return sub { scalar @{$reader->($_[0])} }; } sub empty : method { my ($attr, $reader, $writer) = @_; return sub { scalar @{$reader->($_[0])} ? 1 : 0 }; } sub find : method { my ($attr, $reader, $writer) = @_; return sub { my ($instance, $predicate) = @_; foreach my $val (@{$reader->($instance)}) { return $val if $predicate->($val); } return; }; } sub map : method { my ($attr, $reader, $writer) = @_; return sub { my ($instance, $f) = @_; CORE::map { $f->($_) } @{$reader->($instance)} }; } sub sort : method { my ($attr, $reader, $writer) = @_; return sub { my ($instance, $predicate) = @_; die "Argument must be a code reference" if $predicate && ref $predicate ne 'CODE'; if ($predicate) { CORE::sort { $predicate->($a, $b) } @{$reader->($instance)}; } else { CORE::sort @{$reader->($instance)}; } }; } sub grep : method { my ($attr, $reader, $writer) = @_; return sub { my ($instance, $predicate) = @_; CORE::grep { $predicate->($_) } @{$reader->($instance)} }; } sub elements : method { my ($attr, $reader, $writer) = @_; return sub { my ($instance) = @_; @{$reader->($instance)} }; } sub join : method { my ($attr, $reader, $writer) = @_; return sub { my ($instance, $separator) = @_; join $separator, @{$reader->($instance)} }; } sub get : method { my ($attr, $reader, $writer) = @_; return sub { $reader->($_[0])->[$_[1]] }; } sub first : method { my ($attr, $reader, $writer) = @_; return sub { $reader->($_[0])->[0] }; } sub last : method { my ($attr, $reader, $writer) = @_; return sub { $reader->($_[0])->[-1] }; } 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::MethodProvider::List =head1 SYNOPSIS package Stuff; use Moose; use MooseX::AttributeHelpers; has 'options' => ( metaclass => 'Collection::List', is => 'rw', isa => 'ArrayRef[Str]', default => sub { [] }, auto_deref => 1, provides => { elements => 'all_options', map => 'map_options', grep => 'filter_options', find => 'find_option', first => 'first_option', last => 'last_option', get => 'get_option', join => 'join_options', count => 'count_options', empty => 'do_i_have_options', sort => 'sorted_options', } ); no Moose; 1; =head1 DESCRIPTION This is a role which provides the method generators for L. =head1 METHODS =over 4 =item B =back =head1 PROVIDED METHODS =over 4 =item B Returns the number of elements in the list. $stuff = Stuff->new; $stuff->options(["foo", "bar", "baz", "boo"]); my $count = $stuff->count_options; print "$count\n"; # prints 4 =item B If the list is populated, returns true. Otherwise, returns false. $stuff->do_i_have_options ? print "Good boy.\n" : die "No options!\n" ; =item B This method accepts a subroutine reference as its argument. That sub will receive each element of the list in turn. If it returns true for an element, that element will be returned by the C method. my $found = $stuff->find_option( sub { $_[0] =~ /^b/ } ); print "$found\n"; # prints "bar" =item B This method accepts a subroutine reference as its argument. This method returns every element for which that subroutine reference returns a true value. my @found = $stuff->filter_options( sub { $_[0] =~ /^b/ } ); print "@found\n"; # prints "bar baz boo" =item B This method accepts a subroutine reference as its argument. The subroutine will be executed for each element of the list. It is expected to return a modified version of that element. The return value of the method is a list of the modified options. my @mod_options = $stuff->map_options( sub { $_[0] . "-tag" } ); print "@mod_options\n"; # prints "foo-tag bar-tag baz-tag boo-tag" =item B Sorts and returns the elements of the list. You can provide an optional subroutine reference to sort with (as you can with the 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 Returns all of the elements of the list my @option = $stuff->all_options; print "@options\n"; # prints "foo bar baz boo" =item B Joins every element of the list using the separator given as argument. my $joined = $stuff->join_options( ':' ); print "$joined\n"; # prints "foo:bar:baz:boo" =item B Returns an element of the list by its index. my $option = $stuff->get_option(1); print "$option\n"; # prints "bar" =item B Returns the first element of the list. my $first = $stuff->first_option; print "$first\n"; # prints "foo" =item B Returns the last element of the list. my $last = $stuff->last_option; print "$last\n"; # prints "boo" =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/MethodProvider/Array.pm0000644000175000017500000001713111317442720027615 0ustar autarchautarchpackage MooseX::AttributeHelpers::MethodProvider::Array; use Moose::Role; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; with 'MooseX::AttributeHelpers::MethodProvider::List'; sub push : method { my ($attr, $reader, $writer) = @_; if ($attr->has_type_constraint && $attr->type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) { my $container_type_constraint = $attr->type_constraint->type_parameter; return sub { my $instance = CORE::shift; $container_type_constraint->check($_) || confess "Value " . ($_||'undef') . " did not pass container type constraint '$container_type_constraint'" foreach @_; CORE::push @{$reader->($instance)} => @_; }; } else { return sub { my $instance = CORE::shift; CORE::push @{$reader->($instance)} => @_; }; } } sub pop : method { my ($attr, $reader, $writer) = @_; return sub { CORE::pop @{$reader->($_[0])} }; } sub unshift : method { my ($attr, $reader, $writer) = @_; if ($attr->has_type_constraint && $attr->type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) { my $container_type_constraint = $attr->type_constraint->type_parameter; return sub { my $instance = CORE::shift; $container_type_constraint->check($_) || confess "Value " . ($_||'undef') . " did not pass container type constraint '$container_type_constraint'" foreach @_; CORE::unshift @{$reader->($instance)} => @_; }; } else { return sub { my $instance = CORE::shift; CORE::unshift @{$reader->($instance)} => @_; }; } } sub shift : method { my ($attr, $reader, $writer) = @_; return sub { CORE::shift @{$reader->($_[0])} }; } sub get : method { my ($attr, $reader, $writer) = @_; return sub { $reader->($_[0])->[$_[1]] }; } sub set : method { my ($attr, $reader, $writer) = @_; if ($attr->has_type_constraint && $attr->type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) { my $container_type_constraint = $attr->type_constraint->type_parameter; return sub { ($container_type_constraint->check($_[2])) || confess "Value " . ($_[2]||'undef') . " did not pass container type constraint '$container_type_constraint'"; $reader->($_[0])->[$_[1]] = $_[2] }; } else { return sub { $reader->($_[0])->[$_[1]] = $_[2] }; } } sub accessor : method { my ($attr, $reader, $writer) = @_; if ($attr->has_type_constraint && $attr->type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) { my $container_type_constraint = $attr->type_constraint->type_parameter; return sub { my $self = shift; if (@_ == 1) { # reader return $reader->($self)->[$_[0]]; } elsif (@_ == 2) { # writer ($container_type_constraint->check($_[1])) || confess "Value " . ($_[1]||'undef') . " did not pass container type constraint '$container_type_constraint'"; $reader->($self)->[$_[0]] = $_[1]; } else { confess "One or two arguments expected, not " . @_; } }; } else { return sub { my $self = shift; if (@_ == 1) { # reader return $reader->($self)->[$_[0]]; } elsif (@_ == 2) { # writer $reader->($self)->[$_[0]] = $_[1]; } else { confess "One or two arguments expected, not " . @_; } }; } } sub clear : method { my ($attr, $reader, $writer) = @_; return sub { @{$reader->($_[0])} = () }; } sub delete : method { my ($attr, $reader, $writer) = @_; return sub { CORE::splice @{$reader->($_[0])}, $_[1], 1; } } sub insert : method { my ($attr, $reader, $writer) = @_; if ($attr->has_type_constraint && $attr->type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) { my $container_type_constraint = $attr->type_constraint->type_parameter; return sub { ($container_type_constraint->check($_[2])) || confess "Value " . ($_[2]||'undef') . " did not pass container type constraint '$container_type_constraint'"; CORE::splice @{$reader->($_[0])}, $_[1], 0, $_[2]; }; } else { return sub { CORE::splice @{$reader->($_[0])}, $_[1], 0, $_[2]; }; } } sub splice : method { my ($attr, $reader, $writer) = @_; if ($attr->has_type_constraint && $attr->type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) { my $container_type_constraint = $attr->type_constraint->type_parameter; return sub { my ( $self, $i, $j, @elems ) = @_; ($container_type_constraint->check($_)) || confess "Value " . (defined($_) ? $_ : 'undef') . " did not pass container type constraint '$container_type_constraint'" for @elems; CORE::splice @{$reader->($self)}, $i, $j, @elems; }; } else { return sub { my ( $self, $i, $j, @elems ) = @_; CORE::splice @{$reader->($self)}, $i, $j, @elems; }; } } sub sort_in_place : method { my ($attr, $reader, $writer) = @_; return sub { my ($instance, $predicate) = @_; die "Argument must be a code reference" if $predicate && ref $predicate ne 'CODE'; my @sorted; if ($predicate) { @sorted = CORE::sort { $predicate->($a, $b) } @{$reader->($instance)}; } else { @sorted = CORE::sort @{$reader->($instance)}; } $writer->($instance, \@sorted); }; } 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::MethodProvider::Array =head1 DESCRIPTION This is a role which provides the method generators for L. =head1 METHODS =over 4 =item B =back =head1 PROVIDED METHODS This module also consumes the B method providers, to see those provied methods, refer to that documentation. =over 4 =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =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 the 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 If passed one argument, returns the value of the requested element. If passed two arguments, sets the value of the requested element. =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/MethodProvider/Counter.pm0000644000175000017500000000270511317442720030157 0ustar autarchautarch package MooseX::AttributeHelpers::MethodProvider::Counter; use Moose::Role; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; sub reset : method { my ($attr, $reader, $writer) = @_; return sub { $writer->($_[0], $attr->default($_[0])) }; } sub set : method { my ($attr, $reader, $writer, $value) = @_; return sub { $writer->($_[0], $_[1]) }; } sub inc { my ($attr, $reader, $writer) = @_; return sub { $writer->($_[0], $reader->($_[0]) + (defined($_[1]) ? $_[1] : 1) ) }; } sub dec { my ($attr, $reader, $writer) = @_; return sub { $writer->($_[0], $reader->($_[0]) - (defined($_[1]) ? $_[1] : 1) ) }; } 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::MethodProvider::Counter =head1 DESCRIPTION This is a role which provides the method generators for L. =head1 METHODS =over 4 =item B =back =head1 PROVIDED METHODS =over 4 =item B =item B =item B =item B =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/MethodProvider/String.pm0000644000175000017500000000614511317442720030010 0ustar autarchautarch package MooseX::AttributeHelpers::MethodProvider::String; use Moose::Role; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; sub append : method { my ($attr, $reader, $writer) = @_; return sub { $writer->( $_[0], $reader->($_[0]) . $_[1] ) }; } sub prepend : method { my ($attr, $reader, $writer) = @_; return sub { $writer->( $_[0], $_[1] . $reader->($_[0]) ) }; } sub replace : method { my ($attr, $reader, $writer) = @_; return sub { my ( $self, $regex, $replacement ) = @_; my $v = $reader->($_[0]); if ( (ref($replacement)||'') eq 'CODE' ) { $v =~ s/$regex/$replacement->()/e; } else { $v =~ s/$regex/$replacement/; } $writer->( $_[0], $v); }; } sub match : method { my ($attr, $reader, $writer) = @_; return sub { $reader->($_[0]) =~ $_[1] }; } sub chop : method { my ($attr, $reader, $writer) = @_; return sub { my $v = $reader->($_[0]); CORE::chop($v); $writer->( $_[0], $v); }; } sub chomp : method { my ($attr, $reader, $writer) = @_; return sub { my $v = $reader->($_[0]); chomp($v); $writer->( $_[0], $v); }; } sub inc : method { my ($attr, $reader, $writer) = @_; return sub { my $v = $reader->($_[0]); $v++; $writer->( $_[0], $v); }; } sub clear : method { my ($attr, $reader, $writer) = @_; return sub { $writer->( $_[0], '' ) } } sub length : method { my ($attr, $reader, $writer) = @_; return sub { my $v = $reader->($_[0]); return CORE::length($v); }; } sub substr : method { my ($attr, $reader, $writer) = @_; return sub { my $self = shift; my $v = $reader->($self); my $offset = defined $_[0] ? shift : 0; my $length = defined $_[0] ? shift : CORE::length($v); my $replacement = defined $_[0] ? shift : undef; my $ret; if (defined $replacement) { $ret = CORE::substr($v, $offset, $length, $replacement); $writer->($self, $v); } else { $ret = CORE::substr($v, $offset, $length); } return $ret; }; } 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::MethodProvider::String =head1 DESCRIPTION This is a role which provides the method generators for L. =head1 METHODS =over 4 =item B =back =head1 PROVIDED METHODS =over 4 =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/MethodProvider/Bool.pm0000644000175000017500000000253611317442720027435 0ustar autarchautarch package MooseX::AttributeHelpers::MethodProvider::Bool; use Moose::Role; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; sub set : method { my ($attr, $reader, $writer) = @_; return sub { $writer->($_[0], 1) }; } sub unset : method { my ($attr, $reader, $writer) = @_; return sub { $writer->($_[0], 0) }; } sub toggle : method { my ($attr, $reader, $writer) = @_; return sub { $writer->($_[0], !$reader->($_[0])) }; } sub not : method { my ($attr, $reader, $writer) = @_; return sub { !$reader->($_[0]) }; } 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::MethodProvider::Bool =head1 DESCRIPTION This is a role which provides the method generators for L. =head1 METHODS =over 4 =item B =back =head1 PROVIDED METHODS =over 4 =item B =item B =item B =item B =back =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 AUTHOR Jason May Ejason.a.may@gmail.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/MethodProvider/Hash.pm0000644000175000017500000001125211317442720027420 0ustar autarchautarchpackage MooseX::AttributeHelpers::MethodProvider::Hash; use Moose::Role; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; with 'MooseX::AttributeHelpers::MethodProvider::ImmutableHash'; sub set : method { my ($attr, $reader, $writer) = @_; if ($attr->has_type_constraint && $attr->type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) { my $container_type_constraint = $attr->type_constraint->type_parameter; return sub { my ( $self, @kvp ) = @_; my ( @keys, @values ); while ( @kvp ) { my ( $key, $value ) = ( shift(@kvp), shift(@kvp) ); ($container_type_constraint->check($value)) || confess "Value " . ($value||'undef') . " did not pass container type constraint '$container_type_constraint'"; push @keys, $key; push @values, $value; } if ( @values > 1 ) { @{ $reader->($self) }{@keys} = @values; } else { $reader->($self)->{$keys[0]} = $values[0]; } }; } else { return sub { if ( @_ == 3 ) { $reader->($_[0])->{$_[1]} = $_[2] } else { my ( $self, @kvp ) = @_; my ( @keys, @values ); while ( @kvp ) { push @keys, shift @kvp; push @values, shift @kvp; } @{ $reader->($_[0]) }{@keys} = @values; } }; } } sub accessor : method { my ($attr, $reader, $writer) = @_; if ($attr->has_type_constraint && $attr->type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) { my $container_type_constraint = $attr->type_constraint->type_parameter; return sub { my $self = shift; if (@_ == 1) { # reader return $reader->($self)->{$_[0]}; } elsif (@_ == 2) { # writer ($container_type_constraint->check($_[1])) || confess "Value " . ($_[1]||'undef') . " did not pass container type constraint '$container_type_constraint'"; $reader->($self)->{$_[0]} = $_[1]; } else { confess "One or two arguments expected, not " . @_; } }; } else { return sub { my $self = shift; if (@_ == 1) { # reader return $reader->($self)->{$_[0]}; } elsif (@_ == 2) { # writer $reader->($self)->{$_[0]} = $_[1]; } else { confess "One or two arguments expected, not " . @_; } }; } } sub clear : method { my ($attr, $reader, $writer) = @_; return sub { %{$reader->($_[0])} = () }; } sub delete : method { my ($attr, $reader, $writer) = @_; return sub { my $hashref = $reader->(shift); CORE::delete @{$hashref}{@_}; }; } 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::MethodProvider::Hash =head1 DESCRIPTION This is a role which provides the method generators for L. This role is composed from the L role. =head1 METHODS =over 4 =item B =back =head1 PROVIDED METHODS =over 4 =item B Returns the number of elements in the hash. =item B Removes the element with the given key =item B Returns true if the value of a given key is defined =item B If the list is populated, returns true. Otherwise, returns false. =item B Unsets the hash entirely. =item B Returns true if the given key is present in the hash =item B Returns an element of the hash by its key. =item B Returns the list of keys in the hash. =item B Sets the element in the hash at the given key to the given value. =item B Returns the list of values in the hash. =item B Returns the key, value pairs in the hash =item B If passed one argument, returns the value of the requested key. If passed two arguments, sets the value of the requested key. =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/MethodProvider/ImmutableHash.pm0000644000175000017500000000554711317442720031272 0ustar autarchautarchpackage MooseX::AttributeHelpers::MethodProvider::ImmutableHash; use Moose::Role; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; sub exists : method { my ($attr, $reader, $writer) = @_; return sub { CORE::exists $reader->($_[0])->{$_[1]} ? 1 : 0 }; } sub defined : method { my ($attr, $reader, $writer) = @_; return sub { CORE::defined $reader->($_[0])->{$_[1]} ? 1 : 0 }; } sub get : method { my ($attr, $reader, $writer) = @_; return sub { if ( @_ == 2 ) { $reader->($_[0])->{$_[1]} } else { my ( $self, @keys ) = @_; @{ $reader->($self) }{@keys} } }; } sub keys : method { my ($attr, $reader, $writer) = @_; return sub { CORE::keys %{$reader->($_[0])} }; } sub values : method { my ($attr, $reader, $writer) = @_; return sub { CORE::values %{$reader->($_[0])} }; } sub kv : method { my ($attr, $reader, $writer) = @_; return sub { my $h = $reader->($_[0]); map { [ $_, $h->{$_} ] } CORE::keys %{$h} }; } sub elements : method { my ($attr, $reader, $writer) = @_; return sub { my $h = $reader->($_[0]); map { $_, $h->{$_} } CORE::keys %{$h} }; } sub count : method { my ($attr, $reader, $writer) = @_; return sub { scalar CORE::keys %{$reader->($_[0])} }; } sub empty : method { my ($attr, $reader, $writer) = @_; return sub { scalar CORE::keys %{$reader->($_[0])} ? 1 : 0 }; } 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::MethodProvider::ImmutableHash =head1 DESCRIPTION This is a role which provides the method generators for L. =head1 METHODS =over 4 =item B =back =head1 PROVIDED METHODS =over 4 =item B Returns the number of elements in the list. =item B If the list is populated, returns true. Otherwise, returns false. =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 an element of the hash by its key. =item B Returns the list of 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 array references =item B Returns the key, value pairs in the hash as a flattened list =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/MethodProvider/Bag.pm0000644000175000017500000000303011317442720027221 0ustar autarchautarchpackage MooseX::AttributeHelpers::MethodProvider::Bag; use Moose::Role; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; with 'MooseX::AttributeHelpers::MethodProvider::ImmutableHash'; sub add : method { my ($attr, $reader, $writer) = @_; return sub { $reader->($_[0])->{$_[1]}++ }; } sub delete : method { my ($attr, $reader, $writer) = @_; return sub { CORE::delete $reader->($_[0])->{$_[1]} }; } sub reset : method { my ($attr, $reader, $writer) = @_; return sub { $reader->($_[0])->{$_[1]} = 0 }; } 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::MethodProvider::Bag =head1 DESCRIPTION This is a role which provides the method generators for L. This role is composed from the L role. =head1 METHODS =over 4 =item B =back =head1 PROVIDED METHODS =over 4 =item B =item B =item B =item B =item B =item B =item B =item B =item B =item B =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/String.pm0000644000175000017500000000617511317442720025060 0ustar autarchautarch package MooseX::AttributeHelpers::String; use Moose; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; extends 'Moose::Meta::Attribute'; with 'MooseX::AttributeHelpers::Trait::String'; no Moose; # register the alias ... package # hide me from search.cpan.org Moose::Meta::Attribute::Custom::String; sub register_implementation { 'MooseX::AttributeHelpers::String' } 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::String =head1 SYNOPSIS package MyHomePage; use Moose; use MooseX::AttributeHelpers; has 'text' => ( metaclass => 'String', is => 'rw', isa => 'Str', default => sub { '' }, provides => { append => "add_text", replace => "replace_text", } ); 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. If your attribute definition does not include any of I, I, I or I but does use the C metaclass, then this module applies defaults as in the L above. This allows for a very basic counter definition: has 'foo' => (metaclass => 'String'); $obj->append_foo; =head1 METHODS =over 4 =item B =item B =item B =item B =item B Run before its superclass method. =item B Run after its superclass method. =back =head1 PROVIDED METHODS It is important to note that all those methods do in place modification of the value stored in the attribute. =over 4 =item I Increments the value stored in this slot using the magical string autoincrement operator. Note that Perl doesn't provide analogeous behavior in C<-->, so C is not available. =item I C<$string> Append a string, like C<.=>. =item I C<$string> Prepend a string. =item I C<$pattern> C<$replacement> Performs a regexp substitution (L). There is no way to provide the C flag, but code references will be accepted for the replacement, causing the regex to be modified with a single C. C can be applied using the C operator. =item I C<$pattern> Like I but without the replacement. Provided mostly for completeness. =item C L =item C L =item C Sets the string to the empty string (not the value passed to C). =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut MooseX-AttributeHelpers-0.23/lib/MooseX/AttributeHelpers/Bool.pm0000644000175000017500000000223711317442720024500 0ustar autarchautarchpackage MooseX::AttributeHelpers::Bool; use Moose; our $VERSION = '0.23'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; extends 'Moose::Meta::Attribute'; with 'MooseX::AttributeHelpers::Trait::Bool'; no Moose; # register the alias ... package # hide me from search.cpan.org Moose::Meta::Attribute::Custom::Bool; sub register_implementation { 'MooseX::AttributeHelpers::Bool' } 1; __END__ =pod =head1 NAME MooseX::AttributeHelpers::Bool =head1 METHODS =over 4 =item B =item B =item B =item B =item B Run before its superclass method. =item B Run after its superclass method. =back =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 AUTHOR Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut