From 7446bb2b9d24fa6b702fbb62d73084a32ade6f75 Mon Sep 17 00:00:00 2001 From: Lorry Tar Creator Date: Sat, 31 Jan 2015 02:13:12 +0000 Subject: Class-Tiny-1.001 --- lib/Class/Tiny.pm | 592 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 592 insertions(+) create mode 100644 lib/Class/Tiny.pm (limited to 'lib') diff --git a/lib/Class/Tiny.pm b/lib/Class/Tiny.pm new file mode 100644 index 0000000..6056f9b --- /dev/null +++ b/lib/Class/Tiny.pm @@ -0,0 +1,592 @@ +use 5.006; +use strict; +no strict 'refs'; +use warnings; + +package Class::Tiny; +# ABSTRACT: Minimalist class construction + +our $VERSION = '1.001'; + +use Carp (); + +# load as .pm to hide from min version scanners +require( $] >= 5.010 ? "mro.pm" : "MRO/Compat.pm" ); ## no critic: + +my %CLASS_ATTRIBUTES; + +sub import { + my $class = shift; + my $pkg = caller; + $class->prepare_class($pkg); + $class->create_attributes( $pkg, @_ ) if @_; +} + +sub prepare_class { + my ( $class, $pkg ) = @_; + @{"${pkg}::ISA"} = "Class::Tiny::Object" unless @{"${pkg}::ISA"}; +} + +# adapted from Object::Tiny and Object::Tiny::RW +sub create_attributes { + my ( $class, $pkg, @spec ) = @_; + my %defaults = map { ref $_ eq 'HASH' ? %$_ : ( $_ => undef ) } @spec; + my @attr = grep { + defined and !ref and /^[^\W\d]\w*$/s + or Carp::croak "Invalid accessor name '$_'" + } keys %defaults; + $CLASS_ATTRIBUTES{$pkg}{$_} = $defaults{$_} for @attr; + _gen_accessor( $pkg, $_ ) for grep { !*{"$pkg\::$_"}{CODE} } @attr; + Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@; +} + +sub _gen_accessor { + my ( $pkg, $name ) = @_; + my $outer_default = $CLASS_ATTRIBUTES{$pkg}{$name}; + + my $sub = "sub $name { if (\@_ == 1) {"; + if ( defined $outer_default && ref $outer_default eq 'CODE' ) { + $sub .= "if ( !exists \$_[0]{$name} ) { \$_[0]{$name} = \$default->(\$_[0]) }"; + } + elsif ( defined $outer_default ) { + $sub .= "if ( !exists \$_[0]{$name} ) { \$_[0]{$name} = \$default }"; + } + $sub .= "return \$_[0]{$name} } else { return \$_[0]{$name}=\$_[1] } }"; + + # default = outer_default avoids "won't stay shared" bug + eval "package $pkg; my \$default=\$outer_default; $sub"; ## no critic + Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@; +} + +sub get_all_attributes_for { + my ( $class, $pkg ) = @_; + my %attr = + map { $_ => undef } + map { keys %{ $CLASS_ATTRIBUTES{$_} || {} } } @{ mro::get_linear_isa($pkg) }; + return keys %attr; +} + +sub get_all_attribute_defaults_for { + my ( $class, $pkg ) = @_; + my $defaults = {}; + for my $p ( reverse @{ mro::get_linear_isa($pkg) } ) { + while ( my ( $k, $v ) = each %{ $CLASS_ATTRIBUTES{$p} || {} } ) { + $defaults->{$k} = $v; + } + } + return $defaults; +} + +package Class::Tiny::Object; +# ABSTRACT: Base class for classes built with Class::Tiny + +our $VERSION = '1.001'; + +my ( %HAS_BUILDARGS, %BUILD_CACHE, %DEMOLISH_CACHE, %ATTR_CACHE ); + +my $_PRECACHE = sub { + no warnings 'once'; # needed to avoid downstream warnings + my ($class) = @_; + my $linear_isa = + @{"$class\::ISA"} == 1 && ${"$class\::ISA"}[0] eq "Class::Tiny::Object" + ? [$class] + : mro::get_linear_isa($class); + $DEMOLISH_CACHE{$class} = [ + map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } + map { "$_\::DEMOLISH" } @$linear_isa + ]; + $BUILD_CACHE{$class} = [ + map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } + map { "$_\::BUILD" } reverse @$linear_isa + ]; + $HAS_BUILDARGS{$class} = $class->can("BUILDARGS"); + return $ATTR_CACHE{$class} = + { map { $_ => 1 } Class::Tiny->get_all_attributes_for($class) }; +}; + +sub new { + my $class = shift; + my $valid_attrs = $ATTR_CACHE{$class} || $_PRECACHE->($class); + + # handle hash ref or key/value arguments + my $args; + if ( $HAS_BUILDARGS{$class} ) { + $args = $class->BUILDARGS(@_); + } + else { + if ( @_ == 1 && ref $_[0] ) { + my %copy = eval { %{ $_[0] } }; # try shallow copy + Carp::croak("Argument to $class->new() could not be dereferenced as a hash") if $@; + $args = \%copy; + } + elsif ( @_ % 2 == 0 ) { + $args = {@_}; + } + else { + Carp::croak("$class->new() got an odd number of elements"); + } + } + + # create object and invoke BUILD (unless we were given __no_BUILD__) + my $self = + bless { map { $_ => $args->{$_} } grep { exists $valid_attrs->{$_} } keys %$args }, + $class; + $self->BUILDALL($args) if !delete $args->{__no_BUILD__} && @{ $BUILD_CACHE{$class} }; + + return $self; +} + +sub BUILDALL { $_->(@_) for @{ $BUILD_CACHE{ ref $_[0] } } } + +# Adapted from Moo and its dependencies +require Devel::GlobalDestruction unless defined ${^GLOBAL_PHASE}; + +sub DESTROY { + my $self = shift; + my $class = ref $self; + my $in_global_destruction = + defined ${^GLOBAL_PHASE} + ? ${^GLOBAL_PHASE} eq 'DESTRUCT' + : Devel::GlobalDestruction::in_global_destruction(); + for my $demolisher ( @{ $DEMOLISH_CACHE{$class} } ) { + my $e = do { + local ( $?, $@ ); + eval { $demolisher->( $self, $in_global_destruction ) }; + $@; + }; + no warnings 'misc'; # avoid (in cleanup) warnings + die $e if $e; # rethrow + } +} + +1; + + +# vim: ts=4 sts=4 sw=4 et: + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Class::Tiny - Minimalist class construction + +=head1 VERSION + +version 1.001 + +=head1 SYNOPSIS + +In F: + + package Person; + + use Class::Tiny qw( name ); + + 1; + +In F: + + package Employee; + use parent 'Person'; + + use Class::Tiny qw( ssn ), { + timestamp => sub { time } # attribute with default + }; + + 1; + +In F: + + use Employee; + + my $obj = Employee->new( name => "Larry", ssn => "111-22-3333" ); + + # unknown attributes are ignored + my $obj = Employee->new( name => "Larry", OS => "Linux" ); + # $obj->{OS} does not exist + +=head1 DESCRIPTION + +This module offers a minimalist class construction kit in around 120 lines of +code. Here is a list of features: + +=over 4 + +=item * + +defines attributes via import arguments + +=item * + +generates read-write accessors + +=item * + +supports lazy attribute defaults + +=item * + +supports custom accessors + +=item * + +superclass provides a standard C constructor + +=item * + +C takes a hash reference or list of key/value pairs + +=item * + +C supports providing C to customize constructor options + +=item * + +C calls C for each class from parent to child + +=item * + +superclass provides a C method + +=item * + +C calls C for each class from child to parent + +=back + +Multiple-inheritance is possible, with superclass order determined via +L. + +It uses no non-core modules for any recent Perl. On Perls older than v5.10 it +requires L. On Perls older than v5.14, it requires +L. + +=head1 USAGE + +=head2 Defining attributes + +Define attributes as a list of import arguments: + + package Foo::Bar; + + use Class::Tiny qw( + name + id + height + weight + ); + +For each attribute, a read-write accessor is created unless a subroutine of that +name already exists: + + $obj->name; # getter + $obj->name( "John Doe" ); # setter + +Attribute names must be valid subroutine identifiers or an exception will +be thrown. + +You can specify lazy defaults by defining attributes with a hash reference. +Keys define attribute names and values are constants or code references that +will be evaluated when the attribute is first accessed if no value has been +set. The object is passed as an argument to a code reference. + + package Foo::WithDefaults; + + use Class::Tiny qw/name id/, { + title => 'Peon', + skills => sub { [] }, + hire_date => sub { $_[0]->_build_hire_date }, + }; + +When subclassing, if multiple accessors of the same name exist in different +classes, any default (or lack of default) is determined by standard +method resolution order. + +To make your own custom accessors, just pre-declare the method name before +loading Class::Tiny: + + package Foo::Bar; + + use subs 'id'; + + use Class::Tiny qw( name id ); + + sub id { ... } + +Even if you pre-declare a method name, you must include it in the attribute +list for Class::Tiny to register it as a valid attribute. + +If you set a default for a custom accessor, your accessor will need to retrieve +the default and do something with it: + + package Foo::Bar; + + use subs 'id'; + + use Class::Tiny qw( name ), { id => sub { int(rand(2*31)) } }; + + sub id { + my $self = shift; + if (@_) { + return $self->{id} = shift; + } + elsif ( exists $self->{id} ) { + return $self->{id}; + } + else { + my $defaults = + Class::Tiny->get_all_attribute_defaults_for( ref $self ); + return $self->{id} = $defaults->{id}->(); + } + } + +=head2 Class::Tiny::Object is your base class + +If your class B already inherit from some class, then +Class::Tiny::Object will be added to your C<@ISA> to provide C and +C. + +If your class B inherit from something, then no additional inheritance is +set up. If the parent subclasses Class::Tiny::Object, then all is well. If +not, then you'll get accessors set up but no constructor or destructor. Don't +do that unless you really have a special need for it. + +Define subclasses as normal. It's best to define them with L, L +or L before defining attributes with Class::Tiny so the C<@ISA> +array is already populated at compile-time: + + package Foo::Bar::More; + + use parent 'Foo::Bar'; + + use Class::Tiny qw( shoe_size ); + +=head2 Object construction + +If your class inherits from Class::Tiny::Object (as it should if you followed +the advice above), it provides the C constructor for you. + +Objects can be created with attributes given as a hash reference or as a list +of key/value pairs: + + $obj = Foo::Bar->new( name => "David" ); + + $obj = Foo::Bar->new( { name => "David" } ); + +If a reference is passed as a single argument, it must be able to be +dereferenced as a hash or an exception is thrown. + +Unknown attributes in the constructor arguments will be ignored. Prior to +version 1.000, unknown attributes were an error, but this made it harder for +people to cleanly subclass Class::Tiny classes so this feature was removed. + +You can define a C method to change how arguments to new are +handled. It will receive the constructor arguments as they were provided and +must return a hash reference of key/value pairs (or else throw an +exception). + + sub BUILDARGS { + my $class = shift; + my $name = shift || "John Doe"; + return { name => $name }; + }; + + Foo::Bar->new( "David" ); + Foo::Bar->new(); # "John Doe" + +Unknown attributes returned from C will be ignored. + +=head2 BUILD + +If your class or any superclass defines a C method, it will be called +by the constructor from the furthest parent class down to the child class after +the object has been created. + +It is passed the constructor arguments as a hash reference. The return value +is ignored. Use C for validation, checking required attributes or +setting default values that depend on other attributes. + + sub BUILD { + my ($self, $args) = @_; + + for my $req ( qw/name age/ ) { + croak "$req attribute required" unless defined $self->$req; + } + + croak "Age must be non-negative" if $self->age < 0; + + $self->msg( "Hello " . $self->name ); + } + +The argument reference is a copy, so deleting elements won't affect data in the +original (but changes will be passed to other BUILD methods in C<@ISA>). + +=head2 DEMOLISH + +Class::Tiny provides a C method. If your class or any superclass +defines a C method, they will be called from the child class to the +furthest parent class during object destruction. It is provided a single +boolean argument indicating whether Perl is in global destruction. Return +values and errors are ignored. + + sub DEMOLISH { + my ($self, $global_destruct) = @_; + $self->cleanup(); + } + +=head2 Introspection and internals + +You can retrieve an unsorted list of valid attributes known to Class::Tiny +for a class and its superclasses with the C class +method. + + my @attrs = Class::Tiny->get_all_attributes_for("Employee"); + # returns qw/name ssn timestamp/ + +Likewise, a hash reference of all valid attributes and default values (or code +references) may be retrieved with the C class +method. Any attributes without a default will be C. + + my $def = Class::Tiny->get_all_attribute_defaults_for("Employee"); + # returns { + # name => undef, + # ssn => undef + # timestamp => $coderef + # } + +The C method uses two class methods, C and +C to set up the C<@ISA> array and attributes. Anyone +attempting to extend Class::Tiny itself should use these instead of mocking up +a call to C. + +When the first object is created, linearized C<@ISA>, the valid attribute list +and various subroutine references are cached for speed. Ensure that all +inheritance and methods are in place before creating objects. (You don't want +to be changing that once you create objects anyway, right?) + +=for Pod::Coverage new get_all_attributes_for get_all_attribute_defaults_for +prepare_class create_attributes + +=head1 RATIONALE + +=head2 Why this instead of Object::Tiny or Class::Accessor or something else? + +I wanted something so simple that it could potentially be used by core Perl +modules I help maintain (or hope to write), most of which either use +L or roll-their-own OO framework each time. + +L and L were close to what I wanted, but +lacking some features I deemed necessary, and their maintainers have an even +more strict philosophy against feature creep than I have. + +I also considered L, which has been around a long time and is +heavily used, but it, too, lacked features I wanted and did things in ways I +considered poor design. + +I looked for something else on CPAN, but after checking a dozen class creators +I realized I could implement exactly what I wanted faster than I could search +CPAN for something merely sufficient. + +In general, compared to most things on CPAN (other than Object::Tiny), +Class::Tiny is smaller in implementation and simpler in API. + +Specifically, here is how Class::Tiny ("C::T") compares to Object::Tiny +("O::T") and Class::Accessor ("C::A"): + + FEATURE C::T O::T C::A + -------------------------------------------------------------- + attributes defined via import yes yes no + read/write accessors yes no yes + lazy attribute defaults yes no no + provides new yes yes yes + provides DESTROY yes no no + new takes either hashref or list yes no (list) no (hash) + Moo(se)-like BUILD/DEMOLISH yes no no + Moo(se)-like BUILDARGS yes no no + no extraneous methods via @ISA yes yes no + +=head2 Why this instead of Moose or Moo? + +L and L are both excellent OO frameworks. Moose offers a powerful +meta-object protocol (MOP), but is slow to start up and has about 30 non-core +dependencies including XS modules. Moo is faster to start up and has about 10 +pure Perl dependencies but provides no true MOP, relying instead on its ability +to transparently upgrade Moo to Moose when Moose's full feature set is +required. + +By contrast, Class::Tiny has no MOP and has B non-core dependencies for +Perls in the L. It has far less code, less +complexity and no learning curve. If you don't need or can't afford what Moo or +Moose offer, this is intended to be a reasonable fallback. + +That said, Class::Tiny offers Moose-like conventions for things like C +and C for some minimal interoperability and an easier upgrade path. + +=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + +=head1 SUPPORT + +=head2 Bugs / Feature Requests + +Please report any bugs or feature requests through the issue tracker +at L. +You will be notified automatically of any progress on your issue. + +=head2 Source Code + +This is open source software. The code repository is available for +public review and contribution under the terms of the license. + +L + + git clone https://github.com/dagolden/Class-Tiny.git + +=head1 AUTHOR + +David Golden + +=head1 CONTRIBUTORS + +=for stopwords Dagfinn Ilmari Mannsåker Gelu Lupas Karen Etheridge Matt S Trout Olivier Mengué Toby Inkster + +=over 4 + +=item * + +Dagfinn Ilmari Mannsåker + +=item * + +Gelu Lupas + +=item * + +Karen Etheridge + +=item * + +Matt S Trout + +=item * + +Olivier Mengué + +=item * + +Toby Inkster + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is Copyright (c) 2013 by David Golden. + +This is free software, licensed under: + + The Apache License, Version 2.0, January 2004 + +=cut -- cgit v1.2.1