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
