File Coverage

blib/lib/Devel/StealthDebug.pm

Criterion	Covered	Total	%
statement	156	225	69.3
branch	39	56	69.6
condition	1	3	33.3
subroutine	20	34	58.8
pod	0	12	0.0
total	216	330	65.4

package Devel::StealthDebug;

require Exporter;
@ISA=qw(Exporter);

@EXPORT=();					# put the public function here
@EXPORT_OK=();				# to unable a non-stealth interface


use strict;
use Carp;
use Filter::Simple;

our $SOURCE	= 0;
our $VERSION	= '1.008'; 	# Beware ! 1.1.2 sould be 1.001002
our $TABLEN	= 2;
our $ENABLE	= 1;
our $DUMPER	= 0;

our $Emit	= 'carp';
our $Counter	= 1;

my %Wait_Cond;

sub import {
	shift;

	while (my $imported = shift) {
		if ($imported eq 'SOURCE') {
			my $file = shift;
			open SOURCE,"> $file";
			$SOURCE = 1;
		} elsif ($imported eq 'emit_type') {
			$Emit = shift;
			if ($Emit =~ m:/:) {
				my $tfh;
				open($tfh,">>$Emit") or die $!;	# replace filename by filehandle.
				select($tfh);$|++;
				$Emit=$tfh;
			}
		} elsif ($imported eq 'DUMPER') {
                    $DUMPER = shift ;
		} elsif ($imported eq 'ENABLE') {
			my $file_or_not = shift;

			$ENABLE = $file_or_not;				# By default assume it's a value

			if (-e $file_or_not) {				# If the file exists

				$ENABLE = 0;						# disable ENABLE

				open INFILE,"<$file_or_not" or croak "Can't open $file_or_not ($!)";
				while(my $authorized = ) {
					chomp $authorized;
					if ($0 =~ /$authorized/) {	# unless the file allows it.
						$ENABLE = 1; #  unless
						last;
					}
				}
				close INFILE;
			}
		} else {
			croak "Unknown $imported option ($imported @_)";
		}
	}
        if ($DUMPER) {
            require Data::Dumper ;
            $Data::Dumper::Indent = 1;
	    $Data::Dumper::Sortkeys = 1;
        }
}

sub emit {
	if ($Emit eq 'carp') {
		carp @_, ' in ' , (caller(1))[3] ;
	} elsif ($Emit eq 'croak') {
		croak @_, ' in ' , (caller(1))[3];
	} elsif ($Emit eq 'print') {
		print @_;
	} elsif (ref $Emit =~ /CODE/) {
		&$Emit(@_);
	} else {						# Otherwise it's a filehandle
		print $Emit @_;
	}
}

sub emit_type {
	my $orig = shift;
	my $emit = shift;

	if ($emit =~ /(carp|croak|print)/) {
		return "\$Devel::StealthDebug::Emit = $emit;$orig"
	}
}

sub add_assert {
	my $orig = shift;
	my $cond = my $cond2 = shift;

	$cond2   =~ s/\'/\\\'/g;
	return "die '($cond2) condition failed' if !($cond);$orig";
}

sub add_emit {
	my $orig = shift;
	my $text = shift;

	$text   =~ s/^"(.*)"$/$1/;
	$text   =~ s/\"/\\\"/g;
	return "$orig;Devel::StealthDebug::emit \"$text\";";
}

sub add_dump  {
	my $orig = shift;
	my $ref  = shift;

	$Counter++;

	my $output = $orig . ';$Data::Dumper::Sortkeys=1;Devel::StealthDebug::emit(';
	my @vars = split (/\s*,\s*/, $ref) ;
	my $i = 0 ;

        if ($DUMPER) {
            while ($vars[0] =~ /^\'|\"/) {
                $output .= (shift @vars) . (@vars?',':'') ;
            }
            $output .=  'Data::Dumper -> Dump ([' . join (',', @vars) . "],['" . join ("','", @vars) . "']));";
        } else {
	    	foreach my $var (@vars)	{
	        	$output .=  ($i++?',':'') . "'\$$var = ', Devel::StealthDebug::dumpvalue($var,-1)";
	    	}
            $output .=  ');' ;
        }
	return $output ;
}

sub dumpvalue {
	my $type 	= shift;
	my $tabn	= shift;

	my $ref     = ref $type;
	my $tab		= ' ' x ($tabn+1);
	my $output;
	$tabn		+= $TABLEN;

	if 			($type =~ /^($ref=)?HASH/) {
		$output = "{\n".dump_hash($type,$tabn,'')."$tab},\n";
	} elsif 	($type =~ /^($ref=)?ARRAY/) {
		$output = "[\n".dump_array($type,$tabn,'')."$tab],\n";
	} elsif 	($type =~ /^($ref=)?SCALAR/) {
		$output = dump_scalar($type,$tabn,'');
	} else {
		$output = dump_scalar($type,$tabn,'');
	}

	if (($tabn - $TABLEN) == -1) {
		$output =~ s/,$/;/s;
	}

	return $output;
}

sub dump_hash {
	my $var 	= shift;
	my $tabn 	= shift;
	my $output	= shift;

	my $tab 	 = " " x $tabn;
	#$output	.= "$tab\n";
	$tab 		.= " ";

	for my $elem (sort keys %$var) {
		if (ref $elem) {
			$output .= "$tab$elem => {"
		} else {
			$output .= "$tab'$elem' => ";
		}
		$output .= dumpvalue($var->{$elem},$tabn);
	}
	$output =~ s/\,$//s;	# To remove the last ',' from the list

	return $output;
}

sub dump_scalar {
	my $scalar 	= shift;
	my $tabn 	= shift;
	my $output	= shift;

	if ($scalar !~ /\d+/) { $scalar = "'$scalar'" }

	$output		.= "$scalar,\n";

	return $output;
}

sub dump_array {
	my $var 	= shift;
	my $tabn 	= shift;
	my $output	= shift;

	my $i;

	my $tab 	 = " " x $tabn;
	#$output 	.= "$tab\n";
	#$output 	.= "$tab";
	$tab		.= " ";

	for my $elem (@$var) {
		$output .= $tab;
		#$output .= $i++;
		#$output .= " => ";
		$output .= dumpvalue($elem,$tabn);
	}
	$output =~ s/\,$//s;	# To remove the last ',' from the list

	return $output;
}

sub add_when {
	my $orig    = shift;
	my $var		= shift;
	my $op  	= shift;
	my $value	= shift;

	push @{$Wait_Cond{$var}},[$op,$value];
	return "$orig";
}

sub add_watch {
	my $orig    = shift;
	my $var     = my $var2 = shift;

	$var2	    =~ s/[\$\@\%]//;

	my ($pre,$post,$init);

	if ($orig =~ /\s*my\s*[\@\$\%]/) {
		$pre  = $orig;
		$pre  =~ s/(\s*my\s*[\@\$\%]$var2).*/$1;/i;
	}

	if ($orig =~ /(=|\+\+|--)/) {
		$post = $orig;
		$post =~ s/.*([\@\$\%]$var2)/$1/si;
	}

	$init = ",\\$var" if (!$pre && !$post) ;

	return "$pre tie $var,'Devel::StealthDebug','$var'$init;$post";
}

sub check_when_cond {
	my $object = shift;
	my $value  = shift;
	my $index  = shift;

	my $ok;
	for my $cond (@{$Wait_Cond{$object->{name}}}) {
		{
			local ($@, $!);
			$ok = eval "\$object->{value} $$cond[0] $$cond[1]";
		}

		if ($ok) {
				emit "$object->{name}$$cond[0]$$cond[1] !";
		}
	}
}

FILTER {
	#
	# Make it consistent and CLEAN !
	# (Of course if it could work...)
	#
	# Should we really forbid pure comment lines
	#
	if ($ENABLE) {
   	s/^([^#]*?)(#.*?!assert\((.+?)\)!)/add_assert($1,$3)/meg;
 	s/^([^#]*?)(#.*?!watch\((.+?)\)!)/add_watch($1,$3)/meg;
 	s/^([^#]*?)(#.*?!emit\((.+?)\)!)/add_emit($1,$3)/meg;
 	s/^([^#]*?)(#.*?!dump\((.+?)\)!)/add_dump($1,$3)/meg;
 	s/^([^#]*?)(#.*?!when\((.+?),(.+?),(.+?)\)!)/add_when($1,$3,$4,$5)/meg;
 	s/^([^#]*?)(#.*?!emit_type\((.+?)\)!)/emit_type($1,$3)/meg;
	}
	if ($SOURCE)	{ print SOURCE  "$_\n" }  ;
	#s/(.)/$1/mg;
};

sub TIESCALAR {
	my $class	= shift;
	my $name	= shift;
    my $value	= shift;
	my %object;

	$object{name}=$name;
	$object{value}=$$value if ($value) ;
	bless \%object,$class;
}

sub FETCH {
	my $object = shift;
	my $index  = shift;

	if ($object->{name} =~ /^\@/) {
		carp  "FETCH ($object->{name}\[$index\] -> ",$object->{value}[$index],")";
		return $object->{value}[$index];
	} elsif ($object->{name} =~ /^\$/) {
		carp  "FETCH ($object->{name} -> ",$object->{value},")";
		return $object->{value};
	} elsif ($object->{name} =~ /^\%/) {
		carp  "FETCH ($object->{name}\{$index\} -> ",$object->{value}{$index},")";
		return $object->{value}{$index};
	} else {
		carp  "Strange FETCH"
	}
}

sub FETCHSIZE {
	my $object = shift;
	my $value  = shift;

	$#{$object->{value}}=$value;
	carp  "FETCHSIZE ($object->{name})($value)";
}

sub STORE {
	my $object = shift;
	my $value  = pop;
	my $index  = shift;

	if ($object->{name} =~ /^\@/) {
		$object->{value}[$index]=$value;
		check_when_cond($object,$value,$index);
		carp "STORE ($object->{name}\[$index\] <- $object->{value}[$index])";
		return $object->{value}[$index];
	} elsif ($object->{name} =~ /^\$/) {
		$object->{value}=$value;
		check_when_cond($object,$value,$index);
		carp "STORE ($object->{name} <- $object->{value})";
		return $object->{value};
	} elsif ($object->{name} =~ /^\%/) {
		$object->{value}{$index}=$value;
		check_when_cond($object,$value,$index);
		carp "STORE ($object->{name}\{$index\} <- $object->{value}{$index})";
		return $object->{value}{$index};
	}
}

sub CLEAR {
	my $object = shift;

	$object->{value}=[];
	carp "CLEAR ($object->{name})";
}

sub TIEARRAY {
	my $class	= shift;
	my $name 	= shift;
	my $value	= shift;
	my %object;

	$object{name} = $name;
	$object{value}= $value?$value:[];
	bless \%object,$class;
}

sub TIEHASH {
	my $class	= shift;
	my $name 	= shift;
	my $value	= shift;
	my %object;

	$object{name} = $name;
	$object{value}= $value?$value:{};
	bless \%object,$class;
}

sub DELETE {
	my $object	= shift;
	my $key 	= shift;

	delete $object->{value}{$key};
	carp "DELETE ($object->{name})($key)";
}

sub EXISTS {
	my $object	= shift;
	my $key 	= shift;;

	carp "EXISTS ($object->{name})($key)";

	return 0	if $object->{value}{$key};
	return 1;
}

sub FIRSTKEY {
	my $object		= shift;
	my $toreseteach	= keys %{$object->{value}};

	$object->{lastkey} = each %{$object->{value}};
	carp "FIRSTKEY ($object->{name})(",$object->{lastkey},")";
	return $object->{lastkey}
}

sub NEXTKEY {
	my $object	= shift;
	my $key		= shift;
	my $lastkey = shift;

	carp "NEXTKEY ($object->{name})($key)($lastkey)";
	return each %{$object->{value}}
}

sub DESTROY {
	my $object = shift;

	carp "DESTROY ($object->{name})";
}


sub STORESIZE {
	my $object	= shift;
	my $count 	= shift;

	carp "STORESIZE ($object)($count)";
}

sub PUSH {
	my $object = shift;
	my @list   = @_;

	push @{$object->{value}},@list;
	carp "PUSH ($object)(@list)";
}

sub POP {
	my $object	= shift;
	my $value	= pop  @{$object->{value}};

	carp "POP ($object)($value)";
}

sub SHIFT {
	my $object	= shift;
	my $value	= shift  @{$object->{value}};

	carp "SHIFT ($object)($value)";
}

sub UNSHIFT {
	my $object  = shift;
	my @list	= @_;

	unshift  @{$object->{value}},@list;
	carp "SHIFT ($object)(@list)";
}

sub SPLICE {
	my $object	= shift;
	my $offset	= shift;
	my $length	= shift;
	my @list	= @_;

	return splice @{$object->{value}},$offset,$length,@list
}

sub EXTEND {
	my $object = shift;
	my $count  = shift;

	# Nothing to do ?
	carp "EXTEND (",$object->STORESIZE,")";
}

1;

__END__