package Class::Basic; use warnings; use strict; use Carp; use version; our $VERSION = qv('0.2.1'); =pod =head1 NAME Class::Basic - Tool to help organize and build perl classes =cut my @exported_subs = qw{ new has AUTOLOAD }; sub import { my $caller = caller; no strict 'refs'; foreach my $sub (@exported_subs) { *{ $caller . '::' . $sub } = \&{$sub}; } } =pod =head1 new Constructer It will call a BUILD method on every class in the inheritance tree starting at the parent. BUILD is also passed a hash_ref with the arguments passed to new. new is exported by default. =cut my %_init_args; sub new { my ( $class, $args ) = @_; croak "Argument to new must be hash reference" if @_ > 1 && ref $args ne 'HASH'; my $self = bless {}, ref $class || $class; foreach my $init_arg ( keys %_init_args ) { my $key = $_init_args{$init_arg}; $self->{$init_arg} = $args->{$key} || $args->{$init_arg}; delete $args->{$key} if exists $args->{$key}; delete $args->{$init_arg} if exists $args->{$init_arg}; } my @build = _reverse_hierarchy_of($class); foreach my $pkg (@build) { no strict 'refs'; if ( my $build_ref = *{ $pkg . '::BUILD' }{CODE} ) { $build_ref->( $self, $args ); } } return $self; } =pod =head1 has Create attributes. =over 4 =item has attribute => ( is => 'rw' ); This would create the method $self->attribute that can get and set the attribute =item has attribute => ( is => 'rw', reader => 'get_attribute', writer => 'set_attribute' ); This would create the methods $self->get_attribute and $self->set_attribute for the attribute =item has attribute => ( is => 'ro', default => sub { 42 }, predicate => 'has_attribute' ); This would create a read only method $self->attribute and the default value is 42. The default value must be a CODE ref. The CODE ref will receive $self as an argument. The default is always lazily set and the attribute is not set until the attribute method is called. The predicate key will create a boolean method for the attribute named after the value of the predicate key. =item has attribute => ( is => 'ro', init_arg => 1 ); Class->new( { attribute => 'value' } ); A read only method will be created and the key 'attribute' will be initialized automatically at instantiation. =back has is exported by default. =cut sub has($;%) { my ( $attr, %meta ) = @_; my $caller = caller(); my $reader = $meta{'reader'} || $attr; my $writer = $meta{'writer'} || $attr; $_init_args{$attr} = $meta{'init_arg'} if ( exists $meta{'init_arg'} and $meta{'init_arg'} ); croak 'Default must be a code ref' if exists $meta{'default'} and ref $meta{'default'} ne 'CODE'; if ( $reader eq $writer ) { if ( !exists $meta{'is'} or $meta{'is'} eq 'ro' ) { _ro_method( $caller, $attr, $reader, $meta{'default'} ); } elsif ( exists $meta{'is'} and $meta{'is'} eq 'wo' ) { _wo_method( $caller, $attr, $writer, $meta{'default'} ); } elsif ( exists $meta{'is'} and $meta{'is'} eq 'rw' ) { _rw_method( $caller, $attr, $writer, $meta{'default'} ); } } else { if ( !exists $meta{'is'} or $meta{'is'} eq 'ro' ) { _ro_method( $caller, $attr, $reader, $meta{'default'} ); } elsif ( exists $meta{'is'} and $meta{'is'} eq 'wo' ) { _wo_method( $caller, $attr, $writer, $meta{'default'} ); } elsif ( exists $meta{'is'} and $meta{'is'} eq 'rw' ) { _ro_method( $caller, $attr, $reader, $meta{'default'} ); _wo_method( $caller, $attr, $writer, $meta{'default'} ); } } if ( exists $meta{'predicate'} and $meta{'predicate'} ) { _predicate_method( $caller, $attr, $meta{'predicate'} ); } } =pod =head1 _reverse_hierarchy_of Walk the ISA tree and return the list of inheritance starting at the parent/base. =cut my %_reverse_hierarchy_of; sub _reverse_hierarchy_of { my ($class) = @_; return @{ $_reverse_hierarchy_of{$class} } if exists $_reverse_hierarchy_of{$class}; no strict 'refs'; my @hierarchy = $class; my @parents = reverse @{ $class . '::ISA' }; while ( defined( my $parent = shift @parents ) ) { push @hierarchy, $parent; push @parents, reverse @{ $parent . '::ISA' }; } my %seen; return @{ $_reverse_hierarchy_of{$class} } = reverse sort { $a->isa($b) ? -1 : $b->isa($a) ? +1 : 0 } grep !$seen{$_}++, @hierarchy; } sub _ro_method { my ( $pkg, $attr, $reader, $default ) = @_; no strict 'refs'; *{ $pkg . '::' . $reader } = sub { my ($self) = @_; carp $reader . ' is a read only accessor.' if scalar @_ > 1; $self->{$attr} ||= $default->($self) if $default and ref $default eq 'CODE'; return $self->{$attr}; }; } sub _wo_method { my ( $pkg, $attr, $writer, $default ) = @_; no strict 'refs'; *{ $pkg . '::' . $writer } = sub { my ( $self, $value ) = @_; my $old = $self->{$attr} ||= $default->($self) if $default and ref $default eq 'CODE'; $self->{$attr} = $value if $value; return $old || $self->{$attr}; }; } sub _rw_method { my ( $pkg, $attr, $writer, $default ) = @_; no strict 'refs'; *{ $pkg . '::' . $writer } = sub { my ( $self, $value ) = @_; my $old = $self->{$attr} ||= $default->($self) if $default and ref $default eq 'CODE'; $self->{$attr} = $value if $value; return $old || $self->{$attr}; }; } sub _predicate_method { my ( $pkg, $attr, $predicate ) = @_; no strict 'refs'; *{ $pkg . '::' . $predicate } = sub { my ($self) = @_; if ( exists $self->{$attr} and ref $self->{$attr} ) { if ( ref $self->{$attr} eq 'ARRAY' ) { return ( @{ $self->{$attr} } ) ? 1 : 0; } elsif ( ref $self->{$attr} eq 'HASH' ) { return ( %{ $self->{$attr} } ) ? 1 : 0; } else { return ( defined $self->{$attr} ) ? 1 : 0; } } elsif ( exists $self->{$attr} ) { return ( defined $self->{$attr} ) ? 1 : 0; } else { return 0; } }; } sub AUTOLOAD { my ($self) = @_; my $invocant_class = ref $self || $self; my ( $package_name, $method_name ) = our $AUTOLOAD =~ m/ (.*) :: (.*) /xms; return if $method_name eq 'DESTROY'; for my $parent_class ( reverse _reverse_hierarchy_of($invocant_class) ) { no strict 'refs'; if ( my $automethod_ref = *{ $parent_class . '::AUTOMETHOD' }{CODE} ) { local $CALLER::_ = $_; local $_ = $method_name; if ( my $method_impl = $automethod_ref->( $self, @_[ 1 .. $#_ ] ) ) { goto &$method_impl; } } } my $type = ref $self ? 'object' : 'class'; croak qq{Can't locate $type method "$method_name" via package "$package_name"}; } { my $real_can = \&UNIVERSAL::can; no warnings 'redefine', 'once'; *UNIVERSAL::can = sub { my ( $self, $method_name ) = @_; if ( my $sub_ref = $real_can->(@_) ) { return $sub_ref; } for my $parent_class ( reverse _reverse_hierarchy_of( ref $self || $self ) ) { no strict 'refs'; if ( my $automethod_ref = *{ $parent_class . '::AUTOMETHOD' }{CODE} ) { local $CALLER::_ = $_; local $_ = $method_name; if ( my $method_impl = $automethod_ref->(@_) ) { return sub { my $inv = shift; $inv->$method_name(@_) } } } } return; }; } 1;