view release on metacpan or  search on metacpan

lib/Acme/AtIncPolice.pm  view on Meta::CPAN

package Acme::AtIncPolice;
use 5.008001;
use strict;
use warnings;
use Carp;

our $VERSION = "0.02";

BEGIN {
    use Tie::Trace qw/watch/;
    no warnings 'redefine';

    *Tie::Trace::_output_message = sub {
        my ($self, $class, $value, $args) = @_;
        if (!$value) {
            return;
        }

        my ($msg, @msg) = ('');

        my $caller    =  $self->{options}->{caller};
        my $_caller_n = 1;
        while (my $c = (caller $_caller_n)[0]) {
            if (not $c) {
                last;
            } elsif ($c  !~ /^Tie::Trace/) {
                last;
            }
            $_caller_n++;
        }

        my @caller = map $_ + $_caller_n, ref $caller ? @{$caller} : $caller;
        my(@filename, @line);
        foreach(@caller){
            my($f, $l) = (caller($_))[1, 2];
            next unless $f and $l;

            push @filename, $f;
            push @line, $l;

        }

        my $location = @line == 1 ? " at $filename[0] line $line[0]." :
                                    join "\n", map " at $filename[$_] line $line[$_].", (0 .. $#filename);
        my($_p, $p) = ($self, $self->parent);
        while($p){
            my $s_type = ref $p->{storage};
            my $s = $p->{storage};
            if($s_type eq 'HASH'){
                push @msg, "{$_p->{__key}}";
            }elsif($s_type eq 'ARRAY'){
                push @msg, "[$_p->{__point}]";
            }
            $_p = $p;
            last if ! ref $p or ! ($p = $p->parent);
        }
        $msg = @msg > 0 ? ' => ' . join "", reverse @msg : "";


        $value = '' unless defined $value;
        if ($class eq 'Scalar') {
            return("${msg} => $value$location");
        } elsif ($class eq 'Array') {
            unless(defined $args->{point}){
                $msg =~ s/^( => )(.+)$/$1\@\{$2\}/;
                return("$msg => $value$location");
            }else{
                return("${msg}[$args->{point}] => $value$location");
            }
        } elsif ($class eq 'Hash') {
            return("${msg}" . (! $self->{options}->{pkg} || @msg ? "" : " => "). "{$args->{key}} => $value$location");
        }
    };


    *Tie::Trace::_carpit = sub {
        my ($self, %args) = @_;
        return if $Tie::Trace::QUIET;
        
        my $class = (split /::/, ref $self)[2];
        my $op = $self->{options} || {};
        
        # key/value checking
        if ($op->{key} or $op->{value}) {
            my $key   = $self->_matching($self->{options}->{key},   $args{key});
            my $value = $self->_matching($self->{options}->{value}, $args{value});
            if (($args{key} and $op->{key}) and $op->{value}) {
                return unless $key or $value;
            } elsif($args{key} and $op->{key}) {
                return unless $key;
            } elsif($op->{value}) {
                return unless $value;
            }
        }
        
        # debug type
        my $value = $self->_debug_message($args{value}, $op->{debug}, $args{filter});
        # debug_value checking
        return unless $self->_matching($self->{options}->{debug_value}, $value);
        # use scalar/array/hash ?
        return unless grep lc($class) eq lc($_) , @{$op->{use}};
        # create warning message
        my $watch_msg = '';
        my $msg = $self->_output_message($class, $value, \%args);