File Coverage

blib/lib/Class/Data/TIN.pm

Criterion	Covered	Total	%
statement	152	165	92.1
branch	48	72	66.6
condition	29	38	76.3
subroutine	24	24	100.0
pod	4	5	80.0
total	257	304	84.5

package Class::Data::TIN;

# ABSTRACT: DEPRECATED - Translucent, Inheritable, Nonpolluting class data
our $VERSION = '0.03'; # VERSION

use 5.006;
use strict;
use warnings;

warn __PACKAGE__ .' is DEPRECATED, please do not use this module anymore';

use Class::DispatchToAll qw(dispatch_to_all);

require Exporter;

use Carp;
use Data::Dumper;

our @ISA = qw(Exporter);
our @EXPORT_OK = ('get_classdata','set_classdata','append_classdata','merge_classdata');

our $stop="_tinstop";

# 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=_import_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.='$'.__PACKAGE__.'::_tin=$data;';
   $install.='our $_tin=$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 _import_data {
    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;
	    unless ($data) {
		croak("couldn't parse $param: $@") if $@;
                croak("couldn't do $param: $!") unless defined $data;
	    }
	} else {  # then something is wrong
	    croak("param is neither HASH REF nor file ...");
	}
    } else {  # more params passed, treat as HASH
	$data={@_};
    }
   return $data;
}

sub _save_val {
    my ($pkg,$key,$val,$stopper)=@_;

#    if (ref($val) eq "ARRAY" && $val->[0] eq $stop) {
#	$val=$val->[1];
#    }

    if ($stopper && $stopper>0) {
	$val=[$stop,$val];
    }

    my $install='$'.$pkg.'::_tin->{$key}=$val';
    eval $install;
    croak($@) if $@;

    _make_accessor($pkg,$key);

    return;
}

sub _make_accessor {
    my ($pkg,$key)=@_;
    no strict "refs";
    my $accessor=$pkg."::".$key;
    return if *$accessor{CODE}; # there is allready an accessor

    my $r_tin=eval '$'."$pkg".'::_tin';
    croak($@) if $@;

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

# ueberschreibt den aktuellen Wert in der package mit dem neuen
# geht mit einem wert
sub set_classdata {
    my ($self,$key,$val,$stopper)=@_;
    my $package=ref($self) || $self;

    my $tin=__PACKAGE__."::".$package;
    _save_val($tin,$key,$val,$stopper);
    return $tin->$key();
}

# haengt daten an die daten in der aktuellen package dran
# geht mit einem wert
# copy on write
sub append_classdata {
    my ($self,$key,$val,$stopper)=@_;
    return unless $val;
    my $package=ref($self) || $self;

    # aktuellen wert hohlen
    no strict 'refs';
    my $tin=__PACKAGE__."::".$package;
    my $rtin=$tin."::_tin";
    my $oldval=$$rtin->{$key};

    # neuen wert dranhaengen
    if ($oldval) {
	($val,$stopper)=_merge($oldval,$val,$stopper);
    }

    _save_val($tin,$key,$val,$stopper);
    return;
}

# wie append, nur mit mehreren vals auf einmal
sub merge_classdata {
    my $self=shift;
    my $package=ref($self) || $self;
    my $data=_import_data(@_);

    no strict 'refs';
    my $tin=__PACKAGE__."::".$package;
    my $rtin=$tin."::_tin";

    while (my ($key,$val)=each %$data) {
	my $stopper;
	my $oldval=$$rtin->{$key};
	if ($oldval && $val) {
	    ($val,$stopper)=_merge($oldval,$val);
	}
	_save_val($tin,$key,$val,$stopper);
    }
    return;
}

sub _merge {
    my ($oldval,$newval,$stopper)=@_;

    my $ref=ref($oldval);
    my $refnew=ref($newval);

    if ($ref eq "ARRAY" && $oldval->[0] eq $stop) {
	$oldval=$oldval->[1];
	$ref=ref($oldval);
	$stopper++;
    }

    if ($refnew eq "ARRAY" && $newval->[0] eq $stop) {
	$newval=$newval->[1];
	$refnew=ref($newval);
	$stopper++;
    }

    if (!$ref || $ref eq "SCALAR") {
	if ($refnew eq "SCALAR") {
	    $oldval=$newval;
	} else {
	    if ($ref eq "SCALAR") {
		my $v=$$oldval;
		$v.=$newval;
		$oldval=\$v;
	    } else {
		$oldval.=$newval;
	    }
	}
    } elsif ($ref eq "HASH") {
	if (!$refnew) {
	    $oldval={%$oldval,$newval};
	} elsif ($refnew eq "HASH") {
	    $oldval={%$oldval,%$newval};
	} else {
	    croak("type mismatch!");
	}
    } elsif ($ref eq "ARRAY") {
	if (!$refnew) {
	    push(@$oldval,$newval);
	} elsif ($refnew eq "ARRAY") {
	    push(@$oldval,@$newval);
	} else {
	    croak("type mismatch!");
	}
    } elsif ($ref eq "CODE") {
	croak("cannot append/merge code ref");
    }

    return ($oldval,$stopper);
}


sub get_classdata {
    my ($self,$key)=@_;
    my $package=ref($self) || $self;
    my $tin=__PACKAGE__."::".$package;

    my @vals=dispatch_to_all($tin,$key);
    return unless @vals;

    # peek at first val of @vals to decide data type
    my $ref=ref($vals[0]);

    # check if stoptin caused wrong ref
    if ($ref eq "ARRAY" && $vals[0]->[0] eq $stop) {
	$ref=ref($vals[0]->[1]);
    }

    $ref||="SCALAR";

    my $get='_get_'.$ref;
    my $return;
    no strict 'refs';
    foreach my $v (reverse @vals) {
	next unless $v;
	if (ref($v) eq "ARRAY" && $v->[0] eq $stop) {
	    $return=$get->(undef,$v->[1]);
#	    my $overwrite=$v->[1];
#	    if ($ref eq "ARRAY") {
#		$return=[];
#		push(@$return,@$overwrite);
#	    } else {
#		$return=$overwrite;
#	    }
	} else {
	    $return=$get->($return,$v);
	}
    }
    return $return;
}


sub _get_SCALAR {
    my ($ret,$val)=@_;
    my $r=ref($val);
    if (!$r) {
	$ret.=$val;
    } elsif ($r eq "SCALAR") {
	$ret=$$val;
    }
    return $ret;
}

sub _get_ARRAY {
    my ($ret,$val)=@_;
    push(@$ret,@$val);
    return $ret;
}

sub _get_HASH {
    my ($ret,$val)=@_;
    if (! defined $ret) {
	$ret=$val;
    } else {
	$ret={%$ret,%$val};
    }
    return $ret;
}

sub _get_CODE {
    my ($ret,$val)=@_;
    return $val;
}

1;

__END__