view release on metacpan or  search on metacpan

lib/Tie/Trace.pm  view on Meta::CPAN

package Tie::Trace;

use strict;
use warnings;
use PadWalker ();
use Tie::Hash ();
use Tie::Array ();
use Tie::Scalar ();
use Carp ();
use Data::Dumper ();
use base qw/Exporter/;

use constant {
  SCALAR    => 0,
  SCALARREF => 1,
  ARRAYREF  => 2,
  HASHREF   => 4,
  BLESSED   => 8,
  TIED      => 16,
  };

our @EXPORT_OK  = ('watch');
our %EXPORT_TAGS = (all => \@EXPORT_OK);

our %OPTIONS = (debug => 'dumper');
our $QUIET   = 0;

our $AUTOLOAD;

sub AUTOLOAD{
  # proxy to Tie::Std***
  my($self, @args) = @_;
  my($class, $method) = (split /::/, $AUTOLOAD)[2, 3];
  my $sub = \&{'Tie::Std' . $class . '::' . $method};
  defined &$sub ? $sub->($self->{storage}, @args) : return;
}

sub TIEHASH  { Tie::Trace::_tieit({}, @_); }
sub TIEARRAY { Tie::Trace::_tieit([], @_); }
sub TIESCALAR{ my $tmp; Tie::Trace::_tieit(\$tmp, @_); }

sub watch(\[$@%]@){
  my $s  = shift;
  my $s_type = ref $s;
  my $s_ = $s;

  if($s_type eq 'SCALAR'){
    $s_ = $$s;
  }elsif($s_type eq 'ARRAY'){
    $s_ = [ @$s ];
  }elsif($s_type eq 'HASH'){
    $s_ = { %$s };
  }

  Carp::croak("must pass one argument.") unless $s;
  my @options = @_;
  my $var_name;
  eval{
    $var_name = PadWalker::var_name(1, $s);
  };
  my $pkg = defined $var_name ? (caller)[0] : undef;
  my $tied_value = tie $s_type eq 'SCALAR' ? $$s : $s_type eq 'ARRAY' ? @$s : %$s, "Tie::Trace", var => $var_name, pkg => $pkg, @options;
  local $QUIET = 1;

  if($s_type eq 'SCALAR'){
    $$s = $s_;
  }elsif($s_type eq 'ARRAY'){
    @$s = @$s_ if @$s_;
  }elsif($s_type eq 'HASH'){
    %$s = %$s_ if %$s_;
  }
  return $tied_value;
}

sub _dumper{
  my($self, $value) = @_;
  local $Data::Dumper::Terse   = 1;
  local $Data::Dumper::Indent  = 0;
  local $Data::Dumper::Deparse = 1;
  $value = Data::Dumper::Dumper($value);
}

sub storage{
  my($self) = @_;
  return $self->{storage};
}

sub parent{
  my($self) = @_;
  return $self->{parent};
}

sub _match{
  my($self, $test, $value) = @_;
  if(ref $test eq 'Regexp'){
    return $value =~ $_;
  }elsif(ref $test eq 'CODE'){
    return $test->($self, $value);
  }else{
    return $test eq $value;
  }
  return;
}

sub _matching{
  my($self, $test, $tested) = @_;
  return 1 unless $test;
  if($tested){
    return 1 if grep $self->_match($_, $tested), @$test;
  }
  return 0;
}

sub _carpit{
  my($self, %args) = @_;
  return if $QUIET;

  my $class = (split /::/, ref $self)[2];
  my $op = $self->{options} || {};

  # key/value checking

lib/Tie/Trace.pm  view on Meta::CPAN

use warnings;
use strict;

use base qw/Tie::Trace/;

sub STORE{
  my($self, $key, $value) = @_;
  $self->_carpit(key => $key, value => $value)  unless $QUIET;
  local $QUIET = 1;
  Tie::Trace::_data_filter($value, $self, {__key => $key});
  $self->{storage}->{$key} = $value;
};

sub DELETE {
  my($self, $key) = @_;
  my $deleted = delete $self->{storage}->{$key};
  $self->_carpit(key => $key,
                 value => sprintf("DELETED(%s)", $self->_dumper(defined $deleted ? $deleted : 'undef')),
                 filter => sub{$_[0] =~ s/^\'(.+)\'$/$1/; $_[0] =~s /\\'/'/g}
                )  unless $QUIET;
  return $deleted;
}

sub CLEAR{
  my($self) = @_;
  return $self->Tie::Hash::CLEAR;
}

# Array /////////////////////////
package
 Tie::Trace::Array;

use warnings;
use strict;

use base qw/Tie::Trace/;

sub STORE{
  my($self, $p, $value) = @_;
  $self->_carpit(point => $p, value => $value)  unless $QUIET;
  local $QUIET = 1;
  Tie::Trace::_data_filter($value, $self, {__point => $p});
  $self->{storage}->[$p] = $value;
}

sub DELETE{
  my($self, $p) = @_;
  my $deleted = delete ${$self->{storage}}[$p];
  $self->_carpit(point => $p,
                 value => sprintf("DELETED(%s)", $self->_dumper(defined $deleted ? $deleted : "undef")),
                 filter => sub{$_[0] =~ s/^\'(.*)\'$/$1/; $_[0] =~s /\\'/'/g}
                )  unless $QUIET;
  return $deleted;
}

sub SPLICE{
  my $self  = shift;
  my $sz  = @{$self->{storage}};
  my $off = @_ ? shift : 0;
  my $fetchsize = $self->FETCHSIZE;
  my $caller_pkg = (caller)[0];
  my $func = "";
  if($caller_pkg eq "Tie::Trace::Array"){
    $func = (caller 1)[3];
    $func =~s/^Tie::Trace::Array:://;
  }
  $off   += $sz if $off < 0;
  my $len = @_ ? shift : $sz - $off;
  my $to  = $off + $len -1;
  my $p = $off eq $to ? $off : $off < $to ? "$off .. $to" : $off;
  my @point = ($func and $func ne 'STORESIZE') ? () : (point => $p);
  $self->_carpit(@point, value => \@_, filter => sub {$_[0] =~ s/^\[(.*)\]$/$func\($1\)/} )  unless $QUIET;
  local $QUIET = 1;
  if(@_){
    my $cnt = 0;
    foreach(@_){
      Tie::Trace::_data_filter($_, $self, {__point => $off + $cnt++});
    }
  }
  my $ret = splice(@{$self->{storage}}, $off, $len, @_);
  if(@_ != $len){
    my $diff = scalar @_ - $len;
    local $QUIET = 1;
    for(my $i = 0;$i < @{$self->{storage}}; $i++){
      my $value = $self->{storage}->[$i];
      Tie::Trace::_data_filter($value, $self, {__point => $i});
      $self->{storage}->[$i] = $value;
    }
  }
  return $ret;
}

sub FETCHSIZE{
  my($self) = shift;
  return scalar @{$self->{storage} ||= []};
}

sub PUSH{
  my($self, @value) = @_;
  return $self->SPLICE($self->FETCHSIZE, 0, @value);
}

sub UNSHIFT{
  my($self, @value) = @_;
  return $self->SPLICE(0, 0, @value);
}

sub POP{
  my($self) = @_;
  return $self->SPLICE(-1);
}

sub SHIFT{
  my($self) = @_;
  return $self->SPLICE(0, 1);
}

sub STORESIZE {
  my ($self, $p) = @_;
  $self->SPLICE($p, $self->FETCHSIZE - $p);
  return undef;