File Coverage

blib/lib/Devel/FIXME.pm

Criterion	Covered	Total	%
statement	97	109	88.9
branch	32	48	66.6
condition	22	33	66.6
subroutine	20	20	100.0
pod	1	8	12.5
total	172	218	78.9

#!/usr/bin/perl

package Devel::FIXME;
use fields qw/text line file package script time/;

use 5.008_000; # needs open to work on scalar ref

use strict;
use warnings;

use Exporter;
use Scalar::Util qw/reftype/;
use List::Util qw/first/;
use Carp qw/carp croak/;

our @EXPORT_OK = qw/FIXME SHOUT DROP CONT/;
our %EXPORT_TAGS = ( "constants" => \@EXPORT_OK );

our $VERSION = 0.01;

# some constants for rules
sub CONT () { 0 };
sub SHOUT () { 1 };
sub DROP () { 2 };

our $REPAIR_INC = undef; # do not "repair" @INC by default

my %lock; # to prevent recursion
our %rets; # return value cache
our $cur; # the current file, used in an eval
our $err; # the current error, for rethrowal
our $inited; # whether the code ref was installed in @INC, and all

{ my $anon = ''; open my $fh, "<", \$anon or die $!; close $fh; } # otherwise perlio require stuff breaks

sub init {
	my $pkg = shift;
	unless($inited){
		$pkg->readfile($_) for ($0, sort grep { $_ ne __FILE__ } (values %INC)); # readfile on everything loaded, but not us (we don't want to match our own docs)
		$pkg->install_inc;
	}

	$inited = 1;
}

our $carprec = 0;

sub install_inc {
	my $pkg = shift;

	unshift @INC, sub { # YUCK! but tying %INC didn't work, and source filters are applied per caller. XS for source filter purposes is yucki/er/
		my $self = shift;
		my $file = shift;

		return undef if $lock{$file}; # if we're already processing the file, then we're in the eval several lines down. return.
		local $lock{$file} = 1; # set this lock that prevents recursion

		unless (ref $INC[0] and $INC[0] == $self){ # if this happens, some stuff won't be filtered. It shouldn't happen often though.
			local @INC = grep { !ref or $_ != $self } @INC; # make sure we don't recurse when carp loads it's various innards, it causes a mess
			carp "FIXME's magic sub is no longer first in \@INC" . ($REPAIR_INC ? ", repairing" : "");
			if ($REPAIR_INC){
				my $i = 0;
				while ($i < @INC) {
					ref $INC[$i] or next;
					if ($INC[$i] == $self) {
						unshift @INC, splice(@INC, $i, 1);
						last;
					}
				} continue {
					$i++;
				}
			}
		}

		# create some perl code that gives back the return value of the original package, and thus looks like you're really requiring the same thing
		my $buffer = "\${ delete \$Devel::FIXME::rets{q{$file}} };"; # return what the last module returned. I don't know why it doesn't work without refs
		# really load the file
		local $cur = $file;
		my $ret = eval 'require $Devel::FIXME::cur'; # require always evaluates the return from an evalfile in scalar context, so we don't need to worry about list

		($err = "$@\n") =~ s/\nCompilation failed in require at \(eval \d+\)(?:\[.*?\])? line 1\.\n//s; # trim off the eval's appendix to the error
		$buffer = 'die $Devel::FIXME::err' if $@; # rethrow this way, so that base.pm shuts up

		# save the return value so that the original require can have it
		$rets{$file} = \$ret; # see above for why it's a ref

		# look for FIXME comments in the file that was really required
		$pkg->readfile($INC{$file}) if ($INC{$file});

		# return a filehandle containing source code that simply returns the value the real file did
		open my $fh, "<", \$buffer;
		$fh;
	};
}

sub regex {
	qr/#\s*(?:FIXME|XXX)\s+(.*)$/; # match a FIXME or an XXX, in a comment, with some lax whitespace rules, and suck in anything afterwords as the text
}

sub readfile { # FIXME refactor to something classier
	my $pkg = shift;
	my $file = shift;

	return unless -f $file;

	open my $src, "<", $file or die "couldn't open $file: $!";
	local $_;

	while(<$src>){
		$pkg->FIXME( # if the line matches the fixme, generate a fixme
			text => "$1",
			line => $., # the current line number for <$src>
			file => $file,
		) if $_ =~ $pkg->regex;
	} continue { last if eof $src }; # is this a platform bug on OSX?
	close $src;
}

sub eval { # evaluates all the rules on a fixme object
	my __PACKAGE__ $self = shift;

	foreach my $rule ($self->can("rules") ? $self->rules : ()){

		my $action = &$rule($self); # run the rule as a class method, and get back a return value

		if ($action == SHOUT){ # if the rule said to shout, we shout and stop
			return $self->shout;
		} elsif ($action == DROP){ # if the rule says to drop, we stop
			return undef;
		} # otherwise we keep looping through the rules
	}

	$self->shout; # and shout if there are no more rules left.
}

sub shout { # generate a pretty string and send it to STDERR
	my __PACKAGE__ $self = shift;
	warn("# FIXME: $self->{text} at $self->{file} line $self->{line}.\n");
}

sub new { # an object per FIXME statement
	my $pkg = shift;

	my %args;

	if (@_ == 1){ # if we only have one arg
		if (ref $_[0] and reftype($_[0]) eq 'HASH'){ # and it's a hash ref, then we take the hashref to be our args
			%args = %{ $_[0] };
		} else { # if it's one arg and not a hashref, then it's our text
			%args = ( text => $_[0] );
		}
	} elsif (@_ % 2 == 0){ # if there's an even number of arguments, they are key value pairs
		%args = @_;
	} else { # if the argument list is anything else we complain
		croak "Invalid arguments";
	}


	my __PACKAGE__ $self = $pkg->fields::new();
	%$self = %args;

	# fill in some defaults
	$self->{package} ||= (caller(1))[0];
	$self->{file} ||= (caller(1))[1];
	$self->{line} ||= (caller(1))[2];

	# these are mainly for rules
	$self->{script} ||= $0;
	$self->{time} ||= localtime;

	$self;
}

sub import { # export \&FIXME to our caller, /and/ generate a message if there is one to generate
	my $pkg = $_[0];
	$pkg->init unless @_ > 1;
	if (@_ == 1 or @_ > 2 or (@_ == 2 and first { $_[1] eq $_ or $_[1] eq "&$_" } @EXPORT_OK, map { ":$_" } keys %EXPORT_TAGS)){
		shift;
		local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
		$pkg->Exporter::import(@_);
	} else {
		$pkg->init;
		goto \&FIXME;
	}
}

sub FIXME { # generate a method
	my $pkg = __PACKAGE__;
	$pkg = shift if UNIVERSAL::can($_[0],"isa") and $_[0]->isa(__PACKAGE__); # it's a method or function, we don't care
	$pkg->new(@_)->eval;
}
*msg = \&FIXME; # booya.

__PACKAGE__

__END__