From: Yuval Kogman <nothingmuch@woobling.org>
Date: Mon, 31 Dec 2007 10:45:13 +0000 (+0000)
Subject: (no commit message)
X-Git-Tag: 0.18_01~49
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=190b1c022d2f2f14c2f019c1e5f8868d381fe1bb;p=gitmo%2FMooseX-AttributeHelpers.git

---

diff --git a/lib/MooseX/AttributeHelpers.pm b/lib/MooseX/AttributeHelpers.pm
index 5f48976..973d5e9 100644
--- a/lib/MooseX/AttributeHelpers.pm
+++ b/lib/MooseX/AttributeHelpers.pm
@@ -8,6 +8,7 @@ use MooseX::AttributeHelpers::Meta::Method::Provided;
 
 use MooseX::AttributeHelpers::Counter;
 use MooseX::AttributeHelpers::Number;
+use MooseX::AttributeHelpers::String;
 use MooseX::AttributeHelpers::Collection::List;
 use MooseX::AttributeHelpers::Collection::Array;
 use MooseX::AttributeHelpers::Collection::Hash;
diff --git a/lib/MooseX/AttributeHelpers/MethodProvider/String.pm b/lib/MooseX/AttributeHelpers/MethodProvider/String.pm
new file mode 100644
index 0000000..0657bf1
--- /dev/null
+++ b/lib/MooseX/AttributeHelpers/MethodProvider/String.pm
@@ -0,0 +1,138 @@
+
+package MooseX::AttributeHelpers::MethodProvider::String;
+use Moose::Role;
+
+our $VERSION   = '0.01';
+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], '' ) }
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::AttributeHelpers::MethodProvider::String
+  
+=head1 DESCRIPTION
+
+This is a role which provides the method generators for 
+L<MooseX::AttributeHelpers::String>.
+
+=head1 METHODS
+
+=over 4
+
+=item B<meta>
+
+=back
+
+=head1 PROVIDED METHODS
+
+=over 4
+
+=item B<append>
+
+=item B<prepend>
+
+=item B<replace>
+
+=item B<match>
+
+=item B<chomp>
+
+=item B<chop>
+
+=item B<inc>
+
+=item B<clear>
+
+=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 E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
diff --git a/lib/MooseX/AttributeHelpers/String.pm b/lib/MooseX/AttributeHelpers/String.pm
new file mode 100644
index 0000000..2091b33
--- /dev/null
+++ b/lib/MooseX/AttributeHelpers/String.pm
@@ -0,0 +1,183 @@
+
+package MooseX::AttributeHelpers::String;
+use Moose;
+
+our $VERSION   = '0.01';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use MooseX::AttributeHelpers::MethodProvider::String;
+
+extends 'MooseX::AttributeHelpers::Base';
+
+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;
+
+# 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<is>, I<isa>,
+I<default> or I<provides> but does use the C<String> metaclass,
+then this module applies defaults as in the L</SYNOPSIS>
+above. This allows for a very basic counter definition:
+
+  has 'foo' => (metaclass => 'String');
+  $obj->append_foo;
+
+=head1 METHODS
+
+=over 4
+
+=item B<meta>
+
+=item B<method_provider>
+
+=item B<has_method_provider>
+
+=item B<helper_type>
+
+=item B<process_options_for_provides>
+
+Run before its superclass method.
+
+=item B<check_provides_values>
+
+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<inc>
+
+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<dec> is not available.
+
+=item I<append> C<$string>
+
+Append a string, like C<.=>.
+
+=item I<prepend> C<$string>
+
+Prepend a string.
+
+=item I<replace> C<$pattern> C<$replacement>
+
+Performs a regexp substitution (L<perlop/s>). There is no way to provide the
+C<g> flag, but code references will be accepted for the replacement, causing
+the regex to be modified with a single C<e>. C</smxi> can be applied using the
+C<qr> operator.
+
+=item I<match> C<$pattern>
+
+Like I<replace> but without the replacement. Provided mostly for completeness.
+
+=item C<chop>
+
+L<perlfunc/chop>
+
+=item C<chomp>
+
+L<perlfunc/chomp>
+
+=item C<clear>
+
+Sets the string to the empty string (not the value passed to C<default>).
+
+=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 E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
diff --git a/t/007_basic_string.t b/t/007_basic_string.t
new file mode 100644
index 0000000..eb54f1a
--- /dev/null
+++ b/t/007_basic_string.t
@@ -0,0 +1,89 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 17;
+
+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',
+        }
+    );
+}
+
+my $page = MyHomePage->new();
+isa_ok($page, 'MyHomePage');
+
+is($page->string, '', '... got the default value');
+
+$page->string('a');
+
+$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");
+
+$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',
+}, '... got the right provides methods');
+