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} || {};