File Coverage

lib/Variable/Watcher.pm

Criterion	Covered	Total	%
statement	104	104	100.0
branch	21	24	87.5
condition	1	3	33.3
subroutine	23	23	100.0
pod	4	5	80.0
total	153	159	96.2

package Variable::Watcher;

require v5.6.0;

use strict;
use vars qw[$VERSION $AUTOLOAD $REPORT_FH $TRACE $VERBOSE];

use Attribute::Handlers;
use Carp;
use Data::Dumper;
use Log::Message    private => 1;
use Params::Check   qw[check allow];

use Tie::Scalar;
use Tie::Array;
use Tie::Hash;

$VERSION        = '0.01';
$VERBOSE        = 1;
$TRACE          = 1;

### file handles to print to
local $| = 1;
$REPORT_FH  = \*STDERR;

### list of names to use for the variables we're watching
my %Names   = ();

### log::message object to store actions in
my $Log     = new Log::Message;

### list of mappings of bless classes to tie classes
my %Map = (
    SCALAR  => 'Tie::StdScalar',
    ARRAY   => 'Tie::StdArray',
    HASH    => 'Tie::StdHash',
);


### add ourselves to the callers @INC, so we can use attributes that
### that are inherited.
sub import {
    my $self    = shift;
    my $class   = [caller]->[0];

    {   no strict 'refs';
        push @{"${class}::ISA"}, __PACKAGE__;
    }
}

=head1 NAME

Variable::Watcher -- Keep track of changes on C variables

=head1 SYNOPSIS

    ### keep track of scalar changes
    my $scalar : Watch(s) = 1;

    ### keep track of array changes
    my @list : Watch(l) = (1);

    ### keep track of hash changes
    my %hash : Watch(h) = (1 => 2);


    ### retrieve individual mutations:
    my @stack = Variable::Watcher->stack;

    ### retrieve the mutation as a printable string
    my $string = Variable::Watcher->stack_as_string;

    ### flush the logs of all the mutations so far
    Variable::Watcher->flush;

    ### Set the default reporting filehandle (defaults to STDERR
    ### -- see the C section
    $Variable::Watcher::REPORT_FH = \*MY_FH;

    ### Make Variable::Watcher not print to REPORT_FH when running
    ### You will have to use the stack/stack_as_string method to
    ### retrieve the logs. See the C section
    $Variable::Watcher::VERBOSE = 0;


=head1 DESCRIPTION

C allows you to keep track of mutations on C
variables. It will record every mutation you do to a variable that
is being Ced. You can retrieve these mutations as a list or
as a big printable string, filtered by a regex if you like.

This is a useful debugging tool when you find your C
variables in a state you did not expect.

See the C section for the limitations of this approach.

=head1 Attributes

=head2 my $var : Watch([NAME])

In order to start Cing a variable, you must tag it as being
Ced at declaration time. You can optionally give it a name
to be used in the logs, rather than it's memory address (this is much
recommended).

You can do this for perls three basic variable types;

=over 4

=item SCALAR

To keep track of a scalar, and it's mutations, you could for example,
do somethign like this:

    my $scalar : Watch(s) = 1;
    $scalar++;


The resulting output would be much like this:

   [Variable::Watcher s -> STORE] Performing 'STORE' on s passing
   '1' at z.pl line 6
   [Variable::Watcher s -> FETCH] Performing 'FETCH' on s at z.pl
   line 7
   [Variable::Watcher s -> STORE] Performing 'STORE' on s passing
   '2' at z.pl line 7

Showing you when you did the first C, when you retrieved the
value (C) and when you stored the increment (C).

=item ARRAY

To keep track of an array, and it's mutation, you could for example,
do something like this:

    my @list : Watch(l) = (1);
    push @list, 2;
    pop @list;

The resulting output would be much like this:

   [Variable::Watcher l -> CLEAR] Performing 'CLEAR' on l at z2.pl
   line 6
   [Variable::Watcher l -> EXTEND] Performing 'EXTEND' on l
   passing '1' at z2.pl line 6
   [Variable::Watcher l -> STORE] Performing 'STORE' on l passing
   '0 1' at z2.pl line 6
   [Variable::Watcher l -> PUSH] Performing 'PUSH' on l passing
   '2' at z2.pl line 7
   [Variable::Watcher l -> FETCHSIZE] Performing 'FETCHSIZE' on l
   at z2.pl line 7
   [Variable::Watcher l -> POP] Performing 'POP' on l at z2.pl
   line 8

Showing you that you initialized an empty array (C), and
extended it's size (C) to fit your first assignment (C),
followed by the C which adds another value to your list.
Then we attempt to remove the last value, showing us how perl fetches
its size (C) and Cs the last value off.

=item HASH

To keep track of a hash, and it's mutation, you could for example,
do something like this:

    my %hash : Watch(h) = (1 => 2);
    $hash{3} = 4;
    delete $hash{3};

The resulting output would be much like this:

   [Variable::Watcher h -> CLEAR] Performing 'CLEAR' on h at z3.pl
   line 6
   [Variable::Watcher h -> STORE] Performing 'STORE' on h passing
   '1 2' at z3.pl line 6
   [Variable::Watcher h -> STORE] Performing 'STORE' on h passing
   '3 4' at z3.pl line 7
   [Variable::Watcher h -> DELETE] Performing 'DELETE' on h
   passing '3' at z3.pl line 8

Showing you that you initialized an empty hash (C), and
Cd it's first key/value pair. Then we C the second
key/value pair, followed by a C of the key C<3>.

=cut

sub Watch : ATTR {
    my ($package, $symbol, $ref, $attr, $data, $phase) = @_;
    my $reftype = ref $ref;

    my $obj;
    ### do we support this type of ref?
    unless( $Map{ $reftype } ) {

        ### report from the callers perspective, not from attribute.pm
        ### or attribute::handlers perspective
        local $Carp::CarpLevel += 2;

        carp("Cannot watch variable of type: '$reftype'" );
        return;

    ### if so, tie it to the appropriate class
    ### note that '$ref' is not the same as '$obj'!
    } elsif ( $reftype eq 'SCALAR' ) {
        tie $$ref, __PACKAGE__ .'::'. $reftype;
        $obj = tied $$ref;

    } elsif ( $reftype eq 'ARRAY' ) {
        tie @$ref, __PACKAGE__ .'::'. $reftype;
        $obj = tied @$ref;

    } elsif ( $reftype eq 'HASH' ) {
        tie %$ref,  __PACKAGE__ .'::'. $reftype;
        $obj = tied %$ref;
    }

    ### store the name which we will call this variable in the
    ### pretty print output
    $Names{ $obj } = ($data || "$obj");

    return 1;
}

sub AUTOLOAD {
    my $self = shift;
    my $ref  = tied $self;

    ### figure out the method called, and the class we're
    ### blessed into
    my ($class,$method) = $AUTOLOAD =~ /::([^:]+)::([^:]+)$/;

    ### XXX we won't have a name yet at TIEFOO stage, but don't
    ### bother reporting that either
    if( my $name = $Names{ $self } ) {
        my $msg = "Performing '$method' on $name";
        $msg .= " passing '@_'" if @_;

        ### skip the call frames that are private to this module
        local $Carp::CarpLevel += 1;

        $Log->store(
                message => Carp::shortmess($msg),
                tag     => __PACKAGE__ . " $name -> $method",
                level   => 'report',
                extra   => [@_]
        );
    }

    ### get the coderef to the correpsonding function in
    ### the tie class
    my $func = $Map{$class}->can( $method );

    ### called the tie function, with ourselves as primary
    ### argument, and the rest of the args after that
    $func->($self, @_);
}


### tie packages, which inherit straight from base
{   package Variable::Watcher::SCALAR;
    use base 'Variable::Watcher';

    package Variable::Watcher::ARRAY;
    use base 'Variable::Watcher';

    package Variable::Watcher::HASH;
    use base 'Variable::Watcher';
}

=pod

=head1 CLASS METHODS

=head2 @stack = Variable::Watcher->stack( [name => $name, action => $action] );

Retrieves a list of C objects describing the
mutations of the Ced variables.

The optional C argument lets you filter based on the name you
have given the variables to be Ced.

The optional C argument lets you filter on the type of action
you want to retrieve (C or C, etc).

Refer to the C manpage for details on how to work with
C objects.

=cut

### report stack retrieval and manipulation
sub stack {
    my $self = shift;
    my %hash = @_;

    my($name,$action);
    my $tmpl = {
        name    => { default => '', store => \$name },
        action  => { default => '', store => \$action },
    };

    check( $tmpl, \%hash ) or return;

    my @rv;
    my $re = __PACKAGE__ . '\s(.+?)\s->\s(.+?)$';

    for my $item ( $Log->retrieve( chrono => 1 ) ) {
        my ($tagname,$tagaction) = $item->tag =~ /$re/;

        ### you want to do name based retrieving?
        if( $name ) {
            next unless allow( $tagname, $name );
        }

        ### you want to do action based retrieving?
        if( $action ) {
            next unless allow( $tagaction, $action);
        }

        push @rv, $item;
    }

    return @rv;
}

=head2 $string = Variable::Watcher->stack_as_string( [name => $name, action => $action] );

Returns the mutation log as a printable string, optionally filterd on
the criteria as described in the C method.

=cut

sub stack_as_string {
    my $class = shift;
    my @stack = $class->stack( @_ );

    return join '', map {
                    '[' . $_->tag . '] ' . $_->message;
                } @stack
}

=head2 @stack = Variable::Watcher->flush;

Flushes the logs of all mutations that have occurred so far. Returns
the stack, like the C method would, without filtering.

=cut


sub flush {
    return reverse $Log->flush;
}

### the function that pretty prints the actions performed on variables
{   package Log::Message::Handlers;
    use Carp ();

    sub report {
        my $self    = shift;

        ### so you don't want us to print the msg? ###
        return unless $Variable::Watcher::VERBOSE;

        ### store the old filehandle, select the one the user wants us
        ### to print to
        my $old_fh = select $Variable::Watcher::REPORT_FH;
        print '['. $self->tag (). '] ' . $self->message;

        ### restore the old filehandle
        select $old_fh;

        return;
    }
}

1;

__END__