File Coverage

blib/lib/Tie/Static.pm

Criterion	Covered	Total	%
statement	30	57	52.6
branch	3	28	10.7
condition	6	18	33.3
subroutine	10	13	76.9
pod	0	3	0.0
total	49	119	41.1

package Tie::Static;

use Exporter;
@EXPORT_OK = 'static';
@ISA = 'Exporter';
$VERSION = 0.04;

use strict;
use vars qw(%call_count);
use Carp;

sub static {
  my $call = join "|", caller();

  if ($call_count{$call}) {
    tie_all($call, @_);
  }
  else {
    my @init = map {
      (ref($_) eq "SCALAR" or ref($_) eq "REF") ? $$_
        : (ref($_) eq "ARRAY") ? [@$_]
        : (ref($_) eq "HASH") ? { %$_ }
        : bad_ref($_);
    } @_;

    tie_all($call, @_);

    foreach my $to_replace(@_) {
      my $saved = shift @init;
      if (ref($to_replace) eq "SCALAR" or ref($to_replace) eq "REF") {
        $$to_replace = $saved;
      }
      elsif (ref($to_replace) eq "ARRAY") {
        @$to_replace = @$saved;
      }
      elsif (ref($to_replace) eq "HASH") {
        %$to_replace = %$saved;
      }
      else {
        $Carp::Verbose = 1;
        bad_ref($to_replace);
      }
    }
  }

  return $call_count{$call}++;
}

# The first argument is the value of $called to use, the
# rest are references to the variables to tie.  It ties
# the variables to the appropriate static.
sub tie_all {
  my $call = shift;
  my $uniq = 0;
  for (@_) {
    if (ref($_) eq "SCALAR" or ref($_) eq "REF") {
      tie ($$_, 'Tie::Static::Scalar', $call, $uniq++);
    }
    elsif (ref($_) eq "ARRAY") {
      tie (@$_, 'Tie::Static::Array', $call, $uniq++);
    }
    elsif (ref($_) eq "HASH") {
      tie (%$_, 'Tie::Static::Hash', $call, $uniq++);
    }
    else {
      bad_ref($_);
    }
  }
}

# Message for a bad reference in the argument.
sub bad_ref {
  my $thing = shift;
  if (my $ref = ref($thing)) {
    croak("Cannot create static of unknown type $ref");
  }
  else {
    croak("Arguments to static must be references!");
  }
}

# Implement the ties
foreach my $type (qw(Hash Array Scalar)) {
  my $meth = uc($type);
  my $pack = "Tie::Static::$type";
  eval qq(
    package $pack;
    require Tie::$type;
    \@$pack\::ISA = 'Tie::Std$type';

    sub TIE$meth {
      my \$class = shift;
      my \$call = join "|", \@_ ? \@_ : caller();
      return \$$pack\::preserved{\$call}
        ||= \$class->SUPER::TIE$meth();
    }

    sub Tie::Static::TIE$meth {
      shift;
      unshift \@_, 'Tie::Static::$type';
      goto &$pack\::TIE$meth;
    }

  ) or die $@;
}

1;

__END__