├── .gitignore ├── .local.vimrc ├── .mailmap ├── .perltidyrc ├── .travis.yml ├── CONTRIBUTING.mkdn ├── Changes ├── Makefile.PL ├── README.mkdn ├── dist.ini ├── lib └── Class │ └── Tiny.pm ├── perlcritic.rc ├── t ├── alfa.t ├── baker.t ├── charlie.t ├── delta.t ├── echo.t ├── foxtrot.t ├── golf.t ├── hotel.t ├── juliett.t └── lib │ ├── Alfa.pm │ ├── Baker.pm │ ├── Charlie.pm │ ├── Delta.pm │ ├── Echo.pm │ ├── Foxtrot.pm │ ├── Golf.pm │ ├── Hotel.pm │ ├── India.pm │ ├── Juliett.pm │ └── TestUtils.pm └── tidyall.ini /.gitignore: -------------------------------------------------------------------------------- 1 | /Class-Tiny* 2 | /.build 3 | /.tidyall.d 4 | -------------------------------------------------------------------------------- /.local.vimrc: -------------------------------------------------------------------------------- 1 | autocmd BufWritePre *.pl,*.pm,*.t call DoTidyWrite() 2 | -------------------------------------------------------------------------------- /.mailmap: -------------------------------------------------------------------------------- 1 | David Golden 2 | Gelu Lupaş 3 | Karen Etheridge 4 | Matt S Trout 5 | Olivier Mengué 6 | Toby Inkster 7 | -------------------------------------------------------------------------------- /.perltidyrc: -------------------------------------------------------------------------------- 1 | # DAGOLDEN .perltidyrc file 2 | 3 | -se # Errors to STDERR 4 | 5 | -l=85 # Max line width target 6 | -vmll # variable maximum line length 7 | -wc=10 # depth to reduce indentation levels 8 | -i=4 # Indent level 9 | -ci=2 # Continuation 10 | 11 | -vt=0 # vertical tightness 12 | -cti=0 # extra indentation for closing brackets 13 | -vtc=0 # close parens on own line if possible 14 | 15 | -nsot # stack opening 16 | -nsct # stack closing 17 | 18 | -notr # opening tokens on right of a line 19 | -pt=1 # parenthesis tightness 20 | -bt=1 # brace tightness 21 | -sbt=1 # square bracket tightness 22 | -bbt=0 # block brace tightness 23 | #-boc # break at old comma breakpoints 24 | -cab=1 25 | 26 | -nsfp # no space after function 27 | -nsfs # No space before semicolons in for loops 28 | 29 | -nolq # Don't outdent long quoted strings 30 | -nola # Don't outdent labels 31 | -nolc # Don't outdent long comments 32 | -nokw # Don't outdent keywords 33 | -nhsc # Don't expect hanging side comments 34 | -nbbc # No blank before comments 35 | -tso # Tight secret operators 36 | 37 | -msc=1 # Space to side comment 38 | 39 | #-wbb="% + - * / x != == >= <= =~ !~ < > | & = **= += *= &= <<= &&= -= /= |= >>= ||= //= .= %= ^= x=" 40 | -wbb="% + - * / x != == >= <= =~ !~ < > | &" 41 | # Break before all operators except assignment 42 | 43 | -ole=unix # line endings 44 | 45 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | language: perl 3 | perl: 4 | - "5.8.1" 5 | - "5.8.8" 6 | - "5.8.8-thr" 7 | - "5.10" 8 | - "5.12" 9 | - "5.14" 10 | - "5.16" 11 | - "5.18" 12 | - "5.20" 13 | - "5.22" 14 | - "5.24" 15 | - "5.26" 16 | - "5.28" 17 | - "5.30" 18 | - "5.32" 19 | - "blead" 20 | matrix: 21 | include: 22 | - perl: 5.18 23 | env: COVERAGE=1 24 | allow_failures: 25 | - perl: "blead" 26 | before_install: 27 | - git clone git://github.com/travis-perl/helpers ~/travis-perl-helpers 28 | - source ~/travis-perl-helpers/init 29 | - build-perl 30 | - perl -V 31 | install: 32 | - cpan-install --deps # installs prereqs, including recommends 33 | - cpan-install --coverage # installs converage prereqs, if enabled 34 | before_script: 35 | - coverage-setup 36 | script: 37 | - prove -l -j$(test-jobs) $(test-files) # parallel testing 38 | after_success: 39 | - coverage-report 40 | # vim: ts=2 sts=2 sw=2 et: 41 | -------------------------------------------------------------------------------- /CONTRIBUTING.mkdn: -------------------------------------------------------------------------------- 1 | ## HOW TO CONTRIBUTE 2 | 3 | Thank you for considering contributing to this distribution. This file 4 | contains instructions that will help you work with the source code. 5 | 6 | The distribution is managed with Dist::Zilla. This means than many of the 7 | usual files you might expect are not in the repository, but are generated at 8 | release time, as is much of the documentation. Some generated files are 9 | kept in the repository as a convenience (e.g. Makefile.PL or cpanfile). 10 | 11 | Generally, **you do not need Dist::Zilla to contribute patches**. You do need 12 | Dist::Zilla to create a tarball. See below for guidance. 13 | 14 | ### Getting dependencies 15 | 16 | If you have App::cpanminus 1.6 or later installed, you can use `cpanm` to 17 | satisfy dependencies like this: 18 | 19 | $ cpanm --installdeps . 20 | 21 | Otherwise, look for either a `Makefile.PL` or `cpanfile` file for 22 | a list of dependencies to satisfy. 23 | 24 | ### Running tests 25 | 26 | You can run tests directly using the `prove` tool: 27 | 28 | $ prove -l 29 | $ prove -lv t/some_test_file.t 30 | 31 | For most of my distributions, `prove` is entirely sufficient for you to test any 32 | patches you have. I use `prove` for 99% of my testing during development. 33 | 34 | ### Code style and tidying 35 | 36 | Please try to match any existing coding style. If there is a `.perltidyrc` 37 | file, please install Perl::Tidy and use perltidy before submitting patches. 38 | 39 | If there is a `tidyall.ini` file, you can also install Code::TidyAll and run 40 | `tidyall` on a file or `tidyall -a` to tidy all files. 41 | 42 | ### Patching documentation 43 | 44 | Much of the documentation Pod is generated at release time. Some is 45 | generated boilerplate; other documentation is built from pseudo-POD 46 | directives in the source like C<=method> or C<=func>. 47 | 48 | If you would like to submit a documentation edit, please limit yourself to 49 | the documentation you see. 50 | 51 | If you see typos or documentation issues in the generated docs, please 52 | email or open a bug ticket instead of patching. 53 | 54 | ### Installing and using Dist::Zilla 55 | 56 | Dist::Zilla is a very powerful authoring tool, optimized for maintaining a 57 | large number of distributions with a high degree of automation, but it has a 58 | large dependency chain, a bit of a learning curve and requires a number of 59 | author-specific plugins. 60 | 61 | To install it from CPAN, I recommend one of the following approaches for 62 | the quickest installation: 63 | 64 | # using CPAN.pm, but bypassing non-functional pod tests 65 | $ cpan TAP::Harness::Restricted 66 | $ PERL_MM_USE_DEFAULT=1 HARNESS_CLASS=TAP::Harness::Restricted cpan Dist::Zilla 67 | 68 | # using cpanm, bypassing *all* tests 69 | $ cpanm -n Dist::Zilla 70 | 71 | In either case, it's probably going to take about 10 minutes. Go for a walk, 72 | go get a cup of your favorite beverage, take a bathroom break, or whatever. 73 | When you get back, Dist::Zilla should be ready for you. 74 | 75 | Then you need to install any plugins specific to this distribution: 76 | 77 | $ cpan `dzil authordeps` 78 | $ dzil authordeps | cpanm 79 | 80 | Once installed, here are some dzil commands you might try: 81 | 82 | $ dzil build 83 | $ dzil test 84 | $ dzil xtest 85 | 86 | You can learn more about Dist::Zilla at http://dzil.org/ 87 | 88 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Class-Tiny 2 | 3 | {{$NEXT}} 4 | 5 | 1.008 2020-09-04 10:04:50-04:00 America/New_York 6 | 7 | - No changes since 1.007 8 | 9 | 1.007 2020-09-02 07:02:55-04:00 America/New_York (TRIAL RELEASE) 10 | 11 | [DOCUMENTATION] 12 | 13 | - DEMOLISH docs incorrectly claimed that errors were thrown. Updated to 14 | say that errors are rethrown. 15 | 16 | 1.006 2016-09-10 14:47:49-04:00 America/New_York 17 | 18 | - No changes since 1.005 19 | 20 | 1.005 2016-09-06 12:12:06-04:00 America/New_York (TRIAL RELEASE) 21 | 22 | [INTERNAL] 23 | 24 | - Optimize generated accessors (5% to 25% faster depending on 25 | combination of read vs write and default vs no-default). 26 | 27 | 1.004 2015-10-30 10:33:59-04:00 America/New_York 28 | 29 | - No changes since 1.003 30 | 31 | 1.003 2015-10-27 13:01:02-04:00 America/New_York (TRIAL RELEASE) 32 | 33 | [INTERNAL] 34 | 35 | - Refactored accessor generation to allow subclasses of Class::Tiny 36 | to implement alternate accessors. 37 | 38 | 1.001 2015-01-30 21:13:07-05:00 America/New_York 39 | 40 | [ADDED] 41 | 42 | - Added support for BUILDARGS for Moo(se) compatibility 43 | 44 | [INTERNAL] 45 | 46 | - Implements BUILDALL via method (was inline) for Moo(se) compatibility 47 | 48 | 1.000 2014-07-16 09:55:29-04:00 America/New_York 49 | 50 | [*** INCOMPATIBLE CHANGES ***] 51 | 52 | - Attributes for custom accessors *MUST* be declared for them to be 53 | set via the constructor. It is no longer sufficient for a method of 54 | the same name to exist. 55 | 56 | - Unknown constructor arguments are ignored rather than fatal; they are 57 | not included in the object. Special instructions for using BUILD to 58 | hide constructor arguments from validation are irrelevant and have 59 | been removed. 60 | 61 | - These changes make Class::Tiny-based classes easier to subclass by 62 | more advanced object frameworks like Moose or Moo. 63 | 64 | 0.015 2014-07-13 23:10:47-04:00 America/New_York 65 | 66 | [CHANGED] 67 | 68 | - lowered minimum perl to 5.006 69 | 70 | 0.014 2013-11-28 07:12:14 America/New_York 71 | 72 | [FIXED] 73 | 74 | - put back a 'no warnings "once"' line that caused downstream warnings 75 | 76 | 0.013 2013-11-26 12:01:13 America/New_York 77 | 78 | [DOCUMENTED] 79 | 80 | - expanded comparision to Object::Tiny and Class::Accessor 81 | 82 | 0.012 2013-11-01 16:36:35 America/New_York 83 | 84 | [DOCUMENTED] 85 | 86 | - added documentation notes about multiple inheritance 87 | and attribute defaults under subclassing 88 | 89 | [INTERNAL] 90 | 91 | - added tests for multiple inheritance 92 | 93 | 0.011 2013-09-25 11:08:07 America/New_York 94 | 95 | [FIXED] 96 | 97 | - compile test could hang on Windows 98 | 99 | [PREREQS] 100 | 101 | - ExtUtils::MakeMaker configure_requires dropped to 6.17 102 | 103 | 0.010 2013-09-18 13:23:15 America/New_York 104 | 105 | [FIXED] 106 | 107 | - suppressed 'used only once' warnings (GH #9) 108 | 109 | 0.009 2013-09-17 06:54:47 America/New_York 110 | 111 | [FIXED] 112 | 113 | - "won't stay shared" bug on older perls 114 | 115 | 0.008 2013-09-08 09:49:46 America/New_York 116 | 117 | [FIXED] 118 | 119 | - META.yml encoding problems 120 | 121 | [DOCUMENTED] 122 | 123 | - revised CONTRIBUTING 124 | 125 | [INTERNAL] 126 | 127 | - refactored precaching 128 | 129 | 0.007 2013-09-07 16:48:56 America/New_York 130 | 131 | [OPTIMIZED] 132 | 133 | - accessors without defaults are now much faster (comparable 134 | to Class::Accessor::Fast) 135 | 136 | - constructor and destructors are slightly faster when there 137 | are no superclasses except Class::Tiny::Object 138 | 139 | - linearized @ISA and other items are cached for speed when 140 | the first object is created 141 | 142 | 0.006 2013-09-05 11:56:48 America/New_York 143 | 144 | [ADDED] 145 | 146 | - added introspection method: get_all_attribute_defaults_for($class) 147 | 148 | [DOCUMENTED] 149 | 150 | - Fixed TOBYINK email address for contributors list 151 | 152 | - Revised rationale for why Class::Tiny vs other modules 153 | 154 | 0.005 2013-08-28 11:51:37 America/New_York 155 | 156 | [ADDED] 157 | 158 | - Attributes now support lazy defaults passed as a hash reference 159 | to the class declaration 160 | 161 | 0.004 2013-08-21 16:38:01 America/New_York 162 | 163 | [CHANGED] 164 | 165 | - Base class is now Class::Tiny::Object; Class::Tiny is now only the 166 | class builder 167 | 168 | - BUILD and DEMOLISH now have Moo(se) like semantics: BUILD gets 169 | original constructor arguments. DEMOLISH is now passed a global 170 | destruction flag (requires Devel::GlobalDestruction on Perls before 171 | v5.14) 172 | 173 | - Constructor argument validation now happens after BUILD. 174 | 175 | - Constructor argument validation has been softened to a heuristic: 176 | argument names must match a method name 177 | 178 | [ADDED] 179 | 180 | - added introspection method: get_all_attributes_for($class) 181 | 182 | [INTERNAL] 183 | 184 | - Refactored import() for easier subclassing of Class::Tiny should 185 | anyone be crazy enough to do so 186 | 187 | 0.003 2013-08-19 19:43:36 America/New_York 188 | 189 | [FIXED] 190 | 191 | - Multiple invocations of "use Class::Tiny" in a package accumulate 192 | attributes instead of overwriting them 193 | 194 | 0.002 2013-08-19 17:17:24 America/New_York 195 | 196 | [CHANGED] 197 | 198 | - Slight reduction in memory usage tracking attributes 199 | 200 | 0.001 2013-08-16 10:48:33 America/New_York 201 | 202 | - First release 203 | 204 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use 5.006; 5 | 6 | use ExtUtils::MakeMaker 6.17; 7 | 8 | my %WriteMakefileArgs = ( 9 | "ABSTRACT" => "Minimalist class construction", 10 | "AUTHOR" => "David Golden ", 11 | "CONFIGURE_REQUIRES" => { 12 | "ExtUtils::MakeMaker" => "6.17" 13 | }, 14 | "DISTNAME" => "Class-Tiny", 15 | "LICENSE" => "apache", 16 | "MIN_PERL_VERSION" => "5.006", 17 | "NAME" => "Class::Tiny", 18 | "PREREQ_PM" => { 19 | "Carp" => 0, 20 | "strict" => 0, 21 | "warnings" => 0 22 | }, 23 | "TEST_REQUIRES" => { 24 | "Exporter" => 0, 25 | "ExtUtils::MakeMaker" => 0, 26 | "File::Spec" => 0, 27 | "Test::More" => "0.96", 28 | "base" => 0, 29 | "lib" => 0, 30 | "subs" => 0 31 | }, 32 | "VERSION" => "1.009", 33 | "test" => { 34 | "TESTS" => "t/*.t" 35 | } 36 | ); 37 | 38 | 39 | my %FallbackPrereqs = ( 40 | "Carp" => 0, 41 | "Exporter" => 0, 42 | "ExtUtils::MakeMaker" => 0, 43 | "File::Spec" => 0, 44 | "Test::More" => "0.96", 45 | "base" => 0, 46 | "lib" => 0, 47 | "strict" => 0, 48 | "subs" => 0, 49 | "warnings" => 0 50 | ); 51 | 52 | 53 | unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { 54 | delete $WriteMakefileArgs{TEST_REQUIRES}; 55 | delete $WriteMakefileArgs{BUILD_REQUIRES}; 56 | $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; 57 | } 58 | 59 | delete $WriteMakefileArgs{CONFIGURE_REQUIRES} 60 | unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; 61 | 62 | if ($] < 5.010) { 63 | $WriteMakefileArgs{PREREQ_PM} = { 64 | %{ $WriteMakefileArgs{PREREQ_PM} }, 65 | "MRO::Compat" => "0", 66 | }; 67 | } 68 | 69 | if ($] < 5.014) { 70 | $WriteMakefileArgs{PREREQ_PM} = { 71 | %{ $WriteMakefileArgs{PREREQ_PM} }, 72 | "Devel::GlobalDestruction" => "0", 73 | }; 74 | } 75 | 76 | WriteMakefile(%WriteMakefileArgs); 77 | -------------------------------------------------------------------------------- /README.mkdn: -------------------------------------------------------------------------------- 1 | CONTRIBUTING.mkdn -------------------------------------------------------------------------------- /dist.ini: -------------------------------------------------------------------------------- 1 | name = Class-Tiny 2 | author = David Golden 3 | license = Apache_2_0 4 | copyright_holder = David Golden 5 | copyright_year = 2013 6 | 7 | [@DAGOLDEN] 8 | :version = 0.072 9 | RewriteVersion.global = 1 10 | BumpVersionAfterRelease.global = 1 11 | stopwords = destructor 12 | stopwords = fatpacking 13 | stopwords = interoperability 14 | stopwords = linearized 15 | 16 | [ReleaseStatus::FromVersion] 17 | testing = third_decimal_odd 18 | 19 | [RemovePrereqs] 20 | remove = Devel::GlobalDestruction 21 | remove = MRO::Compat 22 | remove = Test::FailWarnings 23 | remove = mro 24 | 25 | [Prereqs / TestRecommends ] 26 | Test::FailWarnings = 0 27 | 28 | [PerlVersionPrereqs / 5.010] 29 | MRO::Compat = 0 30 | 31 | [PerlVersionPrereqs / 5.014] 32 | Devel::GlobalDestruction = 0 33 | 34 | [OnlyCorePrereqs] 35 | :version = 0.003 36 | starting_version = current 37 | -------------------------------------------------------------------------------- /lib/Class/Tiny.pm: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | no strict 'refs'; 4 | use warnings; 5 | 6 | package Class::Tiny; 7 | # ABSTRACT: Minimalist class construction 8 | 9 | our $VERSION = '1.009'; 10 | 11 | use Carp (); 12 | 13 | # load as .pm to hide from min version scanners 14 | require( $] >= 5.010 ? "mro.pm" : "MRO/Compat.pm" ); ## no critic: 15 | 16 | my %CLASS_ATTRIBUTES; 17 | 18 | sub import { 19 | my $class = shift; 20 | my $pkg = caller; 21 | $class->prepare_class($pkg); 22 | $class->create_attributes( $pkg, @_ ) if @_; 23 | } 24 | 25 | sub prepare_class { 26 | my ( $class, $pkg ) = @_; 27 | @{"${pkg}::ISA"} = "Class::Tiny::Object" unless @{"${pkg}::ISA"}; 28 | } 29 | 30 | # adapted from Object::Tiny and Object::Tiny::RW 31 | sub create_attributes { 32 | my ( $class, $pkg, @spec ) = @_; 33 | my %defaults = map { ref $_ eq 'HASH' ? %$_ : ( $_ => undef ) } @spec; 34 | my @attr = grep { 35 | defined and !ref and /^[^\W\d]\w*$/s 36 | or Carp::croak "Invalid accessor name '$_'" 37 | } keys %defaults; 38 | $CLASS_ATTRIBUTES{$pkg}{$_} = $defaults{$_} for @attr; 39 | $class->_gen_accessor( $pkg, $_ ) for grep { !*{"$pkg\::$_"}{CODE} } @attr; 40 | Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@; 41 | } 42 | 43 | sub _gen_accessor { 44 | my ( $class, $pkg, $name ) = @_; 45 | my $outer_default = $CLASS_ATTRIBUTES{$pkg}{$name}; 46 | 47 | my $sub = 48 | $class->__gen_sub_body( $name, defined($outer_default), ref($outer_default) ); 49 | 50 | # default = outer_default avoids "won't stay shared" bug 51 | eval "package $pkg; my \$default=\$outer_default; $sub"; ## no critic 52 | Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@; 53 | } 54 | 55 | # NOTE: overriding __gen_sub_body in a subclass of Class::Tiny is risky and 56 | # could break if the internals of Class::Tiny need to change for any 57 | # reason. That said, I currently see no reason why this would be likely to 58 | # change. 59 | # 60 | # The generated sub body should assume that a '$default' variable will be 61 | # in scope (i.e. when the sub is evaluated) with any default value/coderef 62 | sub __gen_sub_body { 63 | my ( $self, $name, $has_default, $default_type ) = @_; 64 | 65 | if ( $has_default && $default_type eq 'CODE' ) { 66 | return << "HERE"; 67 | sub $name { 68 | return ( 69 | ( \@_ == 1 && exists \$_[0]{$name} ) 70 | ? ( \$_[0]{$name} ) 71 | : ( \$_[0]{$name} = ( \@_ == 2 ) ? \$_[1] : \$default->( \$_[0] ) ) 72 | ); 73 | } 74 | HERE 75 | } 76 | elsif ($has_default) { 77 | return << "HERE"; 78 | sub $name { 79 | return ( 80 | ( \@_ == 1 && exists \$_[0]{$name} ) 81 | ? ( \$_[0]{$name} ) 82 | : ( \$_[0]{$name} = ( \@_ == 2 ) ? \$_[1] : \$default ) 83 | ); 84 | } 85 | HERE 86 | } 87 | else { 88 | return << "HERE"; 89 | sub $name { 90 | return \@_ == 1 ? \$_[0]{$name} : ( \$_[0]{$name} = \$_[1] ); 91 | } 92 | HERE 93 | } 94 | } 95 | 96 | sub get_all_attributes_for { 97 | my ( $class, $pkg ) = @_; 98 | my %attr = 99 | map { $_ => undef } 100 | map { keys %{ $CLASS_ATTRIBUTES{$_} || {} } } @{ mro::get_linear_isa($pkg) }; 101 | return keys %attr; 102 | } 103 | 104 | sub get_all_attribute_defaults_for { 105 | my ( $class, $pkg ) = @_; 106 | my $defaults = {}; 107 | for my $p ( reverse @{ mro::get_linear_isa($pkg) } ) { 108 | while ( my ( $k, $v ) = each %{ $CLASS_ATTRIBUTES{$p} || {} } ) { 109 | $defaults->{$k} = $v; 110 | } 111 | } 112 | return $defaults; 113 | } 114 | 115 | package Class::Tiny::Object; 116 | # ABSTRACT: Base class for classes built with Class::Tiny 117 | 118 | our $VERSION = '1.009'; 119 | 120 | my ( %HAS_BUILDARGS, %BUILD_CACHE, %DEMOLISH_CACHE, %ATTR_CACHE ); 121 | 122 | my $_PRECACHE = sub { 123 | no warnings 'once'; # needed to avoid downstream warnings 124 | my ($class) = @_; 125 | my $linear_isa = 126 | @{"$class\::ISA"} == 1 && ${"$class\::ISA"}[0] eq "Class::Tiny::Object" 127 | ? [$class] 128 | : mro::get_linear_isa($class); 129 | $DEMOLISH_CACHE{$class} = [ 130 | map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } 131 | map { "$_\::DEMOLISH" } @$linear_isa 132 | ]; 133 | $BUILD_CACHE{$class} = [ 134 | map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } 135 | map { "$_\::BUILD" } reverse @$linear_isa 136 | ]; 137 | $HAS_BUILDARGS{$class} = $class->can("BUILDARGS"); 138 | return $ATTR_CACHE{$class} = 139 | { map { $_ => 1 } Class::Tiny->get_all_attributes_for($class) }; 140 | }; 141 | 142 | sub new { 143 | my $class = shift; 144 | my $valid_attrs = $ATTR_CACHE{$class} || $_PRECACHE->($class); 145 | 146 | # handle hash ref or key/value arguments 147 | my $args; 148 | if ( $HAS_BUILDARGS{$class} ) { 149 | $args = $class->BUILDARGS(@_); 150 | } 151 | else { 152 | if ( @_ == 1 && ref $_[0] ) { 153 | my %copy = eval { %{ $_[0] } }; # try shallow copy 154 | Carp::croak("Argument to $class->new() could not be dereferenced as a hash") if $@; 155 | $args = \%copy; 156 | } 157 | elsif ( @_ % 2 == 0 ) { 158 | $args = {@_}; 159 | } 160 | else { 161 | Carp::croak("$class->new() got an odd number of elements"); 162 | } 163 | } 164 | 165 | # create object and invoke BUILD (unless we were given __no_BUILD__) 166 | my $self = 167 | bless { map { $_ => $args->{$_} } grep { exists $valid_attrs->{$_} } keys %$args }, 168 | $class; 169 | $self->BUILDALL($args) if !delete $args->{__no_BUILD__} && @{ $BUILD_CACHE{$class} }; 170 | 171 | return $self; 172 | } 173 | 174 | sub BUILDALL { $_->(@_) for @{ $BUILD_CACHE{ ref $_[0] } } } 175 | 176 | # Adapted from Moo and its dependencies 177 | require Devel::GlobalDestruction unless defined ${^GLOBAL_PHASE}; 178 | 179 | sub DESTROY { 180 | my $self = shift; 181 | my $class = ref $self; 182 | my $in_global_destruction = 183 | defined ${^GLOBAL_PHASE} 184 | ? ${^GLOBAL_PHASE} eq 'DESTRUCT' 185 | : Devel::GlobalDestruction::in_global_destruction(); 186 | for my $demolisher ( @{ $DEMOLISH_CACHE{$class} } ) { 187 | my $e = do { 188 | local ( $?, $@ ); 189 | eval { $demolisher->( $self, $in_global_destruction ) }; 190 | $@; 191 | }; 192 | no warnings 'misc'; # avoid (in cleanup) warnings 193 | die $e if $e; # rethrow 194 | } 195 | } 196 | 197 | 1; 198 | 199 | =for Pod::Coverage 200 | new get_all_attributes_for get_all_attribute_defaults_for 201 | prepare_class create_attributes 202 | 203 | =head1 SYNOPSIS 204 | 205 | In F: 206 | 207 | package Person; 208 | 209 | use Class::Tiny qw( name ); 210 | 211 | 1; 212 | 213 | In F: 214 | 215 | package Employee; 216 | use parent 'Person'; 217 | 218 | use Class::Tiny qw( ssn ), { 219 | timestamp => sub { time } # attribute with default 220 | }; 221 | 222 | 1; 223 | 224 | In F: 225 | 226 | use Employee; 227 | 228 | my $obj = Employee->new( name => "Larry", ssn => "111-22-3333" ); 229 | 230 | # unknown attributes are ignored 231 | my $obj = Employee->new( name => "Larry", OS => "Linux" ); 232 | # $obj->{OS} does not exist 233 | 234 | =head1 DESCRIPTION 235 | 236 | This module offers a minimalist class construction kit in around 120 lines of 237 | code. Here is a list of features: 238 | 239 | =for :list 240 | * defines attributes via import arguments 241 | * generates read-write accessors 242 | * supports lazy attribute defaults 243 | * supports custom accessors 244 | * superclass provides a standard C constructor 245 | * C takes a hash reference or list of key/value pairs 246 | * C supports providing C to customize constructor options 247 | * C calls C for each class from parent to child 248 | * superclass provides a C method 249 | * C calls C for each class from child to parent 250 | 251 | Multiple-inheritance is possible, with superclass order determined via 252 | L. 253 | 254 | It uses no non-core modules for any recent Perl. On Perls older than v5.10 it 255 | requires L. On Perls older than v5.14, it requires 256 | L. 257 | 258 | =head1 USAGE 259 | 260 | =head2 Defining attributes 261 | 262 | Define attributes as a list of import arguments: 263 | 264 | package Foo::Bar; 265 | 266 | use Class::Tiny qw( 267 | name 268 | id 269 | height 270 | weight 271 | ); 272 | 273 | For each attribute, a read-write accessor is created unless a subroutine of that 274 | name already exists: 275 | 276 | $obj->name; # getter 277 | $obj->name( "John Doe" ); # setter 278 | 279 | Attribute names must be valid subroutine identifiers or an exception will 280 | be thrown. 281 | 282 | You can specify lazy defaults by defining attributes with a hash reference. 283 | Keys define attribute names and values are constants or code references that 284 | will be evaluated when the attribute is first accessed if no value has been 285 | set. The object is passed as an argument to a code reference. 286 | 287 | package Foo::WithDefaults; 288 | 289 | use Class::Tiny qw/name id/, { 290 | title => 'Peon', 291 | skills => sub { [] }, 292 | hire_date => sub { $_[0]->_build_hire_date }, 293 | }; 294 | 295 | When subclassing, if multiple accessors of the same name exist in different 296 | classes, any default (or lack of default) is determined by standard 297 | method resolution order. 298 | 299 | To make your own custom accessors, just pre-declare the method name before 300 | loading Class::Tiny: 301 | 302 | package Foo::Bar; 303 | 304 | use subs 'id'; 305 | 306 | use Class::Tiny qw( name id ); 307 | 308 | sub id { ... } 309 | 310 | Even if you pre-declare a method name, you must include it in the attribute 311 | list for Class::Tiny to register it as a valid attribute. 312 | 313 | If you set a default for a custom accessor, your accessor will need to retrieve 314 | the default and do something with it: 315 | 316 | package Foo::Bar; 317 | 318 | use subs 'id'; 319 | 320 | use Class::Tiny qw( name ), { id => sub { int(rand(2*31)) } }; 321 | 322 | sub id { 323 | my $self = shift; 324 | if (@_) { 325 | return $self->{id} = shift; 326 | } 327 | elsif ( exists $self->{id} ) { 328 | return $self->{id}; 329 | } 330 | else { 331 | my $defaults = 332 | Class::Tiny->get_all_attribute_defaults_for( ref $self ); 333 | return $self->{id} = $defaults->{id}->(); 334 | } 335 | } 336 | 337 | =head2 Class::Tiny::Object is your base class 338 | 339 | If your class B already inherit from some class, then 340 | Class::Tiny::Object will be added to your C<@ISA> to provide C and 341 | C. 342 | 343 | If your class B inherit from something, then no additional inheritance is 344 | set up. If the parent subclasses Class::Tiny::Object, then all is well. If 345 | not, then you'll get accessors set up but no constructor or destructor. Don't 346 | do that unless you really have a special need for it. 347 | 348 | Define subclasses as normal. It's best to define them with L, L 349 | or L before defining attributes with Class::Tiny so the C<@ISA> 350 | array is already populated at compile-time: 351 | 352 | package Foo::Bar::More; 353 | 354 | use parent 'Foo::Bar'; 355 | 356 | use Class::Tiny qw( shoe_size ); 357 | 358 | =head2 Object construction 359 | 360 | If your class inherits from Class::Tiny::Object (as it should if you followed 361 | the advice above), it provides the C constructor for you. 362 | 363 | Objects can be created with attributes given as a hash reference or as a list 364 | of key/value pairs: 365 | 366 | $obj = Foo::Bar->new( name => "David" ); 367 | 368 | $obj = Foo::Bar->new( { name => "David" } ); 369 | 370 | If a reference is passed as a single argument, it must be able to be 371 | dereferenced as a hash or an exception is thrown. 372 | 373 | Unknown attributes in the constructor arguments will be ignored. Prior to 374 | version 1.000, unknown attributes were an error, but this made it harder for 375 | people to cleanly subclass Class::Tiny classes so this feature was removed. 376 | 377 | You can define a C method to change how arguments to new are 378 | handled. It will receive the constructor arguments as they were provided and 379 | must return a hash reference of key/value pairs (or else throw an 380 | exception). 381 | 382 | sub BUILDARGS { 383 | my $class = shift; 384 | my $name = shift || "John Doe"; 385 | return { name => $name }; 386 | }; 387 | 388 | Foo::Bar->new( "David" ); 389 | Foo::Bar->new(); # "John Doe" 390 | 391 | Unknown attributes returned from C will be ignored. 392 | 393 | =head2 BUILD 394 | 395 | If your class or any superclass defines a C method, it will be called 396 | by the constructor from the furthest parent class down to the child class after 397 | the object has been created. 398 | 399 | It is passed the constructor arguments as a hash reference. The return value 400 | is ignored. Use C for validation, checking required attributes or 401 | setting default values that depend on other attributes. 402 | 403 | sub BUILD { 404 | my ($self, $args) = @_; 405 | 406 | for my $req ( qw/name age/ ) { 407 | croak "$req attribute required" unless defined $self->$req; 408 | } 409 | 410 | croak "Age must be non-negative" if $self->age < 0; 411 | 412 | $self->msg( "Hello " . $self->name ); 413 | } 414 | 415 | The argument reference is a copy, so deleting elements won't affect data in the 416 | original (but changes will be passed to other BUILD methods in C<@ISA>). 417 | 418 | =head2 DEMOLISH 419 | 420 | Class::Tiny provides a C method. If your class or any superclass 421 | defines a C method, they will be called from the child class to the 422 | furthest parent class during object destruction. It is provided a single 423 | boolean argument indicating whether Perl is in global destruction. Return 424 | values are ignored. Errors are caught and rethrown. 425 | 426 | sub DEMOLISH { 427 | my ($self, $global_destruct) = @_; 428 | $self->cleanup(); 429 | } 430 | 431 | =head2 Introspection and internals 432 | 433 | You can retrieve an unsorted list of valid attributes known to Class::Tiny 434 | for a class and its superclasses with the C class 435 | method. 436 | 437 | my @attrs = Class::Tiny->get_all_attributes_for("Employee"); 438 | # returns qw/name ssn timestamp/ 439 | 440 | Likewise, a hash reference of all valid attributes and default values (or code 441 | references) may be retrieved with the C class 442 | method. Any attributes without a default will be C. 443 | 444 | my $def = Class::Tiny->get_all_attribute_defaults_for("Employee"); 445 | # returns { 446 | # name => undef, 447 | # ssn => undef 448 | # timestamp => $coderef 449 | # } 450 | 451 | The C method uses two class methods, C and 452 | C to set up the C<@ISA> array and attributes. Anyone 453 | attempting to extend Class::Tiny itself should use these instead of mocking up 454 | a call to C. 455 | 456 | When the first object is created, linearized C<@ISA>, the valid attribute list 457 | and various subroutine references are cached for speed. Ensure that all 458 | inheritance and methods are in place before creating objects. (You don't want 459 | to be changing that once you create objects anyway, right?) 460 | 461 | =head1 RATIONALE 462 | 463 | =head2 Why this instead of Object::Tiny or Class::Accessor or something else? 464 | 465 | I wanted something so simple that it could potentially be used by core Perl 466 | modules I help maintain (or hope to write), most of which either use 467 | L or roll-their-own OO framework each time. 468 | 469 | L and L were close to what I wanted, but 470 | lacking some features I deemed necessary, and their maintainers have an even 471 | more strict philosophy against feature creep than I have. 472 | 473 | I also considered L, which has been around a long time and is 474 | heavily used, but it, too, lacked features I wanted and did things in ways I 475 | considered poor design. 476 | 477 | I looked for something else on CPAN, but after checking a dozen class creators 478 | I realized I could implement exactly what I wanted faster than I could search 479 | CPAN for something merely sufficient. 480 | 481 | In general, compared to most things on CPAN (other than Object::Tiny), 482 | Class::Tiny is smaller in implementation and simpler in API. 483 | 484 | Specifically, here is how Class::Tiny ("C::T") compares to Object::Tiny 485 | ("O::T") and Class::Accessor ("C::A"): 486 | 487 | FEATURE C::T O::T C::A 488 | -------------------------------------------------------------- 489 | attributes defined via import yes yes no 490 | read/write accessors yes no yes 491 | lazy attribute defaults yes no no 492 | provides new yes yes yes 493 | provides DESTROY yes no no 494 | new takes either hashref or list yes no (list) no (hash) 495 | Moo(se)-like BUILD/DEMOLISH yes no no 496 | Moo(se)-like BUILDARGS yes no no 497 | no extraneous methods via @ISA yes yes no 498 | 499 | =head2 Why this instead of Moose or Moo? 500 | 501 | L and L are both excellent OO frameworks. Moose offers a powerful 502 | meta-object protocol (MOP), but is slow to start up and has about 30 non-core 503 | dependencies including XS modules. Moo is faster to start up and has about 10 504 | pure Perl dependencies but provides no true MOP, relying instead on its ability 505 | to transparently upgrade Moo to Moose when Moose's full feature set is 506 | required. 507 | 508 | By contrast, Class::Tiny has no MOP and has B non-core dependencies for 509 | Perls in the L. It has far less code, less 510 | complexity and no learning curve. If you don't need or can't afford what Moo or 511 | Moose offer, this is intended to be a reasonable fallback. 512 | 513 | That said, Class::Tiny offers Moose-like conventions for things like C 514 | and C for some minimal interoperability and an easier upgrade path. 515 | 516 | =cut 517 | 518 | # vim: ts=4 sts=4 sw=4 et: 519 | -------------------------------------------------------------------------------- /perlcritic.rc: -------------------------------------------------------------------------------- 1 | severity = 5 2 | verbose = 8 3 | 4 | [Variables::ProhibitPunctuationVars] 5 | allow = $@ $! 6 | 7 | [TestingAndDebugging::ProhibitNoStrict] 8 | allow = refs 9 | 10 | # Turn these off 11 | [-BuiltinFunctions::ProhibitStringyEval] 12 | [-ControlStructures::ProhibitPostfixControls] 13 | [-ControlStructures::ProhibitUnlessBlocks] 14 | [-Documentation::RequirePodSections] 15 | [-InputOutput::ProhibitInteractiveTest] 16 | [-References::ProhibitDoubleSigils] 17 | [-RegularExpressions::RequireExtendedFormatting] 18 | [-InputOutput::ProhibitTwoArgOpen] 19 | [-Modules::ProhibitEvilModules] 20 | 21 | # Turn this on 22 | [Lax::ProhibitStringyEval::ExceptForRequire] 23 | 24 | -------------------------------------------------------------------------------- /t/alfa.t: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | use lib 't/lib'; 5 | 6 | use Test::More 0.96; 7 | use TestUtils; 8 | 9 | require_ok("Alfa"); 10 | 11 | subtest "empty list constructor" => sub { 12 | my $obj = new_ok("Alfa"); 13 | is( $obj->foo, undef, "foo is undef" ); 14 | is( $obj->bar, undef, "bar is undef" ); 15 | }; 16 | 17 | subtest "empty hash object constructor" => sub { 18 | my $obj = new_ok( "Alfa", [ {} ] ); 19 | is( $obj->foo, undef, "foo is undef" ); 20 | is( $obj->bar, undef, "bar is undef" ); 21 | }; 22 | 23 | subtest "one attribute set as list" => sub { 24 | my $obj = new_ok( "Alfa", [ foo => 23 ] ); 25 | is( $obj->foo, 23, "foo is set" ); 26 | is( $obj->bar, undef, "bar is undef" ); 27 | }; 28 | 29 | subtest "one attribute set as hash ref" => sub { 30 | my $obj = new_ok( "Alfa", [ { foo => 23 } ] ); 31 | is( $obj->foo, 23, "foo is set" ); 32 | is( $obj->bar, undef, "bar is undef" ); 33 | }; 34 | 35 | subtest "both attributes set as list" => sub { 36 | my $obj = new_ok( "Alfa", [ foo => 23, bar => 42 ] ); 37 | is( $obj->foo, 23, "foo is set" ); 38 | is( $obj->bar, 42, "bar is set" ); 39 | }; 40 | 41 | subtest "both attributes set as hash ref" => sub { 42 | my $obj = new_ok( "Alfa", [ { foo => 23, bar => 42 } ] ); 43 | is( $obj->foo, 23, "foo is set" ); 44 | is( $obj->bar, 42, "bar is set" ); 45 | }; 46 | 47 | subtest "constructor makes shallow copy" => sub { 48 | my $fake = bless { foo => 23, bar => 42 }, "Fake"; 49 | my $obj = new_ok( "Alfa", [$fake] ); 50 | is( ref $fake, "Fake", "object passed to constructor is original class" ); 51 | is( $obj->foo, 23, "foo is set" ); 52 | is( $obj->bar, 42, "bar is set" ); 53 | }; 54 | 55 | subtest "attributes are RW" => sub { 56 | my $obj = new_ok( "Alfa", [ { foo => 23, bar => 42 } ] ); 57 | is( $obj->foo(24), 24, "changing foo returns new value" ); 58 | is( $obj->foo, 24, "accessing foo returns changed value" ); 59 | }; 60 | 61 | subtest "unknown attributes stripped" => sub { 62 | my $obj = new_ok( "Alfa", [ { wibble => 1 } ], "new( wibble => 1 )" ); 63 | ok( !exists $obj->{wibble}, "unknown attribute 'wibble' not in object" ); 64 | }; 65 | 66 | subtest "exceptions" => sub { 67 | like( 68 | exception { Alfa->new(qw/ foo bar baz/) }, 69 | qr/Alfa->new\(\) got an odd number of elements/, 70 | "creating object with odd elements dies", 71 | ); 72 | 73 | like( 74 | exception { Alfa->new( [] ) }, 75 | qr/Argument to Alfa->new\(\) could not be dereferenced as a hash/, 76 | "creating object with array ref dies", 77 | ); 78 | }; 79 | 80 | done_testing; 81 | # COPYRIGHT 82 | # vim: ts=4 sts=4 sw=4 et: 83 | -------------------------------------------------------------------------------- /t/baker.t: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | use lib 't/lib'; 5 | 6 | use Test::More 0.96; 7 | use TestUtils; 8 | 9 | require_ok("Baker"); 10 | 11 | subtest "attribute list" => sub { 12 | is_deeply( 13 | [ sort Class::Tiny->get_all_attributes_for("Baker") ], 14 | [ sort qw/foo bar baz/ ], 15 | "attribute list correct", 16 | ); 17 | }; 18 | 19 | subtest "empty list constructor" => sub { 20 | my $obj = new_ok("Baker"); 21 | is( $obj->foo, undef, "foo is undef" ); 22 | is( $obj->bar, undef, "bar is undef" ); 23 | is( $obj->baz, undef, "baz is undef" ); 24 | }; 25 | 26 | subtest "empty hash object constructor" => sub { 27 | my $obj = new_ok( "Baker", [ {} ] ); 28 | is( $obj->foo, undef, "foo is undef" ); 29 | is( $obj->bar, undef, "bar is undef" ); 30 | is( $obj->baz, undef, "baz is undef" ); 31 | }; 32 | 33 | subtest "subclass attribute set as list" => sub { 34 | my $obj = new_ok( "Baker", [ baz => 23 ] ); 35 | is( $obj->foo, undef, "foo is undef" ); 36 | is( $obj->bar, undef, "bar is undef" ); 37 | is( $obj->baz, 23, "baz is set " ); 38 | }; 39 | 40 | subtest "superclass attribute set as list" => sub { 41 | my $obj = new_ok( "Baker", [ bar => 42, baz => 23 ] ); 42 | is( $obj->foo, undef, "foo is undef" ); 43 | is( $obj->bar, 42, "bar is set" ); 44 | is( $obj->baz, 23, "baz is set " ); 45 | }; 46 | 47 | subtest "all attributes set as list" => sub { 48 | my $obj = new_ok( "Baker", [ foo => 13, bar => 42, baz => 23 ] ); 49 | is( $obj->foo, 13, "foo is set" ); 50 | is( $obj->bar, 42, "bar is set" ); 51 | is( $obj->baz, 23, "baz is set " ); 52 | }; 53 | 54 | subtest "attributes are RW" => sub { 55 | my $obj = new_ok( "Baker", [ { foo => 23, bar => 42 } ] ); 56 | is( $obj->foo(24), 24, "changing foo returns new value" ); 57 | is( $obj->foo, 24, "accessing foo returns changed value" ); 58 | is( $obj->baz(42), 42, "changing baz returns new value" ); 59 | is( $obj->baz, 42, "accessing baz returns changed value" ); 60 | }; 61 | 62 | done_testing; 63 | # COPYRIGHT 64 | # vim: ts=4 sts=4 sw=4 et: 65 | -------------------------------------------------------------------------------- /t/charlie.t: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | use lib 't/lib'; 5 | 6 | use Test::More 0.96; 7 | use TestUtils; 8 | 9 | require_ok("Charlie"); 10 | 11 | subtest "all attributes set as list" => sub { 12 | my $obj = new_ok( "Charlie", [ foo => 13, bar => [42] ] ); 13 | is( $obj->foo, 13, "foo is set" ); 14 | is_deeply( $obj->bar, [42], "bar is set" ); 15 | }; 16 | 17 | subtest "custom accessor" => sub { 18 | my $obj = new_ok( "Charlie", [ foo => 13, bar => [42] ] ); 19 | is_deeply( $obj->bar(qw/1 1 2 3 5/), [qw/1 1 2 3 5/], "bar is set" ); 20 | }; 21 | 22 | subtest "custom accessor with default" => sub { 23 | my $obj = new_ok( "Charlie", [ foo => 13, bar => [42] ] ); 24 | is( $obj->baz, 23, "custom accessor has default" ); 25 | }; 26 | 27 | done_testing; 28 | # COPYRIGHT 29 | # vim: ts=4 sts=4 sw=4 et: 30 | -------------------------------------------------------------------------------- /t/delta.t: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | use lib 't/lib'; 5 | 6 | use Test::More 0.96; 7 | use TestUtils; 8 | 9 | require_ok("Delta"); 10 | 11 | subtest "attribute set as list" => sub { 12 | my $obj = new_ok( "Delta", [ foo => 42, bar => 23 ] ); 13 | is( $obj->foo, 42, "foo is set" ); 14 | is( $obj->bar, 23, "bar is set" ); 15 | }; 16 | 17 | subtest "__no_BUILD__" => sub { 18 | my $obj = new_ok( "Delta", [ __no_BUILD__ => 1 ], "new( __no_BUILD__ => 1 )" ); 19 | is( $Delta::counter, 0, "BUILD method didn't run" ); 20 | }; 21 | 22 | subtest "destructor" => sub { 23 | my @objs = map { new_ok( "Delta", [ foo => 42, bar => 23 ] ) } 1 .. 3; 24 | is( $Delta::counter, 3, "BUILD incremented counter" ); 25 | @objs = (); 26 | is( $Delta::counter, 0, "DEMOLISH decremented counter" ); 27 | }; 28 | 29 | subtest "exceptions" => sub { 30 | like( 31 | exception { Delta->new( foo => 0 ) }, 32 | qr/foo must be positive/, 33 | "BUILD validation throws error", 34 | ); 35 | 36 | }; 37 | 38 | done_testing; 39 | # COPYRIGHT 40 | # vim: ts=4 sts=4 sw=4 et: 41 | -------------------------------------------------------------------------------- /t/echo.t: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | use lib 't/lib'; 5 | 6 | use Test::More 0.96; 7 | use TestUtils; 8 | 9 | require_ok("Echo"); 10 | 11 | subtest "attribute set as list" => sub { 12 | my $obj = new_ok( "Echo", [ foo => 42, bar => 23 ] ); 13 | is( $obj->foo, 42, "foo is set" ); 14 | is( $obj->bar, 23, "bar is set" ); 15 | is( $obj->baz, 24, "baz is set" ); 16 | }; 17 | 18 | subtest "destructor" => sub { 19 | no warnings 'once'; 20 | my @objs = map { new_ok( "Echo", [ foo => 42, bar => 23 ] ) } 1 .. 3; 21 | is( $Delta::counter, 3, "BUILD incremented counter" ); 22 | @objs = (); 23 | is( $Delta::counter, 0, "DEMOLISH decremented counter" ); 24 | is( $Delta::exception, 0, "cleanup worked in correct order" ); 25 | }; 26 | 27 | subtest "exceptions" => sub { 28 | like( 29 | exception { Echo->new( foo => 0, bar => 23 ) }, 30 | qr/foo must be positive/, 31 | "BUILD validation throws error", 32 | ); 33 | 34 | }; 35 | 36 | done_testing; 37 | # COPYRIGHT 38 | # vim: ts=4 sts=4 sw=4 et: 39 | -------------------------------------------------------------------------------- /t/foxtrot.t: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | use lib 't/lib'; 5 | 6 | use Test::More 0.96; 7 | use TestUtils; 8 | 9 | require_ok("Foxtrot"); 10 | 11 | subtest "attribute list" => sub { 12 | is_deeply( 13 | [ sort Class::Tiny->get_all_attributes_for("Foxtrot") ], 14 | [ sort qw/foo bar baz/ ], 15 | "attribute list correct", 16 | ); 17 | }; 18 | 19 | subtest "attribute defaults" => sub { 20 | my $def = Class::Tiny->get_all_attribute_defaults_for("Foxtrot"); 21 | is( keys %$def, 3, "defaults hashref size" ); 22 | is( $def->{foo}, undef, "foo default is undef" ); 23 | is( $def->{bar}, 42, "bar default is 42" ); 24 | is( ref $def->{baz}, 'CODE', "baz default is a coderef" ); 25 | }; 26 | 27 | subtest "attribute set as list" => sub { 28 | my $obj = new_ok( "Foxtrot", [ foo => 42, bar => 23 ] ); 29 | is( $obj->foo, 42, "foo is set" ); 30 | is( $obj->bar, 23, "bar is set" ); 31 | ok( $obj->baz, "baz is set" ); 32 | }; 33 | 34 | done_testing; 35 | # COPYRIGHT 36 | # vim: ts=4 sts=4 sw=4 et: 37 | -------------------------------------------------------------------------------- /t/golf.t: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | use lib 't/lib'; 5 | 6 | use Test::More 0.96; 7 | use TestUtils; 8 | 9 | require_ok("Golf"); 10 | 11 | subtest "lazy defaults" => sub { 12 | my $obj = new_ok("Golf"); 13 | is( $obj->foo, undef, "foo is undef" ); 14 | is( $obj->bar, undef, "bar is undef" ); 15 | ok( !exists( $obj->{wibble} ), "lazy wibble doesn't exist" ); 16 | ok( !exists( $obj->{wobble} ), "lazy wobble doesn't exist" ); 17 | is( $obj->wibble, 42, "wibble access gives default" ); 18 | is( ref $obj->wobble, 'ARRAY', "wobble access gives default" ); 19 | ok( exists( $obj->{wibble} ), "lazy wibble does exist" ); 20 | ok( exists( $obj->{wobble} ), "lazy wobble does exist" ); 21 | my $obj2 = new_ok("Golf"); 22 | isnt( $obj->wobble, $obj2->wobble, "coderefs run for each object" ); 23 | }; 24 | 25 | done_testing; 26 | # COPYRIGHT 27 | # vim: ts=4 sts=4 sw=4 et: 28 | -------------------------------------------------------------------------------- /t/hotel.t: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | use lib 't/lib'; 5 | 6 | use Test::More 0.96; 7 | use TestUtils; 8 | 9 | require_ok("Hotel"); 10 | 11 | subtest "attribute list" => sub { 12 | my $attributes = [ sort Class::Tiny->get_all_attributes_for("Hotel") ]; 13 | is_deeply( 14 | $attributes, 15 | [ sort qw/foo bar wibble wobble zig zag/ ], 16 | "attribute list correct", 17 | ) or diag explain $attributes; 18 | }; 19 | 20 | subtest "attribute defaults" => sub { 21 | my $def = Class::Tiny->get_all_attribute_defaults_for("Hotel"); 22 | is( keys %$def, 6, "defaults hashref size" ); 23 | is( $def->{foo}, undef, "foo default is undef" ); 24 | is( $def->{bar}, undef, "bar default is undef" ); 25 | is( $def->{wibble}, 23, "wibble default overrides" ); 26 | }; 27 | 28 | subtest "attribute set as list" => sub { 29 | my $obj = new_ok( "Hotel", [ foo => 42, bar => 23 ] ); 30 | is( $obj->foo, 42, "foo is set" ); 31 | is( $obj->bar, 23, "bar is set" ); 32 | is( $obj->wibble, 23, "wibble is set" ); 33 | is( ref $obj->wobble, 'HASH', "wobble default overrides" ); 34 | }; 35 | 36 | done_testing; 37 | # COPYRIGHT 38 | # vim: ts=4 sts=4 sw=4 et: 39 | -------------------------------------------------------------------------------- /t/juliett.t: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | use lib 't/lib'; 5 | 6 | use Test::More 0.96; 7 | use TestUtils; 8 | 9 | require_ok("Juliett"); 10 | 11 | subtest "attribute list" => sub { 12 | is_deeply( 13 | [ sort Class::Tiny->get_all_attributes_for("Juliett") ], 14 | [ sort qw/foo bar baz qux kit/ ], 15 | "attribute list correct", 16 | ); 17 | }; 18 | 19 | subtest "empty list constructor" => sub { 20 | my $obj = new_ok("Juliett"); 21 | is( $obj->foo, undef, "foo is undef" ); 22 | is( $obj->bar, undef, "bar is undef" ); 23 | is( $obj->baz, undef, "baz is undef" ); 24 | is( $obj->qux, undef, "qux is undef" ); 25 | is( $obj->kit, undef, "kit is undef" ); 26 | }; 27 | 28 | subtest "empty hash object constructor" => sub { 29 | my $obj = new_ok( "Juliett", [ {} ] ); 30 | is( $obj->foo, undef, "foo is undef" ); 31 | is( $obj->bar, undef, "bar is undef" ); 32 | is( $obj->baz, undef, "baz is undef" ); 33 | is( $obj->qux, undef, "qux is undef" ); 34 | is( $obj->kit, undef, "kit is undef" ); 35 | }; 36 | 37 | subtest "subclass attribute set as list" => sub { 38 | my $obj = new_ok( "Juliett", [ kit => 23 ] ); 39 | is( $obj->foo, undef, "foo is undef" ); 40 | is( $obj->bar, undef, "bar is undef" ); 41 | is( $obj->qux, undef, "baz is undef" ); 42 | is( $obj->qux, undef, "qux is undef" ); 43 | is( $obj->kit, 23, "kit is set" ); 44 | }; 45 | 46 | subtest "superclass attribute set as list" => sub { 47 | my $obj = new_ok( "Juliett", [ bar => 42, baz => 23, qux => 13, kit => 31 ] ); 48 | is( $obj->foo, undef, "foo is undef" ); 49 | is( $obj->bar, 42, "bar is set" ); 50 | is( $obj->baz, 23, "baz is set" ); 51 | is( $obj->qux, 13, "qux is set" ); 52 | is( $obj->kit, 31, "kit is set" ); 53 | }; 54 | 55 | subtest "all attributes set as list" => sub { 56 | my $obj = 57 | new_ok( "Juliett", [ foo => 13, bar => 42, baz => 23, qux => 11, kit => 31 ] ); 58 | is( $obj->foo, 13, "foo is set" ); 59 | is( $obj->bar, 42, "bar is set" ); 60 | is( $obj->baz, 23, "baz is set" ); 61 | is( $obj->qux, 11, "qux is set" ); 62 | is( $obj->kit, 31, "kit is set" ); 63 | }; 64 | 65 | subtest "attributes are RW" => sub { 66 | my $obj = new_ok( "Juliett", [ { foo => 23, bar => 42 } ] ); 67 | is( $obj->foo(24), 24, "changing foo returns new value" ); 68 | is( $obj->foo, 24, "accessing foo returns changed value" ); 69 | is( $obj->baz(42), 42, "changing baz returns new value" ); 70 | is( $obj->baz, 42, "accessing baz returns changed value" ); 71 | is( $obj->qux(11), 11, "changing qux returns new value" ); 72 | is( $obj->qux, 11, "accessing qux returns changed value" ); 73 | is( $obj->kit(31), 31, "changing kit returns new value" ); 74 | is( $obj->kit, 31, "accessing kit rerutns changed value" ); 75 | }; 76 | 77 | done_testing; 78 | # COPYRIGHT 79 | # vim: ts=4 sts=4 sw=4 et: 80 | -------------------------------------------------------------------------------- /t/lib/Alfa.pm: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | 5 | package Alfa; 6 | 7 | use Class::Tiny qw/foo bar/; 8 | 9 | 1; 10 | -------------------------------------------------------------------------------- /t/lib/Baker.pm: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | 5 | package Baker; 6 | use base 'Alfa'; 7 | 8 | use Class::Tiny qw/baz/; 9 | 10 | 1; 11 | -------------------------------------------------------------------------------- /t/lib/Charlie.pm: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | 5 | package Charlie; 6 | 7 | use subs qw/bar baz/; 8 | 9 | use Class::Tiny qw/foo bar/, { baz => 23 }; 10 | 11 | sub bar { 12 | my $self = shift; 13 | if (@_) { 14 | $self->{bar} = [@_]; 15 | } 16 | return $self->{bar}; 17 | } 18 | 19 | sub baz { 20 | my $self = shift; 21 | if (@_) { 22 | $self->{baz} = shift; 23 | } 24 | return $self->{baz} ||= 25 | Class::Tiny->get_all_attribute_defaults_for( ref $self )->{baz}; 26 | } 27 | 28 | 1; 29 | -------------------------------------------------------------------------------- /t/lib/Delta.pm: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | 5 | package Delta; 6 | 7 | our $counter = 0; 8 | our $exception = 0; 9 | 10 | use Carp (); 11 | 12 | use Class::Tiny qw/foo bar/; 13 | 14 | sub BUILD { 15 | my $self = shift; 16 | my $args = shift; 17 | Carp::croak("foo must be positive") 18 | unless defined $self->foo && $self->foo > 0; 19 | 20 | $self->bar(42) unless defined $self->bar; 21 | $counter++; 22 | } 23 | 24 | sub DEMOLISH { 25 | my $self = shift; 26 | $counter-- if $counter > 0; 27 | $exception++ if keys %$self > 2; # Echo will delete first 28 | } 29 | 30 | 1; 31 | -------------------------------------------------------------------------------- /t/lib/Echo.pm: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | 5 | package Echo; 6 | use base 'Delta'; 7 | 8 | use Class::Tiny qw/baz/; 9 | 10 | sub BUILD { 11 | my $self = shift; 12 | $self->baz( $self->bar + 1 ); 13 | } 14 | 15 | sub DEMOLISH { 16 | my $self = shift; 17 | delete $self->{baz}; # or else Delta::DEMOLISH dies 18 | } 19 | 20 | sub a_method { 1 } 21 | 22 | 1; 23 | -------------------------------------------------------------------------------- /t/lib/Foxtrot.pm: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | 5 | package Foxtrot; 6 | 7 | use Class::Tiny 'foo'; 8 | use Class::Tiny { bar => 42, baz => sub { time } }; 9 | 10 | 1; 11 | -------------------------------------------------------------------------------- /t/lib/Golf.pm: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | 5 | package Golf; 6 | 7 | use Class::Tiny qw/foo bar/, { 8 | wibble => 42, 9 | wobble => sub { [] }, 10 | }, qw/zig zag/; 11 | 12 | 1; 13 | -------------------------------------------------------------------------------- /t/lib/Hotel.pm: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | 5 | package Hotel; 6 | 7 | use base 'Golf'; 8 | 9 | use Class::Tiny { 10 | wibble => 23, 11 | wobble => sub { {} }, 12 | }; 13 | 14 | 1; 15 | -------------------------------------------------------------------------------- /t/lib/India.pm: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | 5 | package India; 6 | use base 'Alfa'; 7 | 8 | use Class::Tiny qw/qux/; 9 | 10 | 1; 11 | -------------------------------------------------------------------------------- /t/lib/Juliett.pm: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | 5 | package Juliett; 6 | use base 'Baker', 'India'; 7 | 8 | use Class::Tiny qw/kit/; 9 | 10 | 1; 11 | -------------------------------------------------------------------------------- /t/lib/TestUtils.pm: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings; 4 | package TestUtils; 5 | 6 | use Carp; 7 | 8 | use Exporter; 9 | our @ISA = qw/Exporter/; 10 | our @EXPORT = qw( 11 | exception 12 | ); 13 | 14 | # If we have Test::FailWarnings, use it 15 | BEGIN { 16 | eval { require Test::FailWarnings; 1 } and do { Test::FailWarnings->import }; 17 | } 18 | 19 | sub exception(&) { 20 | my $code = shift; 21 | my $success = eval { $code->(); 1 }; 22 | my $err = $@; 23 | return '' if $success; 24 | croak "Execution died, but the error was lost" unless $@; 25 | return $@; 26 | } 27 | 28 | 1; 29 | -------------------------------------------------------------------------------- /tidyall.ini: -------------------------------------------------------------------------------- 1 | ; Install Code::TidyAll 2 | ; run "tidyall -a" to tidy all files 3 | ; run "tidyall -g" to tidy only files modified from git 4 | [PerlTidy] 5 | select = {lib,t}/**/*.{pl,pm,t} 6 | --------------------------------------------------------------------------------