summaryrefslogtreecommitdiff
path: root/t
diff options
context:
space:
mode:
Diffstat (limited to 't')
-rw-r--r--t/00-report-prereqs.dd55
-rw-r--r--t/00-report-prereqs.t183
-rw-r--r--t/alfa.t90
-rw-r--r--t/baker.t72
-rw-r--r--t/charlie.t37
-rw-r--r--t/delta.t48
-rw-r--r--t/echo.t46
-rw-r--r--t/foxtrot.t44
-rw-r--r--t/golf.t35
-rw-r--r--t/hotel.t46
-rw-r--r--t/juliett.t87
-rw-r--r--t/lib/Alfa.pm9
-rw-r--r--t/lib/Baker.pm10
-rw-r--r--t/lib/Charlie.pm28
-rw-r--r--t/lib/Delta.pm30
-rw-r--r--t/lib/Echo.pm22
-rw-r--r--t/lib/Foxtrot.pm10
-rw-r--r--t/lib/Golf.pm12
-rw-r--r--t/lib/Hotel.pm14
-rw-r--r--t/lib/India.pm10
-rw-r--r--t/lib/Juliett.pm10
-rw-r--r--t/lib/TestUtils.pm28
22 files changed, 926 insertions, 0 deletions
diff --git a/t/00-report-prereqs.dd b/t/00-report-prereqs.dd
new file mode 100644
index 0000000..044b078
--- /dev/null
+++ b/t/00-report-prereqs.dd
@@ -0,0 +1,55 @@
+do { my $x = {
+ 'configure' => {
+ 'requires' => {
+ 'ExtUtils::MakeMaker' => '6.17',
+ 'perl' => '5.006'
+ }
+ },
+ 'develop' => {
+ 'requires' => {
+ 'Dist::Zilla' => '5',
+ 'Dist::Zilla::Plugin::OnlyCorePrereqs' => '0.003',
+ 'Dist::Zilla::Plugin::PerlVersionPrereqs' => '0',
+ 'Dist::Zilla::Plugin::Prereqs' => '0',
+ 'Dist::Zilla::Plugin::RemovePrereqs' => '0',
+ 'Dist::Zilla::PluginBundle::DAGOLDEN' => '0.072',
+ 'File::Spec' => '0',
+ 'File::Temp' => '0',
+ 'IO::Handle' => '0',
+ 'IPC::Open3' => '0',
+ 'Pod::Coverage::TrustPod' => '0',
+ 'Test::CPAN::Meta' => '0',
+ 'Test::More' => '0',
+ 'Test::Pod' => '1.41',
+ 'Test::Pod::Coverage' => '1.08',
+ 'Test::Spelling' => '0.12',
+ 'Test::Version' => '1'
+ }
+ },
+ 'runtime' => {
+ 'requires' => {
+ 'Carp' => '0',
+ 'perl' => '5.006',
+ 'strict' => '0',
+ 'warnings' => '0'
+ }
+ },
+ 'test' => {
+ 'recommends' => {
+ 'CPAN::Meta' => '2.120900',
+ 'Test::FailWarnings' => '0'
+ },
+ 'requires' => {
+ 'Exporter' => '0',
+ 'ExtUtils::MakeMaker' => '0',
+ 'File::Spec' => '0',
+ 'Test::More' => '0.96',
+ 'base' => '0',
+ 'lib' => '0',
+ 'perl' => '5.006',
+ 'subs' => '0'
+ }
+ }
+ };
+ $x;
+ } \ No newline at end of file
diff --git a/t/00-report-prereqs.t b/t/00-report-prereqs.t
new file mode 100644
index 0000000..b0e7e65
--- /dev/null
+++ b/t/00-report-prereqs.t
@@ -0,0 +1,183 @@
+#!perl
+
+use strict;
+use warnings;
+
+# This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.020
+
+use Test::More tests => 1;
+
+use ExtUtils::MakeMaker;
+use File::Spec;
+
+# from $version::LAX
+my $lax_version_re =
+ qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )?
+ |
+ (?:\.[0-9]+) (?:_[0-9]+)?
+ ) | (?:
+ v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )?
+ |
+ (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)?
+ )
+ )/x;
+
+# hide optional CPAN::Meta modules from prereq scanner
+# and check if they are available
+my $cpan_meta = "CPAN::Meta";
+my $cpan_meta_pre = "CPAN::Meta::Prereqs";
+my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic
+
+# Verify requirements?
+my $DO_VERIFY_PREREQS = 1;
+
+sub _max {
+ my $max = shift;
+ $max = ( $_ > $max ) ? $_ : $max for @_;
+ return $max;
+}
+
+sub _merge_prereqs {
+ my ($collector, $prereqs) = @_;
+
+ # CPAN::Meta::Prereqs object
+ if (ref $collector eq $cpan_meta_pre) {
+ return $collector->with_merged_prereqs(
+ CPAN::Meta::Prereqs->new( $prereqs )
+ );
+ }
+
+ # Raw hashrefs
+ for my $phase ( keys %$prereqs ) {
+ for my $type ( keys %{ $prereqs->{$phase} } ) {
+ for my $module ( keys %{ $prereqs->{$phase}{$type} } ) {
+ $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module};
+ }
+ }
+ }
+
+ return $collector;
+}
+
+my @include = qw(
+
+);
+
+my @exclude = qw(
+
+);
+
+# Add static prereqs to the included modules list
+my $static_prereqs = do 't/00-report-prereqs.dd';
+
+# Merge all prereqs (either with ::Prereqs or a hashref)
+my $full_prereqs = _merge_prereqs(
+ ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ),
+ $static_prereqs
+);
+
+# Add dynamic prereqs to the included modules list (if we can)
+my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml';
+if ( $source && $HAS_CPAN_META ) {
+ if ( my $meta = eval { CPAN::Meta->load_file($source) } ) {
+ $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs);
+ }
+}
+else {
+ $source = 'static metadata';
+}
+
+my @full_reports;
+my @dep_errors;
+my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs;
+
+# Add static includes into a fake section
+for my $mod (@include) {
+ $req_hash->{other}{modules}{$mod} = 0;
+}
+
+for my $phase ( qw(configure build test runtime develop other) ) {
+ next unless $req_hash->{$phase};
+ next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING});
+
+ for my $type ( qw(requires recommends suggests conflicts modules) ) {
+ next unless $req_hash->{$phase}{$type};
+
+ my $title = ucfirst($phase).' '.ucfirst($type);
+ my @reports = [qw/Module Want Have/];
+
+ for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) {
+ next if $mod eq 'perl';
+ next if grep { $_ eq $mod } @exclude;
+
+ my $file = $mod;
+ $file =~ s{::}{/}g;
+ $file .= ".pm";
+ my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC;
+
+ my $want = $req_hash->{$phase}{$type}{$mod};
+ $want = "undef" unless defined $want;
+ $want = "any" if !$want && $want == 0;
+
+ my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required";
+
+ if ($prefix) {
+ my $have = MM->parse_version( File::Spec->catfile($prefix, $file) );
+ $have = "undef" unless defined $have;
+ push @reports, [$mod, $want, $have];
+
+ if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) {
+ if ( $have !~ /\A$lax_version_re\z/ ) {
+ push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)";
+ }
+ elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) {
+ push @dep_errors, "$mod version '$have' is not in required range '$want'";
+ }
+ }
+ }
+ else {
+ push @reports, [$mod, $want, "missing"];
+
+ if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) {
+ push @dep_errors, "$mod is not installed ($req_string)";
+ }
+ }
+ }
+
+ if ( @reports ) {
+ push @full_reports, "=== $title ===\n\n";
+
+ my $ml = _max( map { length $_->[0] } @reports );
+ my $wl = _max( map { length $_->[1] } @reports );
+ my $hl = _max( map { length $_->[2] } @reports );
+
+ if ($type eq 'modules') {
+ splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl];
+ push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports;
+ }
+ else {
+ splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl];
+ push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports;
+ }
+
+ push @full_reports, "\n";
+ }
+ }
+}
+
+if ( @full_reports ) {
+ diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports;
+}
+
+if ( @dep_errors ) {
+ diag join("\n",
+ "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n",
+ "The following REQUIRED prerequisites were not satisfied:\n",
+ @dep_errors,
+ "\n"
+ );
+}
+
+pass;
+
+# vim: ts=4 sts=4 sw=4 et:
diff --git a/t/alfa.t b/t/alfa.t
new file mode 100644
index 0000000..8bd97fb
--- /dev/null
+++ b/t/alfa.t
@@ -0,0 +1,90 @@
+use 5.006;
+use strict;
+use warnings;
+use lib 't/lib';
+
+use Test::More 0.96;
+use TestUtils;
+
+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 "attributes 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 "unknown attributes stripped" => sub {
+ my $obj = new_ok( "Alfa", [ { wibble => 1 } ], "new( wibble => 1 )" );
+ ok( !exists $obj->{wibble}, "unknown attribute 'wibble' not in object" );
+};
+
+subtest "exceptions" => sub {
+ 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;
+#
+# This file is part of Class-Tiny
+#
+# This software is Copyright (c) 2013 by David Golden.
+#
+# This is free software, licensed under:
+#
+# The Apache License, Version 2.0, January 2004
+#
+# vim: ts=4 sts=4 sw=4 et:
diff --git a/t/baker.t b/t/baker.t
new file mode 100644
index 0000000..8444b86
--- /dev/null
+++ b/t/baker.t
@@ -0,0 +1,72 @@
+use 5.006;
+use strict;
+use warnings;
+use lib 't/lib';
+
+use Test::More 0.96;
+use TestUtils;
+
+require_ok("Baker");
+
+subtest "attribute list" => sub {
+ is_deeply(
+ [ sort Class::Tiny->get_all_attributes_for("Baker") ],
+ [ sort qw/foo bar baz/ ],
+ "attribute list correct",
+ );
+};
+
+subtest "empty list constructor" => sub {
+ my $obj = new_ok("Baker");
+ is( $obj->foo, undef, "foo is undef" );
+ is( $obj->bar, undef, "bar is undef" );
+ is( $obj->baz, undef, "baz is undef" );
+};
+
+subtest "empty hash object constructor" => sub {
+ my $obj = new_ok( "Baker", [ {} ] );
+ is( $obj->foo, undef, "foo is undef" );
+ is( $obj->bar, undef, "bar is undef" );
+ is( $obj->baz, undef, "baz is undef" );
+};
+
+subtest "subclass attribute set as list" => sub {
+ my $obj = new_ok( "Baker", [ baz => 23 ] );
+ is( $obj->foo, undef, "foo is undef" );
+ is( $obj->bar, undef, "bar is undef" );
+ is( $obj->baz, 23, "baz is set " );
+};
+
+subtest "superclass attribute set as list" => sub {
+ my $obj = new_ok( "Baker", [ bar => 42, baz => 23 ] );
+ is( $obj->foo, undef, "foo is undef" );
+ is( $obj->bar, 42, "bar is set" );
+ is( $obj->baz, 23, "baz is set " );
+};
+
+subtest "all attributes set as list" => sub {
+ my $obj = new_ok( "Baker", [ foo => 13, bar => 42, baz => 23 ] );
+ is( $obj->foo, 13, "foo is set" );
+ is( $obj->bar, 42, "bar is set" );
+ is( $obj->baz, 23, "baz is set " );
+};
+
+subtest "attributes are RW" => sub {
+ my $obj = new_ok( "Baker", [ { foo => 23, bar => 42 } ] );
+ is( $obj->foo(24), 24, "changing foo returns new value" );
+ is( $obj->foo, 24, "accessing foo returns changed value" );
+ is( $obj->baz(42), 42, "changing baz returns new value" );
+ is( $obj->baz, 42, "accessing baz returns changed value" );
+};
+
+done_testing;
+#
+# This file is part of Class-Tiny
+#
+# This software is Copyright (c) 2013 by David Golden.
+#
+# This is free software, licensed under:
+#
+# The Apache License, Version 2.0, January 2004
+#
+# vim: ts=4 sts=4 sw=4 et:
diff --git a/t/charlie.t b/t/charlie.t
new file mode 100644
index 0000000..faaf0ce
--- /dev/null
+++ b/t/charlie.t
@@ -0,0 +1,37 @@
+use 5.006;
+use strict;
+use warnings;
+use lib 't/lib';
+
+use Test::More 0.96;
+use TestUtils;
+
+require_ok("Charlie");
+
+subtest "all attributes set as list" => sub {
+ my $obj = new_ok( "Charlie", [ foo => 13, bar => [42] ] );
+ is( $obj->foo, 13, "foo is set" );
+ is_deeply( $obj->bar, [42], "bar is set" );
+};
+
+subtest "custom accessor" => sub {
+ my $obj = new_ok( "Charlie", [ foo => 13, bar => [42] ] );
+ is_deeply( $obj->bar(qw/1 1 2 3 5/), [qw/1 1 2 3 5/], "bar is set" );
+};
+
+subtest "custom accessor with default" => sub {
+ my $obj = new_ok( "Charlie", [ foo => 13, bar => [42] ] );
+ is( $obj->baz, 23, "custom accessor has default" );
+};
+
+done_testing;
+#
+# This file is part of Class-Tiny
+#
+# This software is Copyright (c) 2013 by David Golden.
+#
+# This is free software, licensed under:
+#
+# The Apache License, Version 2.0, January 2004
+#
+# vim: ts=4 sts=4 sw=4 et:
diff --git a/t/delta.t b/t/delta.t
new file mode 100644
index 0000000..d83922d
--- /dev/null
+++ b/t/delta.t
@@ -0,0 +1,48 @@
+use 5.006;
+use strict;
+use warnings;
+use lib 't/lib';
+
+use Test::More 0.96;
+use TestUtils;
+
+require_ok("Delta");
+
+subtest "attribute set as list" => sub {
+ my $obj = new_ok( "Delta", [ foo => 42, bar => 23 ] );
+ is( $obj->foo, 42, "foo is set" );
+ is( $obj->bar, 23, "bar is set" );
+};
+
+subtest "__no_BUILD__" => sub {
+ my $obj = new_ok( "Delta", [ __no_BUILD__ => 1 ], "new( __no_BUILD__ => 1 )" );
+ is( $Delta::counter, 0, "BUILD method didn't run" );
+};
+
+subtest "destructor" => sub {
+ my @objs = map { new_ok( "Delta", [ foo => 42, bar => 23 ] ) } 1 .. 3;
+ is( $Delta::counter, 3, "BUILD incremented counter" );
+ @objs = ();
+ is( $Delta::counter, 0, "DEMOLISH decremented counter" );
+};
+
+subtest "exceptions" => sub {
+ like(
+ exception { Delta->new( foo => 0 ) },
+ qr/foo must be positive/,
+ "BUILD validation throws error",
+ );
+
+};
+
+done_testing;
+#
+# This file is part of Class-Tiny
+#
+# This software is Copyright (c) 2013 by David Golden.
+#
+# This is free software, licensed under:
+#
+# The Apache License, Version 2.0, January 2004
+#
+# vim: ts=4 sts=4 sw=4 et:
diff --git a/t/echo.t b/t/echo.t
new file mode 100644
index 0000000..de8cff5
--- /dev/null
+++ b/t/echo.t
@@ -0,0 +1,46 @@
+use 5.006;
+use strict;
+use warnings;
+use lib 't/lib';
+
+use Test::More 0.96;
+use TestUtils;
+
+require_ok("Echo");
+
+subtest "attribute set as list" => sub {
+ my $obj = new_ok( "Echo", [ foo => 42, bar => 23 ] );
+ is( $obj->foo, 42, "foo is set" );
+ is( $obj->bar, 23, "bar is set" );
+ is( $obj->baz, 24, "baz is set" );
+};
+
+subtest "destructor" => sub {
+ no warnings 'once';
+ my @objs = map { new_ok( "Echo", [ foo => 42, bar => 23 ] ) } 1 .. 3;
+ is( $Delta::counter, 3, "BUILD incremented counter" );
+ @objs = ();
+ is( $Delta::counter, 0, "DEMOLISH decremented counter" );
+ is( $Delta::exception, 0, "cleanup worked in correct order" );
+};
+
+subtest "exceptions" => sub {
+ like(
+ exception { Echo->new( foo => 0, bar => 23 ) },
+ qr/foo must be positive/,
+ "BUILD validation throws error",
+ );
+
+};
+
+done_testing;
+#
+# This file is part of Class-Tiny
+#
+# This software is Copyright (c) 2013 by David Golden.
+#
+# This is free software, licensed under:
+#
+# The Apache License, Version 2.0, January 2004
+#
+# vim: ts=4 sts=4 sw=4 et:
diff --git a/t/foxtrot.t b/t/foxtrot.t
new file mode 100644
index 0000000..a501da6
--- /dev/null
+++ b/t/foxtrot.t
@@ -0,0 +1,44 @@
+use 5.006;
+use strict;
+use warnings;
+use lib 't/lib';
+
+use Test::More 0.96;
+use TestUtils;
+
+require_ok("Foxtrot");
+
+subtest "attribute list" => sub {
+ is_deeply(
+ [ sort Class::Tiny->get_all_attributes_for("Foxtrot") ],
+ [ sort qw/foo bar baz/ ],
+ "attribute list correct",
+ );
+};
+
+subtest "attribute defaults" => sub {
+ my $def = Class::Tiny->get_all_attribute_defaults_for("Foxtrot");
+ is( keys %$def, 3, "defaults hashref size" );
+ is( $def->{foo}, undef, "foo default is undef" );
+ is( $def->{bar}, 42, "bar default is 42" );
+ is( ref $def->{baz}, 'CODE', "baz default is a coderef" );
+};
+
+subtest "attribute set as list" => sub {
+ my $obj = new_ok( "Foxtrot", [ foo => 42, bar => 23 ] );
+ is( $obj->foo, 42, "foo is set" );
+ is( $obj->bar, 23, "bar is set" );
+ ok( $obj->baz, "baz is set" );
+};
+
+done_testing;
+#
+# This file is part of Class-Tiny
+#
+# This software is Copyright (c) 2013 by David Golden.
+#
+# This is free software, licensed under:
+#
+# The Apache License, Version 2.0, January 2004
+#
+# vim: ts=4 sts=4 sw=4 et:
diff --git a/t/golf.t b/t/golf.t
new file mode 100644
index 0000000..43a186a
--- /dev/null
+++ b/t/golf.t
@@ -0,0 +1,35 @@
+use 5.006;
+use strict;
+use warnings;
+use lib 't/lib';
+
+use Test::More 0.96;
+use TestUtils;
+
+require_ok("Golf");
+
+subtest "lazy defaults" => sub {
+ my $obj = new_ok("Golf");
+ is( $obj->foo, undef, "foo is undef" );
+ is( $obj->bar, undef, "bar is undef" );
+ ok( !exists( $obj->{wibble} ), "lazy wibble doesn't exist" );
+ ok( !exists( $obj->{wobble} ), "lazy wobble doesn't exist" );
+ is( $obj->wibble, 42, "wibble access gives default" );
+ is( ref $obj->wobble, 'ARRAY', "wobble access gives default" );
+ ok( exists( $obj->{wibble} ), "lazy wibble does exist" );
+ ok( exists( $obj->{wobble} ), "lazy wobble does exist" );
+ my $obj2 = new_ok("Golf");
+ isnt( $obj->wobble, $obj2->wobble, "coderefs run for each object" );
+};
+
+done_testing;
+#
+# This file is part of Class-Tiny
+#
+# This software is Copyright (c) 2013 by David Golden.
+#
+# This is free software, licensed under:
+#
+# The Apache License, Version 2.0, January 2004
+#
+# vim: ts=4 sts=4 sw=4 et:
diff --git a/t/hotel.t b/t/hotel.t
new file mode 100644
index 0000000..e5b3ef0
--- /dev/null
+++ b/t/hotel.t
@@ -0,0 +1,46 @@
+use 5.006;
+use strict;
+use warnings;
+use lib 't/lib';
+
+use Test::More 0.96;
+use TestUtils;
+
+require_ok("Hotel");
+
+subtest "attribute list" => sub {
+ my $attributes = [ sort Class::Tiny->get_all_attributes_for("Hotel") ];
+ is_deeply(
+ $attributes,
+ [ sort qw/foo bar wibble wobble zig zag/ ],
+ "attribute list correct",
+ ) or diag explain $attributes;
+};
+
+subtest "attribute defaults" => sub {
+ my $def = Class::Tiny->get_all_attribute_defaults_for("Hotel");
+ is( keys %$def, 6, "defaults hashref size" );
+ is( $def->{foo}, undef, "foo default is undef" );
+ is( $def->{bar}, undef, "bar default is undef" );
+ is( $def->{wibble}, 23, "wibble default overrides" );
+};
+
+subtest "attribute set as list" => sub {
+ my $obj = new_ok( "Hotel", [ foo => 42, bar => 23 ] );
+ is( $obj->foo, 42, "foo is set" );
+ is( $obj->bar, 23, "bar is set" );
+ is( $obj->wibble, 23, "wibble is set" );
+ is( ref $obj->wobble, 'HASH', "wobble default overrides" );
+};
+
+done_testing;
+#
+# This file is part of Class-Tiny
+#
+# This software is Copyright (c) 2013 by David Golden.
+#
+# This is free software, licensed under:
+#
+# The Apache License, Version 2.0, January 2004
+#
+# vim: ts=4 sts=4 sw=4 et:
diff --git a/t/juliett.t b/t/juliett.t
new file mode 100644
index 0000000..e6f85a5
--- /dev/null
+++ b/t/juliett.t
@@ -0,0 +1,87 @@
+use 5.006;
+use strict;
+use warnings;
+use lib 't/lib';
+
+use Test::More 0.96;
+use TestUtils;
+
+require_ok("Juliett");
+
+subtest "attribute list" => sub {
+ is_deeply(
+ [ sort Class::Tiny->get_all_attributes_for("Juliett") ],
+ [ sort qw/foo bar baz qux kit/ ],
+ "attribute list correct",
+ );
+};
+
+subtest "empty list constructor" => sub {
+ my $obj = new_ok("Juliett");
+ is( $obj->foo, undef, "foo is undef" );
+ is( $obj->bar, undef, "bar is undef" );
+ is( $obj->baz, undef, "baz is undef" );
+ is( $obj->qux, undef, "qux is undef" );
+ is( $obj->kit, undef, "kit is undef" );
+};
+
+subtest "empty hash object constructor" => sub {
+ my $obj = new_ok( "Juliett", [ {} ] );
+ is( $obj->foo, undef, "foo is undef" );
+ is( $obj->bar, undef, "bar is undef" );
+ is( $obj->baz, undef, "baz is undef" );
+ is( $obj->qux, undef, "qux is undef" );
+ is( $obj->kit, undef, "kit is undef" );
+};
+
+subtest "subclass attribute set as list" => sub {
+ my $obj = new_ok( "Juliett", [ kit => 23 ] );
+ is( $obj->foo, undef, "foo is undef" );
+ is( $obj->bar, undef, "bar is undef" );
+ is( $obj->qux, undef, "baz is undef" );
+ is( $obj->qux, undef, "qux is undef" );
+ is( $obj->kit, 23, "kit is set" );
+};
+
+subtest "superclass attribute set as list" => sub {
+ my $obj = new_ok( "Juliett", [ bar => 42, baz => 23, qux => 13, kit => 31 ] );
+ is( $obj->foo, undef, "foo is undef" );
+ is( $obj->bar, 42, "bar is set" );
+ is( $obj->baz, 23, "baz is set" );
+ is( $obj->qux, 13, "qux is set" );
+ is( $obj->kit, 31, "kit is set" );
+};
+
+subtest "all attributes set as list" => sub {
+ my $obj =
+ new_ok( "Juliett", [ foo => 13, bar => 42, baz => 23, qux => 11, kit => 31 ] );
+ is( $obj->foo, 13, "foo is set" );
+ is( $obj->bar, 42, "bar is set" );
+ is( $obj->baz, 23, "baz is set" );
+ is( $obj->qux, 11, "qux is set" );
+ is( $obj->kit, 31, "kit is set" );
+};
+
+subtest "attributes are RW" => sub {
+ my $obj = new_ok( "Juliett", [ { foo => 23, bar => 42 } ] );
+ is( $obj->foo(24), 24, "changing foo returns new value" );
+ is( $obj->foo, 24, "accessing foo returns changed value" );
+ is( $obj->baz(42), 42, "changing baz returns new value" );
+ is( $obj->baz, 42, "accessing baz returns changed value" );
+ is( $obj->qux(11), 11, "changing qux returns new value" );
+ is( $obj->qux, 11, "accessing qux returns changed value" );
+ is( $obj->kit(31), 31, "changing kit returns new value" );
+ is( $obj->kit, 31, "accessing kit rerutns changed value" );
+};
+
+done_testing;
+#
+# This file is part of Class-Tiny
+#
+# This software is Copyright (c) 2013 by David Golden.
+#
+# This is free software, licensed under:
+#
+# The Apache License, Version 2.0, January 2004
+#
+# 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..9d1326c
--- /dev/null
+++ b/t/lib/Alfa.pm
@@ -0,0 +1,9 @@
+use 5.006;
+use strict;
+use warnings;
+
+package Alfa;
+
+use Class::Tiny qw/foo bar/;
+
+1;
diff --git a/t/lib/Baker.pm b/t/lib/Baker.pm
new file mode 100644
index 0000000..f9caf3e
--- /dev/null
+++ b/t/lib/Baker.pm
@@ -0,0 +1,10 @@
+use 5.006;
+use strict;
+use warnings;
+
+package Baker;
+use base 'Alfa';
+
+use Class::Tiny qw/baz/;
+
+1;
diff --git a/t/lib/Charlie.pm b/t/lib/Charlie.pm
new file mode 100644
index 0000000..7d312bd
--- /dev/null
+++ b/t/lib/Charlie.pm
@@ -0,0 +1,28 @@
+use 5.006;
+use strict;
+use warnings;
+
+package Charlie;
+
+use subs qw/bar baz/;
+
+use Class::Tiny qw/foo bar/, { baz => 23 };
+
+sub bar {
+ my $self = shift;
+ if (@_) {
+ $self->{bar} = [@_];
+ }
+ return $self->{bar};
+}
+
+sub baz {
+ my $self = shift;
+ if (@_) {
+ $self->{baz} = shift;
+ }
+ return $self->{baz} ||=
+ Class::Tiny->get_all_attribute_defaults_for( ref $self )->{baz};
+}
+
+1;
diff --git a/t/lib/Delta.pm b/t/lib/Delta.pm
new file mode 100644
index 0000000..119bb4f
--- /dev/null
+++ b/t/lib/Delta.pm
@@ -0,0 +1,30 @@
+use 5.006;
+use strict;
+use warnings;
+
+package Delta;
+
+our $counter = 0;
+our $exception = 0;
+
+use Carp ();
+
+use Class::Tiny qw/foo bar/;
+
+sub BUILD {
+ my $self = shift;
+ my $args = shift;
+ Carp::croak("foo must be positive")
+ unless defined $self->foo && $self->foo > 0;
+
+ $self->bar(42) unless defined $self->bar;
+ $counter++;
+}
+
+sub DEMOLISH {
+ my $self = shift;
+ $counter-- if $counter > 0;
+ $exception++ if keys %$self > 2; # Echo will delete first
+}
+
+1;
diff --git a/t/lib/Echo.pm b/t/lib/Echo.pm
new file mode 100644
index 0000000..5bf2ae8
--- /dev/null
+++ b/t/lib/Echo.pm
@@ -0,0 +1,22 @@
+use 5.006;
+use strict;
+use warnings;
+
+package Echo;
+use base 'Delta';
+
+use Class::Tiny qw/baz/;
+
+sub BUILD {
+ my $self = shift;
+ $self->baz( $self->bar + 1 );
+}
+
+sub DEMOLISH {
+ my $self = shift;
+ delete $self->{baz}; # or else Delta::DEMOLISH dies
+}
+
+sub a_method { 1 }
+
+1;
diff --git a/t/lib/Foxtrot.pm b/t/lib/Foxtrot.pm
new file mode 100644
index 0000000..b757d47
--- /dev/null
+++ b/t/lib/Foxtrot.pm
@@ -0,0 +1,10 @@
+use 5.006;
+use strict;
+use warnings;
+
+package Foxtrot;
+
+use Class::Tiny 'foo';
+use Class::Tiny { bar => 42, baz => sub { time } };
+
+1;
diff --git a/t/lib/Golf.pm b/t/lib/Golf.pm
new file mode 100644
index 0000000..5e07438
--- /dev/null
+++ b/t/lib/Golf.pm
@@ -0,0 +1,12 @@
+use 5.006;
+use strict;
+use warnings;
+
+package Golf;
+
+use Class::Tiny qw/foo bar/, {
+ wibble => 42,
+ wobble => sub { [] },
+}, qw/zig zag/;
+
+1;
diff --git a/t/lib/Hotel.pm b/t/lib/Hotel.pm
new file mode 100644
index 0000000..eabe099
--- /dev/null
+++ b/t/lib/Hotel.pm
@@ -0,0 +1,14 @@
+use 5.006;
+use strict;
+use warnings;
+
+package Hotel;
+
+use base 'Golf';
+
+use Class::Tiny {
+ wibble => 23,
+ wobble => sub { {} },
+};
+
+1;
diff --git a/t/lib/India.pm b/t/lib/India.pm
new file mode 100644
index 0000000..ea39909
--- /dev/null
+++ b/t/lib/India.pm
@@ -0,0 +1,10 @@
+use 5.006;
+use strict;
+use warnings;
+
+package India;
+use base 'Alfa';
+
+use Class::Tiny qw/qux/;
+
+1;
diff --git a/t/lib/Juliett.pm b/t/lib/Juliett.pm
new file mode 100644
index 0000000..52857ff
--- /dev/null
+++ b/t/lib/Juliett.pm
@@ -0,0 +1,10 @@
+use 5.006;
+use strict;
+use warnings;
+
+package Juliett;
+use base 'Baker', 'India';
+
+use Class::Tiny qw/kit/;
+
+1;
diff --git a/t/lib/TestUtils.pm b/t/lib/TestUtils.pm
new file mode 100644
index 0000000..c66b8b3
--- /dev/null
+++ b/t/lib/TestUtils.pm
@@ -0,0 +1,28 @@
+use 5.006;
+use strict;
+use warnings;
+package TestUtils;
+
+use Carp;
+
+use Exporter;
+our @ISA = qw/Exporter/;
+our @EXPORT = qw(
+ exception
+);
+
+# If we have Test::FailWarnings, use it
+BEGIN {
+ eval { require Test::FailWarnings; 1 } and do { Test::FailWarnings->import };
+}
+
+sub exception(&) {
+ my $code = shift;
+ my $success = eval { $code->(); 1 };
+ my $err = $@;
+ return '' if $success;
+ croak "Execution died, but the error was lost" unless $@;
+ return $@;
+}
+
+1;
View Lorry Controller Status