#-----------------------------------------------------------------
# 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 domm@zsi.at 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) n
+e "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 easi
+er
   # 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::T
+IN
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::T
+IN
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::T
+IN
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__

for docs etc see CPAN

[download]

In reply to Class::Data::TIN by domm

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.