File Coverage

blib/lib/Code/Explain.pm

Criterion	Covered	Total	%
statement	69	69	100.0
branch	34	34	100.0
condition			n/a
subroutine	10	10	100.0
pod	0	6	0.0
total	113	119	94.9

package Code::Explain;
use 5.008;
use strict;
use warnings;

use Carp qw(croak);

our $VERSION = '0.02';

sub new {
	my ($class, %args) = @_;
	my $self = bless {}, $class;

	$self->{code} = $args{code}
		or croak('Method ->new needs a "code" => $some_code pair');

	return $self
}

sub code { return $_[0]->{code} };

sub explain {
	my ($self, $code) = @_;

	# TODO we will maintain a database of exact matches
	my %exact = (
		'$_'    => 'Default variable',
		'@_'    => 'Default array',
		'given' => 'keyword in perl 5.10',
		'say'   => 'keyword in perl 5.10',
		'!!'    => 'Creating boolean context by negating the value on the right hand side twice',
	);

	$code = $self->code if not defined $code;
	if ($exact{$code}) {
		return $exact{$code};
	}

	# parentheses after the name of a subroutine
	if ($code =~ /^(\w+)\(\)$/) {
		my $sub = $1;
		if ($exact{$sub}) {
			return $exact{$sub};
		}
	}

	# '' .
	if ($code =~ m{^'' \s* \.$}x) {
		return 'Forcing string context';
	}

	# 0 +
	if ($code =~ m{^0 \s* \+$}x) {
		return 'Forcing numeric context';
	}

	my $NUMBER = qr{\d+(?:\.\d+)?};

	# 2 + 3
	if ($code =~ m{^$NUMBER \s* [/*+-]  \s* $NUMBER$}x) {
		return 'Numerical operation';
	}

	# 2
	# 2.34
	if ($code =~ /^$NUMBER$/) {
		return 'A number';
	}

	# 23_145
	if ($code =~ /^\d+(_\d\d\d)+$/) {
		return 'This is the same as the number ' . eval($code) . ' just in a more readable format';
	}

	# $_[2], $_[$var], $name[42]
	if ($code =~ /\$(\w+)\[(.*?)\]/) {
		if ($1 eq '_') {
			return "This is element $2 of the default array \@_";
		} else {
			return "This is element $2 of the array \@$1";
		}
	}

	# $phone{$name}
	if ($code =~ m{^\$(\w+)    \{  \$(\w+) \}  }x) {
		my ($hash_name, $key_name) = ($1, $2);
		return "The element \$$key_name of the hash \%$hash_name";
	}

	# $$x
	if ($code =~/^\$\$(\w+)$/) {
		return "\$$1 is a reference to a scalar value. This expression dereferences it. See perlref";
	}

	# $x ||= $y
	if ($code  =~ m{^\$(\w+) \s*  \|\|= \s* \$(\w+)$}x) {
		my $lhs = $1;
		return "Assigning default value to \$$lhs. It has the disadvantage of not allowing \$$lhs=0. Startin from 5.10 you can use //= instead of ||=";
	}

	# $self->editor
	if ($code =~ m{^\$(\w+)   ->   (\w+)}x) {
		my ($obj_name, $method) = ($1, $2);
		return "Calling method '$method' on an object in the variable called \$$obj_name",
	}

	return "Not found";
}

sub ppi_dump {
	my ($self) = @_;

	require PPI::Dumper;
	my $dumper = PPI::Dumper->new( $self->ppi_document );
	return $dumper->list;
}

sub ppi_explain {
	my ($self) = @_;

	my $document = $self->ppi_document;

	my @result;
	foreach my $token ( $document->tokens ) {
		push @result, {
			code => $token->content,
			text => $self->explain($token->content),
		};
	}
	return @result;
}

sub ppi_document {
	my ($self) = @_;

	if (not $self->{ppi_document}) {
		require PPI::Document;
		my $code = $self->code;
		$self->{ppi_document} = PPI::Document->new(\$code);
#		$self->{ppi_document}->index_locations;
	}

	return $self->{ppi_document};
}


=head1 NAME

Code::Explain - Try to explain what $ @ % & * and the rest mean

=head1 SYNOPSIS


   my $ce = Code::Explain->new;
   $str = '$x ||= $y';
   print $ce->explain($str), "\n";

or

   @ppi_dump = $ce->ppi_dump($str);

=head1 COMMAND LINE

The module comes with a command line tool called

   explain-code

You give a perl expression to it and it will give an explanation
what that might be.


=head1 COMMAND LINE OPTIONS

One of the following:

   --explain     Try to exaplain our way
   --ppidump     Run PPI on the code and print the dump
   --ppiexplain  Run PPI on the code and try to explain the individual tokens
   --all         All of the above

   --help        Prints the list of command line options


=head1 DESCRIPTION

This is pre-alpha version (whatever that means) of the code
explain tool. It should be able to understand various perl
constructs such as.


    $x ||=  $y;

    @data = map { ... } sort { ... } grep { ... } @data;

give a short explanation and reasonable pointers to the documentation.

See the t/cases.txt file more cases that are already handled.
Add further cases to t/todo.txt, preferably with some explanation.

=head1 AUTHOR

Gabor Szabo L

=head1 COPYRIGHT and LICENSE

This software is copyright (c) 2011 by Gabor Szabo.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

1;