This is an automated email from the git hooks/post-receive script. gregoa pushed a commit to annotated tag release-0.001 in repository libclass-tiny-perl.
commit 6661ea7836e91bbeff06fd1ab62feadaf0d2f775 Author: David Golden <dagol...@cpan.org> Date: Thu Aug 15 21:45:21 2013 -0400 Initial crude implementation This is not yet subclass friendly, but it allows defining RW accessors, takes a hashref or list in the constructor, and dies on any unknown constructor attributes. --- lib/Class/Tiny.pm | 64 +++++++++++++++++++++++++++++++++++++--- t/alfa.t | 87 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ t/lib/Alfa.pm | 8 +++++ 3 files changed, 155 insertions(+), 4 deletions(-) diff --git a/lib/Class/Tiny.pm b/lib/Class/Tiny.pm index ca29a7c..db80726 100644 --- a/lib/Class/Tiny.pm +++ b/lib/Class/Tiny.pm @@ -3,11 +3,55 @@ use strict; use warnings; package Class::Tiny; -# ABSTRACT: No abstract given for Class::Tiny +# ABSTRACT: Minimalist class construction # VERSION -# Dependencies -use autodie 2.00; +use Carp (); + +my %CLASS_ATTRIBUTES; + +sub import { + no strict 'refs'; + my $class = shift; + my $pkg = caller; + my @attr = @_; + $CLASS_ATTRIBUTES{$pkg} = { map { $_ => 1 } @attr }; + my $child = !!@{"${pkg}::ISA"}; + eval join "\n", + "package $pkg;", ( $child ? () : "\@${pkg}::ISA = 'Class::Tiny';" ), map { + defined and !ref and /^[^\W\d]\w*$/s + or Carp::croak "Invalid accessor name '$_'"; + "sub $_ { if (\@_ > 1) { \$_[0]->{$_} = \$_[1] } ; return \$_[0]->{$_} }\n" + } @attr; + die "Failed to generate $pkg" if $@; + return 1; +} + +sub new { + my $class = shift; + my $args; + if ( @_ == 1 && ref $_[0] ) { # hope it's a hash or hash object + my %copy = eval { %{ $_[0] } }; # shallow copy + if ( $@ ) { + Carp::croak("Argument to $class->new() could not be dereferenced as a hash"); + } + $args = \%copy; + } + elsif ( @_ % 2 == 0 ) { + $args = {@_}; + } + else { + Carp::croak("$class->new() got an odd number of elements"); + } + my @bad; + for my $k ( keys %$args ) { + push @bad, $k unless $CLASS_ATTRIBUTES{$class}{$k}; + } + if (@bad) { + Carp::croak("Invalid attributes for $class: @bad"); + } + return bless $args, $class; +} 1; @@ -15,13 +59,25 @@ use autodie 2.00; =head1 SYNOPSIS - use Class::Tiny; + package MyClass; + + use Class::Tiny qw( name color ); + + 1; + + package main; + + MyClass->new( name => "Larry", color => "orange" ); + =head1 DESCRIPTION This module might be cool, but you'd never know it from the lack of documentation. +This is inspired by L<Object::Tiny::RW> with just a couple more features +to make it useful for class hierarchies. + =head1 USAGE Good luck! diff --git a/t/alfa.t b/t/alfa.t new file mode 100644 index 0000000..d0bb60b --- /dev/null +++ b/t/alfa.t @@ -0,0 +1,87 @@ +use 5.008001; +use strict; +use warnings; +use Test::More 0.96; +use Test::FailWarnings; +use Test::Deep '!blessed'; +use Test::Fatal; + +use lib 't/lib'; + +require_ok("Alfa"); + +subtest "empty list constructor" => sub { + my $obj = new_ok("Alfa"); + is( $obj->foo, undef, "foo is undef" ); + is( $obj->bar, undef, "bar is undef" ); +}; + +subtest "empty hash object constructor" => sub { + my $obj = new_ok("Alfa", [{}]); + is( $obj->foo, undef, "foo is undef" ); + is( $obj->bar, undef, "bar is undef" ); +}; + +subtest "one attribute set as list" => sub { + my $obj = new_ok( "Alfa", [ foo => 23 ] ); + is( $obj->foo, 23, "foo is set" ); + is( $obj->bar, undef, "bar is undef" ); +}; + +subtest "one attribute set as hash ref" => sub { + my $obj = new_ok( "Alfa", [ { foo => 23 } ] ); + is( $obj->foo, 23, "foo is set" ); + is( $obj->bar, undef, "bar is undef" ); +}; + +subtest "both attributes set as list" => sub { + my $obj = new_ok( "Alfa", [ foo => 23, bar => 42 ] ); + is( $obj->foo, 23, "foo is set" ); + is( $obj->bar, 42, "bar is set" ); +}; + +subtest "both attributes set as hash ref" => sub { + my $obj = new_ok( "Alfa", [ { foo => 23, bar => 42 } ] ); + is( $obj->foo, 23, "foo is set" ); + is( $obj->bar, 42, "bar is set" ); +}; + +subtest "constructor makes shallow copy" => sub { + my $fake = bless { foo => 23, bar => 42 }, "Fake"; + my $obj = new_ok( "Alfa", [ $fake ] ); + is( ref $fake, "Fake", "object passed to constructor is original class" ); + is( $obj->foo, 23, "foo is set" ); + is( $obj->bar, 42, "bar is set" ); +}; + +subtest "attributs are RW" => sub { + my $obj = new_ok( "Alfa", [ { foo => 23, bar => 42 } ] ); + is( $obj->foo(24), 24, "changing foo returns new value" ); + is( $obj->foo, 24, "accessing foo returns changed value" ); +}; + +subtest "exceptions" => sub { + like( + exception { Alfa->new( foo => 23, bar => 42, baz => 13 ) }, + qr/Invalid attributes for Alfa: baz/, + "creating object with 'baz' dies", + ); + + like( + exception { Alfa->new( qw/ foo bar baz/ ) }, + qr/Alfa->new\(\) got an odd number of elements/, + "creating object with odd elements dies", + ); + + like( + exception { Alfa->new( [] ) }, + qr/Argument to Alfa->new\(\) could not be dereferenced as a hash/, + "creating object with array ref dies", + ); +}; + + + +done_testing; +# COPYRIGHT +# vim: ts=4 sts=4 sw=4 et: diff --git a/t/lib/Alfa.pm b/t/lib/Alfa.pm new file mode 100644 index 0000000..b4f8dc8 --- /dev/null +++ b/t/lib/Alfa.pm @@ -0,0 +1,8 @@ +use 5.008001; +use strict; +use warnings; +package Alfa; + +use Class::Tiny qw/foo bar/; + +1; -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libclass-tiny-perl.git _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits