File Coverage

lib/Class/Builder.pm

Criterion	Covered	Total	%
statement	148	323	45.8
branch	31	102	30.3
condition	9	54	16.6
subroutine	23	64	35.9
pod	11	16	68.7
total	222	559	39.7

# ======================================================================== #
#   Class::Builder -- auto-generator of class accessors/special methods    #
# ======================================================================== #
# Author: Wei, Huang, Weitop Corp., 2003-8-30
# $Revision: 1.10 $ - $Date: 2003/10/05 07:28:03 $
# (c) Copyright: 2003 - 2006.

# *WARNNING* ALPHA RELEASE
#     This software is not ready for production use.

# *WARNING* TOTALLY NO WARRANTY
# This module is free software, you can use/modify or distribute
# it as the term of perlself. The software comes without any
# warranty of any type, use it at you own risk.

package Class::Builder;
our $VERSION = do { my @r = (q$Revision: 1.10 $ =~ /\d+/g); sprintf "%d."."%03d" x $#r, @r };;

use 5.006001;
use strict;
use warnings;
use integer;
use autouse 'Carp' => qw(carp croak);
use Exporter;
use Storable qw(dclone);
use base qw{Exporter};
our @EXPORT = qw{struct};

# ========================= | PACKAGE VARIABLES |
$Class::Builder::current_class = '';
%Class::Builder::defaults = ();
%Class::Builder::initializers = ();
%Class::Builder::classdata = ();
# ===============================================

# ---------------- | Public Methods |
sub known_types{
  return qw(string number boolean counter classdata hashref arrayref);
}

sub struct{
  # to inherite from Class::Builder
  # overridden this functions with
  # same contents in your sub class
  __PACKAGE__->_struct(@_);
}

sub import {
  # two type of arguments possible here:
  # use Class::Builder { args };
  # use Class::Builder ( args );
  my $self = shift;
  my $class = (caller(0))[0];
  if(((scalar @_) == 1) and ((ref $_[0]) eq 'HASH')){
    $self->setup($_[0], $class);
  }elsif((scalar @_) > 1){
    my %hash = (@_);
    $self->setup(\%hash, $class);
  }else{ ; }
  $self->export_to_level( 1, $self, @EXPORT );
}

# ---------------- | Private Methods |
sub _struct{
  # three types of arguments are considerable:
  # 1. struct { args } # implicit class name, not recommended
  # 2. struct class => { args }, class2 => { args };
  # 3. struct [class => {args}, class2 => {args}];
    # same as above, with little perfomance improvement
  my $builder = shift;
  my @args = @_;
  if((@args == 1) and (ref $args[0]) eq 'HASH'){
    my $class ||= (caller(1))[0];
    $builder->setup($args[0], $class);
  }else{
    my $aref;
    if((@args == 1) and (ref $args[0]) eq 'ARRAY'){
      $aref = shift @args;
    }else{ $aref = \@args; }
    croak "wrong number of arguments for struct.\n"
      if(@$aref % 2);

    my $class;
    while ($class = shift @$aref){
      $builder->setup((shift @$aref), $class);
    }
    return scalar @$aref;
  }
  return 1;
}

sub setup{
  # for sub-classing: you may
  # add you own extension here
  shift->_setup(@_);
}

sub _setup{
  # typical args hash:
  #  {
  #    '-methods' => {
  #        =>
  #    },
  #     => {
  #  		 => ,
  #  		final  => 1,
  #     forward =>
  #  	 }
  #  }
  # : number, string (or any scalar including references)
  #         boolean, counter, , classdata, hashref, arrayref
  # : initializer, constructor, group
  #                    abstract, dumper, clone,
  my ($builder, $arg, $class) = @_;
  $class ||= (caller(1))[0];

  # initialize class variables:
  $Class::Builder::current_class = $class;
  $Class::Builder::defaults{$class} ||={};
  $Class::Builder::initializers{$class} ||= [];

  # a loosing way for classdata inheritage:
  my $inherite = {};
  $inherite = $class->__classdata() if($class->can('__classdata'));
  %{$Class::Builder::classdata{$class}} = %$inherite;

  # get definations about special methods first
  my $special_methods = {};
  if(exists $arg->{-methods}){
    $special_methods = $arg->{-methods};
    delete $arg->{-methods};

    if(exists $special_methods->{initializer}){
      my $list = $special_methods->{initializer};
      $Class::Builder::initializers{$class}
        = (ref $list) ?  $list : [$list];

      delete $special_methods->{initializer};
    }
  }
  $special_methods->{constructor} = 'new'
      unless($special_methods->{constructor} or $class->can('new'));

  # range field informations,
  my $field_methods = {};
  my $any_classdata = 0;
  {
    my %known = map {$_, 1} $builder->known_types();

    while(my ($field, $def) = each %$arg){
      my $fieldarg = {name=> $field, final => 0};
      foreach (qw(final forward)){
        next unless exists $def->{$_};
        $fieldarg->{$_} = $def->{$_};
        delete $def->{$_};
      }
      croak "santax error for field $field, check it again."
        unless((scalar keys %$def) == 1);
      ($fieldarg->{type}, $fieldarg->{default}) = each %$def;

      croak "can not set counter fields to be final, for ", $fieldarg->{name},
            ".\n" if($fieldarg->{final} and ($fieldarg->{type} eq 'counter'));

      my $type = $fieldarg->{type};
      unless($known{$type}){
        $fieldarg->{type} = 'object';
        # 1. Type => ['constructor', 'arg1', 'arg2']
        # 2. Type => 'constructor'
        # 3. Type => created_object
        $fieldarg->{class} = $type;
        my $default = $fieldarg->{default};
        if($default and !(ref $default)){
          $fieldarg->{default} = $type->$default();
        }elsif((ref $default) eq 'ARRAY'){
          my $constructor = shift @$default;
          $fieldarg->{default} = $type->$constructor(@$default);
        }else{;}
      }

      # class data default goes here
      if($fieldarg->{type} eq 'classdata'){
        ++ $any_classdata;
        $Class::Builder::classdata{$class}->{$field} = $fieldarg->{default};
      }else{
        $Class::Builder::defaults{$class}->{$field} = $fieldarg->{default}
      }

      $field_methods->{$field} = $fieldarg;
    }
  }

  # set up fields methods, localize `no strict'
  {
    my %methods = ();
    foreach my $name (keys %$field_methods){
      my $type = $field_methods->{$name}->{type};
      %methods = (%methods, $builder->$type( $field_methods->{$name} ));
    }

    no strict 'refs';
    *{"$class"."::"."__classdata"} = sub {$Class::Builder::classdata{$class}}
                              if($any_classdata);
    while (my ($name, $code) = each %methods){
      *{"$class"."::"."$name"} = $code;
    }
  }

  # setup methods for special methods (after defaults set):
  {
    my %methods = map {$builder->$_( $special_methods->{$_} )}
                  (keys %$special_methods);
      # $_ is a element of a subset of
      # qw[constructor, abstract, dumper, clone]
    no strict 'refs';
    while (my ($name, $code) = each %methods){
      *{"$class"."::"."$name"} = $code;
    }

    # if any of a field declared, add a function to clear it.
    # i hope this will make some perfomance improvement, if any,
    # than the x/clear_x approach of MethodMaker.
    if(scalar keys %$field_methods){
      *{"${class}"."::"."clear"} = sub {
        my $self = shift; foreach (@_){$self->{$_} = undef}; undef;
       };
      # in addtion, you can get a list of
      *{"${class}"."::"."get"} = sub {
        my $self = shift; my $valuelist = [];
        foreach (@_){push @$valuelist, $self->$_; }
        return @$valuelist;
      };
    }
  }

  return 1;
}

# -------------------------------------- | Field Methods Builder |
sub string{
  # args name, final, type, default
  shift;
  my $args = shift;
  my $name = $args->{name};
  return ($name, sub { shift->{$name}; }) if($args->{final});

  return ($name, sub : lvalue {
    my $self = shift;
    $self->{$name} = $_[0] if(@_ == 1);
    $self->{$name};
  });
}

sub number{
  # implemented nothing special :-)
  shift->string(@_);
}

sub arrayref{
  shift;
  my ($arg) = @_;
  my $class = $Class::Builder::current_class;
  my $defaults = $Class::Builder::defaults{$class};
  my $name = $arg->{name};
  return (
    $name,
    sub {
      my $self  = shift;
      $self->{$name} = $_[0] if(@_ == 1 and (ref $_[0] eq 'ARRAY'));
      wantarray ? @{$self->{$name}} : $self->{$name};
    },
    "${name}_push",
    sub {
      my $self = shift;
      $self->{$name} = [] unless((ref $self->{$name}) eq 'ARRAY');
      push @{$self->{$name}}, @_;
    },
    "${name}_pop",
    sub {
      my ($self, $new) = @_;
      pop @{$self->{$name}};
    },
    "${name}_shift",
    sub {
      my $self = shift;
      shift @{$self->{$name}};
    },
    "${name}_unshift",
    sub {
      my $self = shift;
      $self->{$name} = [] unless((ref $self->{$name}) eq 'ARRAY');
      unshift @{$self->{$name}}, @_;
    },
    "${name}_count",
    sub {
      my $self = shift;
      return exists $self->{$name} ? scalar @{$self->{$name}} : 0;
    },
    "${name}_splice",
    sub {
      my ($self, $offset, $len, @list) = @_;
      splice(@{$self->{$name}}, $offset, $len, @list);
    }
  );
}

sub hashref{
shift;
  my ($arg) = @_;
  my $class = $Class::Builder::current_class;
  my $defaults = $Class::Builder::defaults{$class};
  my $name = $arg->{name};
  return (
    $name,
    sub {
      my $self  = shift;
      $self->{$name} = {} unless((ref $self->{$name}) eq 'HASH');
      if(@_ == 1 and (ref $_[0] eq 'HASH')){
        $self->{$name} = $_[0];
        return $self->{$name};
      }
      return @{$self->{$name}}{@_} if(scalar @_);
      $self->{$name};
    },
    "${name}_keys",
    sub {
      my $self = shift;
      $self->{$name} = {} unless((ref $self->{$name}) eq 'HASH');
      keys %{$self->{$name}};
    },
    "${name}_values",
    sub {
      my $self = shift;
      $self->{$name} = {} unless((ref $self->{$name}) eq 'HASH');
      values %{$self->{$name}};
    },
    "${name}_exists",
    sub {
      my $self = shift;
      my $key = shift;
      return
        exists $self->{$name} && exists $self->{$name}->{$key};
    },
    "${name}_delete",
    sub {
      my ($self, @keys) = @_;
      delete @{$self->{$name}}{@keys};
    },
  );
}

sub object{
  shift;
  my $arg = shift;
  my $name = $arg->{name};
  my $forward = [];
  $forward = (ref $arg->{forward}) ? $arg->{forward}
                                   : [$arg->{forward}] if($arg->{forward});
  my %results = ();
  $results{$name} = sub : lvalue {
    my $self  = shift;
    $self->{$name} = $_[0] if(@_ == 1 and ref $_[0]);
    $self->{$name};
  };

  foreach my $meth (@$forward){
    $results{$meth} =
      sub {
        my ($self, @args) = @_;
        $self->$name()->$meth(@args);
      };
  }

  return %results;
}

sub boolean{
  # args name, final, type, default
  shift;
  my $args = shift;
  my $class = $Class::Builder::current_class;
  my $defaults = $Class::Builder::defaults{$class};
  my $name = $args->{name};

  return ($name, sub { shift->{$name}; }) if($args->{final});

  return (
    $name,
    sub : lvalue {
    my $self = shift;
    if(@_ == 1){ $self->{$name} = ($_[0]) ? 1 : 0; }
    $self->{$name};
    },
    "${name}_rev",
    sub {
      my $self = shift;
      $self->{$name} = ($self->{$name}) ? 0 : 1;
    },
    "${name}_reset",
    sub {
      my $self = shift;
      my $val = $defaults->{$name} || 0;
      $self->{$name} = $val;
    },
  );
}

sub counter{
  shift;
  my ($arg) = @_;
  my $class = $Class::Builder::current_class;
  my $defaults = $Class::Builder::defaults{$class};
  my $name = $arg->{name};
  return (
    $name,
    sub {
      my $self  = shift;
      $self->{$name} = $_[0] if(@_ == 1 and ref $_[0]);
      $self->{$name};
    },
    "${name}_add",
    sub {
      my ($self, $new) = @_;
      $new ||= 1;
      $self->{$name} += $new;
    },
    "${name}_remove",
    sub {
      my ($self, $new) = @_;
      $new ||= 1;
      $self->{$name} -= $new;
    },
    "${name}_reset",
    sub {
      my $self = shift;
      my $val = $defaults->{$name} || 0;
      $self->{$name} = $val;
    },
    "${name}_set",
    sub {
      my $self = shift;
      $self->{$name} = int(shift);
    }
  );
}

sub classdata{
  shift;
  my $args = shift;
  my $class = $Class::Builder::current_class;
  my $classdata = $Class::Builder::classdata{$class};
  my $name = $args->{name};
  return ($name, sub { $classdata->{$name}; }) if($args->{final});
  return ($name, sub : lvalue {
    shift;
    my $arg = shift;
    defined $arg and $classdata->{$name} = $arg;
    $classdata->{$name};
  });
}

# -------------------------------------- | Special Methods Builder |
sub constructor{
  shift;
  my $arg = shift;
  my @list = ref($arg) eq 'ARRAY' ? @$arg : ($arg);
  my $class = $Class::Builder::current_class;
  my $initializers = $Class::Builder::initializers{$class};
  my $defaults = $Class::Builder::defaults{$class};

  map {
    $_,
    sub {
      my $class = (ref $_[0]) ? ref shift : shift;
      my $self = {};
      $self = dclone($defaults); my @args = @_;
      bless $self, $class;

      my $hashref = {};
      if($args[0] and (ref $args[0] eq 'HASH')){
        $hashref = shift @args;
      }else{
        %$hashref = @args unless(scalar @$initializers);
      }
      map {$_, $self->$_($hashref->{$_})} (keys %$hashref);
      map {$_, $self->$_(@args)} @$initializers;
      return $self;
    }
  } @list;
}

sub abstract {
  # implement abstract methods:
  shift;
  my $arg = shift;
  my $class = $Class::Builder::current_class;
  my @list = ref($arg) eq 'ARRAY' ? @$arg : ($arg);
  map {
    my $name = $_;
    ($name,
     sub {
       my ($self) = @_;
       my $calling_class = ref $self;
       die "[ABSTRACT METHOD] you can not call ${calling_class}::$name ",
        "(defined in class '$class') without overridden.";
     }
    )
  } @list;
}

sub group{
  shift;
  my $arg = shift;
  croak "the argument for a group must be a reference."
    unless(ref $arg);
  my $hashref = {};
  my %results = ();
  if(ref $arg eq 'ARRAY'){
    %$hashref = @$arg;
  }else{
    $hashref = $arg;
  }
  while (my ($group, $garg) = each %$hashref){
    $results{$group} = sub {wantarray ? @$garg : $garg};
  }
  return %results;
}

sub dumper{
  shift;
  my $arg = shift;
  my @list = ref($arg) eq 'ARRAY' ? @$arg : ($arg);
  map {
    $_,
    sub { require Data::Dumper; return Data::Dumper::Dumper(shift); }
  } @list;
}

sub clone{
  shift;
  my $arg = shift;
  my @list = ref($arg) eq 'ARRAY' ? @$arg : ($arg);
  map {
    $_,
    sub { require Storable; return Storable::dclone(shift); }
  } @list;
}

1;

__END__