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<my> 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<GLOBAL VARIABLES> 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<GLOBAL VARIABLES> section
$Variable::Watcher::VERBOSE = 0;
=head1 DESCRIPTION
C<Variable::Watcher> allows you to keep track of mutations on C<my>
variables. It will record every mutation you do to a variable that
is being C<Watch>ed. 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<my>
variables in a state you did not expect.
See the C<CAVEATS> section for the limitations of this approach.
=head1 Attributes
=head2 my $var : Watch([NAME])
In order to start C<Watch>ing a variable, you must tag it as being
C<Watch>ed 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<STORE>, when you retrieved the
value (C<FETCH>) and when you stored the increment (C<STORE>).
=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<CLEAR>), and
extended it's size (C<EXTEND>) to fit your first assignment (C<STORE>),
followed by the C<PUSH> which adds another value to your list.
Then we attempt to remove the last value, showing us how perl fetches
its size (C<FETCHSIZE>) and C<POP>s 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<CLEAR>), and
C<STORE>d it's first key/value pair. Then we C<STORE> the second
key/value pair, followed by a C<DELETE> 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<Log::Message::Item> objects describing the
mutations of the C<Watch>ed variables.
The optional C<name> argument lets you filter based on the name you
have given the variables to be C<Watch>ed.
The optional C<action> argument lets you filter on the type of action
you want to retrieve (C<STORE> or C<FETCH>, etc).
Refer to the C<Log::Message> manpage for details on how to work with
C<Log::Message::Item> 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<stack> 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<stack> 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__
=head1 GLOBAL VARIABLES
=head2 $Variable::Watcher::REPORT_FH
This is the filehandle that all mutations are printed to. It defaults
to C<STDERR> but you can change it to any (open!) filehandle you wish.
=head2 $Variable::Watcher::VERBOSE
By default, all the mutation are printed to C<REPORT_FH> when they
occur. You can silence C<Variable::Watcher> by setting this variable to
C<false>. Note you will then have to retrieve mutation logs via the
C<stack> or C<stack_as_string> methods.
=head1 CAVEATS
This module can only operate on the three standard perl data types;
C<SCALAR>, C<ARRAY>, C<HASH>, and only C<Watch>es the first level of a
variable, but not nested ones; ie, a variable within a variable is not
C<Watch>ed.
=head1 AUTHOR
This module by
Jos Boumans E<lt>kane@cpan.orgE<gt>.
=head1 COPYRIGHT
This module is
copyright (c) 2005 Jos Boumans E<lt>kane@cpan.orgE<gt>.
All rights reserved.
This library is free software;
you may redistribute and/or modify it under the same
terms as Perl itself.
=cut
# Local variables:
# c-indentation-style: bsd
# c-basic-offset: 4
# indent-tabs-mode: nil
# End:
# vim: expandtab shiftwidth=4: