File Coverage

blib/lib/Orignal.pm

Criterion	Covered	Total	%
statement	176	184	95.6
branch	23	36	63.8
condition	16	27	59.2
subroutine	20	20	100.0
pod	2	2	100.0
total	237	269	88.1

require 5.006_001;
BEGIN {
  $Orignal::VERSION = "0.04";
}
package Orignal;
use Carp();
use Exporter ();
BEGIN {
  @ISA = qw(Exporter);
  @EXPORT    = ();
  @EXPORT_OK = qw(%Orignal);
}
use strict;
use warnings;
sub attributes {
    my $class = shift;


    # Make sure it is not called out of a 'modual' context;
    Carp::croak("ERROR: Orignal::$class->attributes, Somehow you managed to call this outside a modual!") if (ref($class));
    my $self = {};
    bless( $self, ( ref($class) || $class ) );
    my ($attributes) = @_;
   # Check $attributes
   ref($attributes) eq 'HASH' || Carp::croak("ERROR: Orignal::$class->attributes, argument must be a 'HASH' reference.");
   if (!exists($attributes->{SCALARS}) and
       !exists($attributes->{HASHES}) and
       !exists($attributes->{ARRAYS}) and
       !exists($attributes->{ORDERED_HASHES})){
      Carp::croak("ERROR: Orignal::$class->attributes, argument 'HASH' reference must has at least one key of 'SCALARS','HASHES' or 'ARRAYS'.");
   }
   if ( exists($attributes->{SCALARS}) and ref($attributes->{SCALARS}) ne 'ARRAY') {
      Carp::croak("ERROR: Orignal::$class->attributes 'SCALARS', must be an 'ARRAY' reference.");
   }
   if ( exists($attributes->{HASHES}) and ref($attributes->{HASHES}) ne 'ARRAY') {
      Carp::croak("ERROR: Orignal::$class->attributes 'HASHES', must be an 'ARRAY' reference.");
   }
   if ( exists($attributes->{ORDERED_HASHES}) and ref($attributes->{ORDERED_HASHES}) ne 'ARRAY') {
      Carp::croak("ERROR: Orignal::$class->attributes 'ORDERED_HASHES', must be an 'ARRAY' reference.");
   }
   if ( exists($attributes->{ARRAYS}) and ref($attributes->{ARRAYS}) ne 'ARRAY') {
      Carp::croak("ERROR: Orignal::$class->attributes 'ARRAYS', must be an 'ARRAY' reference.");
   }

   $self->_install_perlish($class,$attributes);
   return;
}
sub new {
    my $class = shift;
    my $self = {};
    bless( $self, ( ref($class) || $class ) );
    $self->_initialize(@_);
    return( $self );
}
sub _attr_to_string {
   my $self = shift;
   my ($attributes) = @_;
   my $return;
   foreach my $type (keys(%{$attributes})) {
      $return.= $type."=>[";
      foreach my $attr (@{$attributes->{$type}}){
           $return.="'$attr',";
      }
      $return.='],';
   }
   return $return;
}
sub _install_perlish {
   my $self = shift;
   my ($imp_class,$attributes) = @_;

   # set the my_attributes first;

   if (!$self->can('my_attributes')){
     my $attributes_method= "$imp_class\::my_attributes";
     my $attributes_code = "sub {
	  return {".$self->_attr_to_string($attributes)."};
	};";
     {
       no strict qw(refs);
       my $attributes_ref = eval qq{ #line 1 "$imp_class $attributes_method "\n$attributes_code};
       *$attributes_method = $attributes_ref;
     }
   }
    #do the scalars next
   my %fields;
   foreach my $field (@{$attributes->{SCALARS}}) {
      $fields{$field} = 'SCALARS';
      my $set_method= "$imp_class\::$field";
      my $set_code = "sub {
	  my \$self = shift;
	  if (\@_) {
	    \$self->validate_$field(\@_)
	        if \$self->can('validate_$field');
 	    \$self->{$field} = shift;
	    return 1;
	  }
	  return \$self->{$field};
	};";
     {
       no strict qw(refs);
       my $set_code_ref   = eval qq{#line 1 "$imp_class $set_method "\n$set_code};
       *$set_method 	   = $set_code_ref;
     }
   }
   if (exists($attributes->{HASHES})) {
      $self->_install_hashes($imp_class,$attributes->{HASHES},\%fields);
   }
   if (exists($attributes->{ORDERED_HASHES})) {
      $self->_install_ordered_hashes($imp_class,$attributes->{ORDERED_HASHES},\%fields);
   }
   if (exists($attributes->{ARRAYS})) {
      $self->_install_arrays($imp_class,$attributes->{ARRAYS},\%fields);
   }
   $self->{attributes} = $attributes;
   return;
 }
 sub _install_hashes {
   #do the hashes next
   my $self = shift;
   my ($imp_class,$attributes,$fields) = @_;
   foreach my $field (@{$attributes}) {
     if ($fields->{$field}){
        Carp::croak("ERROR: Orignal::$imp_class->attributes, argument 'HASHES' field '$field' is also a SCALARS field!");
     }
     $fields->{$field}  = 'HASHES';
     my $set_get_method = "$imp_class\::$field";
     my $delete_method  = "$imp_class\::delete_$field";
     my $keys_method    = "$imp_class\::keys_$field";
     my $values_method  = "$imp_class\::values_$field";
     my $exists_method  = "$imp_class\::exists_$field";
     my $set_get_code = "sub {
			my \$self = shift;
			my (\$index) = \@_;
			unless (\$index) {
			   if (\$self->{$field}{HASH}){
 			     return(wantarray ? \%{\$self->{$field}{HASH}}:scalar(\%{\$self->{$field}{HASH}}));
 			   }

			}
			if (ref(\$index) eq 'HASH') {
			   unless (scalar(\%{\$index})){
			      \$self->{$field}{HASH}={};
		           }
		           else {
			      \$self->validate_$field(\$index)
			          if \$self->can('validate_$field');
		              if (\$self->{$field}{HASH}){
		                \$self->{$field}{HASH}={\%{\$self->{$field}{HASH}},\%{\$index}};
			      }
			      else {
                                \$self->{$field}{HASH}=	\$index;
			      }
			   }
			   return(wantarray ? \%{\$self->{$field}{HASH}}:scalar(\%{\$self->{$field}{HASH}}));
			}
			if (scalar(\@_)){
			   my \%ret=();
			   foreach my \$key (\@_){
			      last if(!\$key);
			      next if (!exists(\$self->{$field}{HASH}{\$key} ) );
			      \$ret{\$key} = \$self->{$field}{HASH}{\$key};
			   }
			   return(wantarray ? \%ret : scalar(\%ret));
 			}
		     };";
     my $keys_code = "sub {
			my \$self = shift;
			return(wantarray ? keys(\%{\$self->{$field}{HASH}}):scalar(keys(\%{\$self->{$field}{HASH}})));
		     };";
     my $values_code = "sub {
			my \$self = shift;
			return(wantarray ? values(\%{\$self->{$field}{HASH}}):scalar(values(\%{\$self->{$field}{HASH}})));
		     };";
     my $delete_code = "sub {
			my \$self = shift;
			my \@ret_val =();
			foreach my \$val (\@_) {
			   next if (!exists( \$self->{$field}{HASH}{\$val}));
			   push(\@ret_val,\$self->{$field}{HASH}{\$val});
                           delete(\$self->{$field}{HASH}{\$val});
                        }
                        return wantarray ? \@ret_val : pop(\@ret_val);
                      };";
     my $exists_code = "sub {
			my \$self = shift;
			my \$count = 0;
			foreach my \$val (\@_) {
			   \$count += exists( \$self->{$field}{HASH}{\$val});
			}
			return(\$count);
		      };";
      {
	 no strict qw(refs);
	 my $set_get_code_ref = eval qq{#line 1  "$imp_class $set_get_method "\n$set_get_code};
	 my $delete_code_ref  = eval qq{#line 1  "$imp_class $delete_method "\n$delete_code};
	 my $keys_code_ref    = eval qq{#line 1  "$imp_class $keys_method "\n$keys_code};
         my $values_code_ref  = eval qq{#line 1  "$imp_class $values_method "\n$values_code};
         my $exists_code_ref  = eval qq{#line 1  "$imp_class $exists_method "\n$exists_code};
         *$exists_method  = $exists_code_ref;
	 *$set_get_method = $set_get_code_ref;
	 *$delete_method  = $delete_code_ref;
	 *$keys_method    = $keys_code_ref;
	 *$values_method  = $values_code_ref;
      }
    }
}
sub _install_ordered_hashes {
   #do the hashes next
   my $self = shift;
   my ($imp_class,$attributes,$fields) = @_;
   foreach my $field (@{$attributes}) {
     if ($fields->{$field}){
        Carp::croak("ERROR: Orignal::$imp_class->attributes, argument 'ORDERED_HASHES' field '$field' is also a $fields->{$field} field!");
     }
     $fields->{$field}  = 'ORDERED_HASHES';
     my $set_get_method = "$imp_class\::$field";
     my $delete_method  = "$imp_class\::delete_$field";
     my $keys_method    = "$imp_class\::keys_$field";
     my $values_method  = "$imp_class\::values_$field";
     my $exists_method  = "$imp_class\::exists_$field";
     my $set_get_code = "sub {
			my \$self    = shift;
			my (\$index) = \@_;
			unless (\$index) {
			   if(\$self->{$field}{HASH}){
			      return(wantarray ? \%{\$self->{$field}{HASH}} : scalar(\%{\$self->{$field}{HASH}}));
			   }
			}

			if (ref(\$index) eq 'HASH') {
			   unless (scalar(\%{\$index})){
			      \$self->{$field}{HASH} ={};
			      \$self->{$field}{ARRAY}=[];
		           }
		           else {
			      \$self->validate_$field(\$index)
			         if \$self->can('validate_$field');
			      foreach my \$key (keys(\%\$index)){
			        push(\@{\$self->{$field}{ARRAY}},\$key)
			          unless (exists(\$self->{$field}{HASH}{\$key}));
			        \$self->{$field}{HASH}{\$key} = \$index->{\$key};
			      }
			   }
			   return(wantarray ? \%{\$self->{$field}{HASH}} : scalar(\%{\$self->{$field}{HASH}}));
			}
			if (scalar(\@_)){
			   my \%ret=();
			   foreach my \$key (\@_){
			      last if (!\$key);
			      next if (!exists(\$self->{$field}{HASH}{\$key} ) );
			      \$ret{\$key} = \$self->{$field}{HASH}{\$key};
			   }
			   if (scalar(\@_) == 1 and \$_[0]){
			      return(wantarray ? \%ret : \$ret{\$_[0]});
			   }
			   return(wantarray ? \%ret : scalar(\%ret));
            		}
		     };";
     my $keys_code = "sub {
			my \$self = shift;
			return(wantarray ? \@{\$self->{$field}{ARRAY}}:scalar(\@{\$self->{$field}{ARRAY}}));
		     };";
     my $values_code = "sub {
			my \$self = shift;
			my \@ret  = ();
			foreach my \$key (\@{\$self->{$field}{ARRAY}}){
			   push(\@ret,\$self->{$field}{HASH}{\$key});
			}
			return(wantarray ? \@ret : scalar(\@ret));
		     };";
     my $delete_code = "sub {
			my \$self     = shift;
			my \@ret_val =();
			my \$del_index = 0;
			foreach my \$val (\@_) {
			   \$del_index = 0;
			   foreach my \$item (\@{\$self->{$field}{ARRAY}}){
			      next if (!exists( \$self->{$field}{HASH}{\$val}));
			      if (\$item eq \$val){
				  push(\@ret_val,\$self->{$field}{HASH}{\$val});
				  splice( \@{\$self->{$field}{ARRAY}},\$del_index,1);
				  delete(\$self->{$field}{HASH}{\$val});
			      }
			      \$del_index++;
			   }
                        }
                        return wantarray ? \@ret_val : pop(\@ret_val);
		      };";
     my $exists_code = "sub {
			my \$self = shift;
			my \$count = 0;
			foreach my \$val (\@_) {
			   \$count += exists( \$self->{$field}{HASH}{\$val});
			}
			return(\$count);
		      };";
      {
	 no strict qw(refs);
	 my $set_get_code_ref = eval qq{#line 1 "$imp_class $set_get_method "\n$set_get_code};
	 my $delete_code_ref  = eval qq{#line 1 "$imp_class $delete_method "\n$delete_code};
	 my $keys_code_ref    = eval qq{#line 1 "$imp_class $keys_method "\n$keys_code};
         my $values_code_ref  = eval qq{#line 1 "$imp_class $values_method "\n$values_code};
         my $exists_code_ref  = eval qq{#line 1 "$imp_class $exists_method "\n$exists_code};
         *$exists_method  = $exists_code_ref;
	 *$set_get_method = $set_get_code_ref;
	 *$delete_method  = $delete_code_ref;
	 *$keys_method    = $keys_code_ref;
	 *$values_method  = $values_code_ref;
      }
    }
}
 sub _install_arrays {
   my $self = shift;
   my ($imp_class,$attributes,$fields) = @_;
    #do the arrays next
   foreach my $field (@{$attributes}) {
      if ($fields->{$field}){
         Carp::croak("ERROR: Orignal::$imp_class->attributes, argument 'ARRAYS' field '$field' is also a $fields->{$field} field!");
      }
      my $pop_method     = "$imp_class\::pop_$field";
      my $push_method    = "$imp_class\::push_$field";
      my $shift_method   = "$imp_class\::shift_$field";
      my $unshift_method = "$imp_class\::unshift_$field";
      my $set_get_method = "$imp_class\::$field";
      my $set_get_code = "sub {
	                my \$self = shift;
	                my (\$index) = \@_;

			if (ref(\$index) eq 'ARRAY') {
			  unless (scalar(\@{\$index})){
			    \$self->{$field}{ARRAY}=[];
		          }
		          else {
		  	      \$self->validate_$field(\$index)
		  	          if \$self->can('validate_$field');
		              push(\@{\$self->{$field}{ARRAY}},\@{\$index});
			  }
			  return(wantarray ? \@{\$self->{$field}{ARRAY}} : scalar(\@{\$self->{$field}{ARRAY}}));
			}
			if (!\$index){
			  if (\$self->{$field}{ARRAY}){
		            return(wantarray ? \@{\$self->{$field}{ARRAY}} : scalar(\@{\$self->{$field}{ARRAY}}));
  			  }
  			  else {
  			    return(wantarray ? () : 0);

  			  }
			}
			else {
			   my \@ret=();
			   foreach my \$index (\@_){
			      push(\@ret,\$self->{$field}{ARRAY}[\$index]);
			   }
			   return(wantarray ? \@ret : scalar(\@ret));
			}

		     };";
      my $pop_code   = "sub {
			  my \$self = shift;
			  return(pop( \@{ \$self->{$field}{ARRAY} } ));
                        };";
      my $push_code  = "sub {
			  my \$self = shift;
			  my (\$index) = \@_;
			  my \$return_count = 0;
			  if (ref(\$index) eq 'ARRAY') {
			     \$self->validate_$field(\$index)
		  	        if \$self->can('validate_$field');
			     \$return_count = push( \@{ \$self->{$field}{ARRAY}}, \@{\$index} );
			  }
			  else {
			     foreach my \$val (\@_) {
			       \$self->validate_$field(\$val)
		  	          if \$self->can('validate_$field');
			       \$return_count = push( \@{ \$self->{$field}{ARRAY}}, \$val );
			     }
			  }
			  return(\$return_count);
                        };";
      my $shift_code = "sub {
			  my \$self = shift;
			  my \$index;
			  return(shift( \@{ \$self->{$field}{ARRAY}} ));
                        };";
       my $unshift_code = "sub {
			   my \$self = shift;
			   my (\$index) = \@_;
			   my \$return_count = 0;
			   if (ref(\$index) eq 'ARRAY') {
			     \$self->validate_$field(\$index)
		  	        if \$self->can('validate_$field');
			     \$return_count = unshift( \@{ \$self->{$field}{ARRAY}}, \@{\$index} );
			   }
			   else {
			     foreach my \$val (\@_) {
			       \$return_count = unshift( \@{ \$self->{$field}{ARRAY}}, \$val );
			     }
			  }
			  return(\$return_count);
                          };";
       {
          no strict qw(refs);
          my $pop_code_ref     = eval qq{#line 1  "$imp_class $pop_method "\n$pop_code};
          my $push_code_ref    = eval qq{#line 1  "$imp_class $push_method "\n$push_code};
          my $shift_code_ref   = eval qq{#line 1  "$imp_class $shift_method "\n$shift_code};
          my $unshift_code_ref = eval qq{#line 1  "$imp_class $unshift_method "\n$unshift_code};
          my $set_get_code_ref = eval qq{#line 1  "$imp_class $set_get_method "\n$set_get_code};
          *$unshift_method = $unshift_code_ref;
          *$pop_method     = $pop_code_ref;
          *$push_method    = $push_code_ref;
          *$shift_method   = $shift_code_ref;
          *$set_get_method = $set_get_code_ref;
       }
     }
}
sub _initialize {
    my $self = shift;
    my $opt = defined($_[0]) ? shift : {};
    # Check $opt
    ref($opt) eq 'HASH' || Carp::croak("ERROR: Orignal::$self, first argument must be 'HASH' reference.");
    foreach my $field (keys(%{$opt})) {
       if ($self->can($field)){
	  my $validate = 'validate_'.$field;
	  if ($self->can($validate)){
	       $self->$validate($opt->{$field});
          }
 	  $self->$field($opt->{$field});
       }
       # else {
          # Carp::croak("ERROR: Orignal::".ref($self)."::new, Field $field not defined!");
       # }
    }
}

1;
__END__