File Coverage

blib/lib/Devel/Carnivore.pm

Criterion	Covered	Total	%
statement	96	107	89.7
branch	20	26	76.9
condition			n/a
subroutine	26	30	86.6
pod	0	5	0.0
total	142	168	84.5

package Devel::Carnivore;
use strict;
use 5.6.0;
use warnings;
use Carp;
use Attribute::Handlers;
no  warnings "redefine";

use vars qw/$OUT @EXPORT @ISA $NAME $VERSION/;

use base "Exporter";
@EXPORT = qw(watch unwatch);

$VERSION = 0.09;

# By default print to STDERR
$OUT = \*STDERR;

# test whether the first para is NOT a hashref
sub test_no_hashref($) {
	my($hashref) = @_;

	return if ref $hashref eq "HASH";                # normal hash ref: good

	if(ref $hashref) {
		local $@;
		eval '%{ $hashref }';
		return unless $@;                        # blessed hash: good
	}

	return 1;
}

# tie $hashref to Devel::Carnivore::Tie::Hash
# optionally specify a name
# for internal use: a custom carp level may be specified. look at Carp.pm for documentation
sub watch($;$) {
	my($hashref,$name) = @_;

	# this module only works with hashrefs
	croak "variable is not a hash reference" if test_no_hashref $hashref;

	my %copy = %$hashref; # make a copy of the actual hash in hashref

	my $calling_pkg = caller;

	croak "can't watch a variable which is already tied" if tied %$hashref;

	# print a comment that we start watching
	print $Devel::Carnivore::OUT "# variable is now under observation\n";

	tie %$hashref, 'Devel::Carnivore::Tie::Hash', $name;
	# %$hashref is now empty

	while(my($key,$value) = each %copy) { # but we restore the copy
		$hashref->{$key} = $value
	}
}

# untie $hashref
sub unwatch($) {
	my($hashref) = @_;

	if(test_no_hashref $hashref) { # of course this only works if $hashref is actually a hash reference
		carp "variable is not a hash reference"
	}
	elsif((tied %$hashref)->isa("Devel::Carnivore::Tie::Hash")) {
		no warnings; # silence "untie attempted while 1 inner references still exist" warning
		             # is there a better way to do this.
		             # as far as I can see this call is perfectly safe.
		untie %$hashref;
		print $Devel::Carnivore::OUT "# mission completed\n";
	} else {
		carp "Apparently this variable is not currently under observation."
	}
}

# install Watch as a universal attribute for hashes
# a name may be given as the single parameter to the attribute
# we then call our watch with the hashref and the name
sub UNIVERSAL::Watch : ATTR(HASH) {
	my ($package, $symbol, $hashref, $attr, $name, $phase) = @_;

	watch $hashref, $name
}

# install Watch as a universal attribute for scalars
# this scalar is then tied to the special class Devel::Carnivore::Tie::Scalar
# ....why the f*ck? ... oh, yeah, so we can automatically tie any hashref to
# Devel::Carnivore::Tie::Hash as soon as it is assigned to this scalar :)
sub UNIVERSAL::Watch : ATTR(SCALAR) {
	my ($package, $symbol, $scalar_ref, $attr, $name, $phase) = @_;

	tie $$scalar_ref, 'Devel::Carnivore::Tie::Scalar', $name
}

# utility class used by the Watch scalar attribute
package Devel::Carnivore::Tie::Scalar;
use Carp;
use Devel::Carnivore;

# save a scalar and a name with the tied scalar
sub TIESCALAR {
	my($class,$name) = @_;

	my $scalar = undef;

	my $self = {
		scalar => \$scalar,
		name   => $name,
	};

	bless $self, $class;
}

# only hashrefs or object based on hashrefs may be assigned to scalars based on this class
# these hashrefs are then immediately tied to Devel::Carnivore::Tie::Hash
sub STORE {
	my($self,$value) = @_;

	croak "You may only store hashrefs within a scalar under observation by Devel::Carnivore."
		if Devel::Carnivore::test_no_hashref($value);

	Devel::Carnivore::watch $value, $self->{name};

	${$self->{scalar}} = $value
}

sub FETCH   { ${$_[0]->{scalar}} }
sub DESTROY { undef ${$_[0]->{scalar}} }

package Devel::Carnivore::Tie::Hash;

# this is where the actual output is generated
sub STORE {
	my($self,$key,$value)     = @_;
	my($package,$filename,$line) = caller;

	my $hashref   = $self->{hash};
	my $name      = $self->{name};

	my $old_value = $hashref->{$key};

	$key       = defined $key       ? $key       : ""; # some stuff to limit warnings
	$value     = defined $value     ? $value     : "";
	$old_value = defined $old_value ? $old_value : "";

	my $message = "> "; # this is what will eventually get printed out

	$message .= qq{$name: } if defined $name; # we start out with a name if we have one

	# "myHashKey" changed from "someValue" to "someOtherValue"
	$message .= qq{"$key" changed from "$old_value" to "$value" };


	# $Carp::CarpLevel may be set to influence the output.
	# This sucks bad!!!. First, CarpLevel is deprecated but setting CarpInternal to our
	# caller does not seem to work, second, setting CarpLevel to 1 seems to be the right
	# thing but Perl 5.6.1 (and below???) doesnt like it.

	local $Carp::CarpLevel;
	if($] >= 5.008) {
		$Carp::CarpLevel = 1;
	}

	# we print this using a function available via the Carp module
	# it automatically adds information about where this method was called

	print $Devel::Carnivore::OUT Carp::shortmess($message);

	# ahh, and finally we behave like a normal hash.
	return $hashref->{$key} = $value;
}

# make an object with a hash and a name
sub TIEHASH  {
	my($class,$name) = @_;

	bless {
		hash => {},
		name => $name,
	}, $class
}

# copied from Tie::Hash, adapted to my object scheme
sub FETCH    { $_[0]->{hash}{$_[1]} }
sub FIRSTKEY { my $a = scalar keys %{$_[0]->{hash}}; each %{$_[0]->{hash}} }
sub NEXTKEY  { each %{$_[0]->{hash}} }
sub EXISTS   { exists $_[0]->{hash}{$_[1]} }
sub DELETE   { delete $_[0]->{hash}{$_[1]} }
sub CLEAR    { %{$_[0]->{hash}} = () }

q

__END__