File Coverage

lib/LEOCHARRE/Class2.pm

Criterion	Covered	Total	%
statement	258	314	82.1
branch	86	138	62.3
condition	31	58	53.4
subroutine	48	59	81.3
pod	11	15	73.3
total	434	584	74.3

package LEOCHARRE::Class2;
use strict;
no strict 'refs';
use vars qw($VERSION @ISA @EXPORT);
use Exporter;
@ISA = qw/Exporter/;
@EXPORT = qw(
make_constructor
make_constructor_init
make_conf
make_count_for
make_accessor_setget_aref
make_accessor_get
make_method_counter
make_accessor_setget
make_accessor_setget_pathondisk
make_accessor_setget_ondisk_file
make_accessor_setget_ondisk_dir
make_accessor_setget_unique_array
);
$VERSION = sprintf "%d.%02d", q$Revision: 1.19 $ =~ /(\d+)/g;
# use Smart::Comments '###';
use Carp;

sub make_constructor {
   my $class = shift;
   ### $class
   *{"$class\::new"} = sub {
      my ($class,$self) = @_;
      $self||={};

      (defined $self and ref $self and ref $self eq 'HASH')
         or confess("Argument to constructor must be a hash ref");

      bless $self, $class;
      return $self;
   };
}

sub make_constructor_init {
   my $class = shift;
   ### $class
   *{"$class\::new"} = sub {
      my ($class,$self) = @_;
      $self||={};

      (defined $self and ref $self and ref $self eq 'HASH')
         or confess("Argument to constructor must be a hash ref");


      bless $self, $class;
      if ($class->can('init')){
         $self->init;
      }
      return $self;
   };
}



sub make_accessor_setget {
   my $class = shift;
   defined $class or die;

   for ( ___resolve_args(@_) ){
      _make_setget($class,@$_);
   }
}

sub make_accessor_get {
   my $class = shift;
   defined $class or die;

   for ( ___resolve_args(@_) ){
      _make_get($class,@$_);
   }
}


sub make_accessor_setget_ondisk_file {
   my $class = shift;
   defined $class or die;

   for ( ___resolve_args(@_) ){
      _make_setget_ondisk_file($class,@$_);
   }
}

sub make_accessor_setget_ondisk_dir {
   my $class = shift;
   defined $class or die;

   for ( ___resolve_args(@_) ){
      _make_setget_ondisk_dir($class,@$_);
   }
}

sub make_accessor_setget_aref {
   my $class = shift;
   defined $class or die;
   for ( ___resolve_args(@_) ){
      _make_setget_aref($class,@$_);
   }
}

sub make_accessor_setget_unique_array {
   my $class = shift;
   defined $class or die;
   for ( ___resolve_args(@_) ){
      _make_setget_unique_array($class,@$_);
   }
}



sub make_method_counter {
   my $class = shift;
   defined $class or die;
   for( ___resolve_args(@_) ){
      _make_method_counter($class,@$_);
   }
}
sub make_count_for {
   my $class = shift;
   defined $class or die;
   for( ___resolve_args(@_) ){
      _make_count_for($class,@$_);
   }
}


# THE REST ARE PRIVATE METHODS

sub ___resolve_args {

   my @resolved_args;

   # each one is
   #  accessor_name, accessor_default_value (can be undef)

   METHOD : while (scalar @_){
      my $arg = shift;
      defined $arg
         or die('1.arguments must be scalars, array refs, or hash refs, not undef or false');
      ### ARG START -----------------------------------------------
      ### $arg
      if ( my $ref = ref $arg ){         # make_accessor__ ( {} [])

         if ( $ref eq 'ARRAY' ){
            ### arg is aref
            push @resolved_args, $arg; # keep as is..
            next METHOD;
         }

         elsif ( $ref eq 'HASH' ){
            ### arg is hashref
            while( my ($name, $default_value) = each %$arg ){
               push @resolved_args, [ $name, $default_value];
            }
            next METHOD;
         }

         die("2.arguments must be scalars, array refs, or hash refs, "
            ."not undef or false or '$ref'");
      }

      ### arg is not ref

      push @resolved_args, [$arg, undef];
   }

   return @resolved_args;
}



# DEFAULT SETGET ACCESSOR
sub _make_setget {
   my($_class,$_name,$_default_value) = @_;
   my $namespace = "$_class\::$_name";

   *{$namespace} = sub {
      my $self = shift;
      my ($val) = @_;

      if( defined $val ){ # store it in object instance only
         $self->{$_name} = $val;
      }

      # if the key does not exist and we DO have a default in the class...
      if( !exists $self->{$_name} and defined $_default_value ){

            # BUT, if it is a ref, COPY it
            # IS A REF:
            if ( my $ref = ref $_default_value ){
               if ($ref eq 'ARRAY'){
                  $self->{$_name} = [ @$_default_value ];
               }
               elsif( $ref eq 'HASH' ){
                  $self->{$_name} = { %$_default_value };
               }
               elsif ( $ref eq 'SCALAR' ){
                  $self->{$_name} = $$_default_value;
               }
               else {
                  die("dont know how to use '$ref' ref as a default");
               }
            }


            # IS NOT A REF:
            else {
               $self->{$_name} = $_default_value;
            }


      }
      return $self->{$_name}; # may still be undef, that's ok
   };
}

# GET ACCESSOR

sub _make_get {
   my($_class,$_name,$_default_value) = @_;
   my $namespace = "$_class\::$_name";

   *{$namespace} = sub {
      my $self = shift;

      Carp::croak("This method does not take arguments.") if @_ and scalar @_;

      # if the key does not exist and we DO have a default in the class...
      if( !exists $self->{$_name} and defined $_default_value ){

            # BUT, if it is a ref, COPY it
            # IS A REF:
            if ( my $ref = ref $_default_value ){
               if ($ref eq 'ARRAY'){
                  $self->{$_name} = [ @$_default_value ];
               }
               elsif( $ref eq 'HASH' ){
                  $self->{$_name} = { %$_default_value };
               }
               elsif ( $ref eq 'SCALAR' ){
                  $self->{$_name} = $$_default_value;
               }
               else {
                  die("dont know how to use '$ref' ref as a default");
               }
            }


            # IS NOT A REF:
            else {
               $self->{$_name} = $_default_value;
            }


      }
      return $self->{$_name}; # may still be undef, that's ok
   };

}



# counter
sub _make_method_counter {
   my ($class,$name) = @_;
   my $namespace = "$class\::$name";
   my $datspace = "__$name\_counter__";

   *{$namespace} = sub {
      my($self,$val)=@_;

      $self->{$datspace} ||=0;

      if(defined $val){
         $val=~/^\d+$/ or die("value to $namespace() must be digits");
         if ($val) { #positive value
            $self->{$datspace} = ($self->{$datspace} + $val);
         }
         else { # arg is 0, reset
            $self->{$datspace} = 0;
         }
      }
      return  $self->{$datspace};
   };
}


sub _make_setget_ondisk_file {
   my($_class,$_name,$_default_value) = @_;
   my $namespace = "$_class\::$_name";


   *{$namespace} = sub {
      my $self = shift;
      my ($val) = @_;

      if( defined $val ){ # store it in object instance only
         my $abs = __resolve_f($val) or return;
         $self->{$_name} = $abs;
      }

      # if the key does not exist and we DO have a default in the class...
      if( !exists $self->{$_name} and defined $_default_value ){
         $self->{$_name} = __resolve_f($_default_value) or die;
      }
      return $self->{$_name}; # may still be undef, that's ok
   };

   sub __resolve_f {
      my $val = shift;
      require Cwd;
      my $a = Cwd::abs_path($val)
         or warn("cant resolve $val")
         and return;
      -f $a or warn("not file on disk '$a'")
         and return;
      return $a;
   }

}

sub _make_setget_ondisk_dir {
   my($_class,$_name,$_default_value) = @_;
   my $namespace = "$_class\::$_name";


   *{$namespace} = sub {
      my $self = shift;
      my ($val) = @_;

      if( defined $val ){ # store it in object instance only
        my $abs = __resolve_d($val) or return;
        $self->{$_name} = $abs;
      }

      # if the key does not exist and we DO have a default in the class...
      if( !exists $self->{$_name} and defined $_default_value ){
        $self->{$_name} = __resolve_d($_default_value) or die;
      }
      return $self->{$_name}; # may still be undef, that's ok
   };

   sub __resolve_d {
      my $val = shift;
      require Cwd;
      my $abs = Cwd::abs_path($val)
            or warn("cannot revolve '$val' with Cwd::abs_path()")
            and return;
      -d $abs
            or warn("'$abs' is not a directory")
            and return;
      return $abs;
   }
}




#sub make_accessor_errstr {
#   my $class = shift;
#   my $namespace = "$class\::errstr";
#}


# validate ondisk file or dir

sub _make_method_validate_ondisk_dir {
   my ($class,$name)= @_;

   my $namespace = "$class\::$name";
   *{$namespace} = sub {
      my ($self,$val) = @_;
      $val or return; # croak, die, warn ??

      require Cwd;
      my $abs = Cwd::abs_path($val) or return;
      -d $abs and return $abs;
      return 0;
   }
}
sub _make_method_validate_ondisk_file {
   my ($class,$name)= @_;

   my $namespace = "$class\::$name";
   *{$namespace} = sub {
      my ($self,$val) = @_;
      $val or return; # croak, die, warn ??

      require Cwd;
      my $abs = Cwd::abs_path($val) or return;
      -f $abs and return $abs;
      return 0;
   }
}







# clear methods
sub _make_method_clear {
   my ($class,$name)= @_;

   my $namespace = "$class\::$name";
   *{$namespace} = sub {
      my $self = shift;
      $self->{$namespace} = undef;
      return 1;
   }
}
sub _make_method_clear_hashref {
   my ($class,$name)= @_;

   my $namespace = "$class\::$name";
   *{$namespace} = sub {
      my $self = shift;
      $self->{$namespace} = {};
      return 1;
   }
}
sub _make_method_clear_arrayref {
   my ($class,$name)= @_;

   my $namespace = "$class\::$name";
   *{$namespace} = sub {
      my $self = shift;
      $self->{$namespace} = [];
      return 1;
   }
}




#use Smart::Comments '####';

# _make_setget_unique_array()
sub _make_setget_unique_array {
   my($_class, $_name, $_default_value) = @_;

   #### $_default_value
   #### $_name

   if( defined $_default_value ){
      ref $_default_value
         and ref $_default_value eq 'ARRAY'
         or confess("Default value to $_class '$_name' must be array ref");
   }

   my $namespace        = "$_class\::$_name";

   no strict 'refs';

   # method name
   my $method_name_href    = "$_name\_href";
   my $method_name_aref    = "$_name\_aref";
   my $method_name_count   = "$_name\_count";
   my $method_name_delete  = "$_name\_delete";
   my $method_name_add     = "$_name\_add";
   my $method_name_exists  = "$_name\_exists";
   my $method_name_clear   = "$_name\_clear";

   # return array
   *{"$_class\::$_name"} = sub {
      my $self = shift;

      map{ $self->$method_name_href->{$_}++ } grep { defined $_ } @_;

      my @a = sort keys %{$self->$method_name_href};
      wantarray ? @a : \@a;
   };

   # return array ref
   *{"$_class\::$method_name_aref"} = sub {
      [ sort keys %{$_[0]->$method_name_href} ]
   };

   # return count
   *{"$_class\::$method_name_count"} = sub {
      scalar keys %{$_[0]->$method_name_href}
   };

   # add
   *{"$_class\::$method_name_add"} = sub {
      my $self = shift;
      map{ $self->$method_name_href->{$_}++ } grep { defined $_ } @_;
      1;
   };

   # delete
   *{"$_class\::$method_name_delete"} = sub {
      my $self = shift;
      map{ delete $self->$method_name_href->{$_} } grep { defined $_ } @_;
      1;
   };

   # exists
   *{"$_class\::$method_name_exists"} = sub {
      my $self = shift;
      exists $self->$method_name_href->{$_[0]} ? 1 : 0
   };

   # clear
   *{"$_class\::$method_name_clear"} = sub {
      my $self = shift;
      $self->{$method_name_href} = {};
      1;
   };

   # actual data holder..... the href.....



   # if the key does not exist and we DO have a default in the class...
   *{"$_class\::$method_name_href"} = sub {
      my $self = shift;

      if ( ! exists $self->{$method_name_href} ){
         #### apparently not init yet

         if ( exists $self->{$_name} ){
            #### was in constructor
            ref $self->{$_name}
               and ref $self->{$_name} eq 'ARRAY'
               or confess("value for $_class $_name must be array ref");

            @{$self->{$method_name_href}}{ @{$self->{$_name}} } = ();
         }
         elsif ( defined $_default_value ){ # was already checked for ARRAY ref
            #### had default value
            @{$self->{$method_name_href}}{ @$_default_value } = ();
         }

         else {
            #### blank value
            $self->{$method_name_href} = {};
         }
      }
      $self->{$method_name_href}
   };

}


#





# TODO, check if subs exist alreaddy? can()
# should we do this or not?


# setget arrayref
sub _make_setget_aref {
   my($_class, $_name, $_default_value) = @_;

   my $namespace = "$_class\::$_name";
   my $namespace_count = "$_class\::$_name\_count";

   *{$namespace} = sub {
      my $self = shift;
      my ($val) = @_;

      if( defined $val ){ # store it in object instance only
         ### 343 VAL
         ref $val eq 'ARRAY' or die("must be array ref arg");
         $self->{$_name} = $val;
      }

      # if the key does not exist and we DO have a default in the class...
      if( !exists $self->{$_name}){

         if ( defined $_default_value ){
            ### 350 DEF
            $self->{$_name} = [ @$_default_value ];
         }
         else {
            ### NON
            $self->{$_name} = [];
         }
      }

      wantarray ? return @{$self->{$_name}} : return $self->{$_name};
   };
   #TODO, right now if undef, we set to [], is this teh behaviour we want?

   _make_count_for($_class, $_name);
}




sub _make_count_for {
   my($class, $methodorkey) = @_;

   my $namespace = "$class\::$methodorkey\_count";

   *{$namespace} = sub {
      my $self = shift;

      my $thing;

      # object method?
      if ($self->can($methodorkey)){
         $thing = $self->$methodorkey;
      }
      # object key?
      elsif( exists $self->{$methodorkey}){
         $thing = $self->{$methodorkey};
      }

      # die???, NO NO.. we do want to return if nothing.. if we want a method that just counts
      # a value in the object instance, taht's all
      else {
         return 0; # ???
         #die;
      }


      # ok... now what..
      my $ref = ref $thing;
      if( $ref and $ref eq 'ARRAY'){
         return scalar @$thing;
      }
      elsif( $ref and $ref eq 'HASH'){
         return scalar keys %$thing;
      }
      # else ???
      # die??
      return 0; # ???
   };

}


# BEGIN  CONF

sub make_conf {
   my $class = shift;
   my $default_path = shift; # can be undef

    _make_setget($class, 'abs_conf', $default_path);

   for my $name (qw(conf conf_load conf_save conf_keys)){
      #$class->can($name) and warn("Class $class can already '$name()'");
      *{"$class\::$name"} = \&$name;
   }


   sub conf {
      $_[0]->{conf} or $_[0]->conf_load;
      $_[0]->{conf} ||= {};
   }
   sub conf_load {
      require YAML;
      my $a = $_[0]->abs_conf
         or warn "Can't load conf, missing abs_conf path."
         and return;
      -f $a
         or warn "Can't load conf, not on disk '$a'\n"
         and return;

      $_[0]->{conf} = YAML::LoadFile($a)
   }
   sub conf_keys { my $c = $_[0]->conf or return; sort keys %$c }
   sub conf_save { require YAML; YAML::DumpFile($_[0]->abs_conf,$_[0]->{conf}) }

}






# END CONF


1;