File Coverage

blib/lib/Class/Data/TIN.pm

Criterion	Covered	Total	%
statement	78	81	96.3
branch	24	34	70.5
condition	6	12	50.0
subroutine	12	12	100.0
pod	4	4	100.0
total	124	143	86.7

#-----------------------------------------------------------------
# Class::Data::TIN
#-----------------------------------------------------------------
# Copyright Thomas Klausner / ZSI 2001, 2002
# You may use and distribute this module according to the same terms
# that Perl is distributed under.
#
# Thomas Klausner [e-mail] http://domm.zsi.at
#
# $Author: domm $
# $Date: 2002/01/29 22:03:35 $
# $Revision: 1.9 $
#-----------------------------------------------------------------
# Class::Data::TIN - T_ranslucent I_nheritable N_onpolluting
#-----------------------------------------------------------------
package Class::Data::TIN;

use 5.006;
use strict;
use warnings;

require Exporter;

use Carp;
use Data::Dumper;

our @ISA = qw(Exporter);
our @EXPORT_OK = qw(get get_classdata set set_classdata append append_classdata);
our $VERSION = '0.02';

# not exported, has to be called explicitly with Class::Data::TIN->new()
sub new {
   shift;  # remove own ClassName 'Class::Data::TIN'
   my $org_package=shift;  # get name of package to store vars in
   my $data;

   if (@_ == 1) {  # one param passed
     my $param=shift;
     if (ref($param) eq 'HASH') {  # is it a HASH ref ?
       $data=$param;
     } elsif (-e $param) {  # or is it a file ?
       $data=do $param; # TODO some error checking
     } else {  # then something is wrong
       croak("param is neither HASH REF nor file ...");
     }
   } else {  # more params passed, treat as HASH
     $data={@_};
   }

   croak("data structure must be a hashref") if ($data && ref($data) ne "HASH");

   my $tin_package=__PACKAGE__."::".$org_package;

   ### put data into TIN
   # start eval-string
   my $install="package $tin_package;";

   # add ISA's
   my @isa=eval "@".$org_package."::ISA";
   my @isa_tin;
   foreach (@isa) {
      push(@isa_tin,__PACKAGE__."::".$_);
   }
   $install.='our @ISA=(qw ('."@isa_tin".'));' if @isa_tin;

   $install.='our $_tin;';
   $install.='$_tin=$data;' if $data;
   eval $install;
   croak $@ if $@;

   # generate accessor methods in $tin_package
   for my $key (keys %$data) {
      _make_accessor($tin_package,$key);
   }

   # return empty fake pseudo obj, to make calling get/set/append easier
   # this is /not/ blessed, in fact, its just an alias to __PACKAGE__
   return $org_package;
}

# not exported
sub _make_accessor {
   my ($pkg,$key)=@_;

   # to enable black symbol table magic
   no strict "refs";

   my $accessor=$pkg."::".$key;
   return if *$accessor{CODE}; # there is allready an accessor

   my $r_tin=eval '$'."$pkg".'::_tin';

   *$accessor = sub {
      my $self=shift;
      $r_tin->{$key} = shift if @_;
      return $r_tin->{$key};
   }
}

# exported, has to be called on object or class, NOT on Class::Data::TIN
sub get_classdata {
   my ($self,$key)=@_;

   my $package=ref($self) || $self;
   my $tin=__PACKAGE__."::".$package;
   if ($tin->can($key)) {
      return $tin->$key();
   }
   return;
}

# alias
*get=*get_classdata;

# exported, has to be called on object or class, NOT on Class::Data::TIN
sub set_classdata {
   my $self=shift;
   my $package=ref($self) || $self;

   croak "object not allowed to modify class data" if (ref($self));

   my $tin=__PACKAGE__."::".$package;
   my ($key,$val)=@_;

   # copy on write:
   _make_accessor($tin,$key);

   return $tin->$key($val);
}

# alias
*set=*set_classdata;


# exported, has to be called on object or class, NOT on Class::Data::TIN
sub append_classdata {
   my $self=shift;
   my $package=ref($self) || $self;

   croak "object not allowed to modify class data" if (ref($self));

   my $tin=__PACKAGE__."::".$package;

   my $key=shift;

   # if this key is not here, there's no use appending, so use set()
   unless ($tin->can($key)) {
      return set($self,$key,@_);
   }

   # get old value
   my $val=$tin->$key;

   if (!ref($val)) {
      $val.=shift;
   } elsif (ref($val) eq "HASH") {
      eval Data::Dumper->Dump([$val],['val']);
      $val={%$val,@_};
   } elsif (ref($val) eq "ARRAY") {
      eval Data::Dumper->Dump([$val],['val']);
      push(@$val,@_);
   } elsif (ref($val) eq "CODE") {
      croak("cannot modify code ref");
   }

   # copy on write:
   _make_accessor($tin,$key);

   $tin->$key($val);
}

# alias
*append=*append_classdata;




1;
__END__