File Coverage

blib/lib/Perl/Metrics/Plugin.pm

Criterion	Covered	Total	%
statement	66	84	78.5
branch	14	26	53.8
condition	4	15	26.6
subroutine	13	13	100.0
pod	5	5	100.0
total	102	143	71.3

package Perl::Metrics::Plugin;

=pod

=head1 NAME

Perl::Metrics::Plugin - Base class for Perl::Metrics Plugins

=head1 SYNOPSIS

  # Implement a simple metrics package which counts up the
  # use of each type of magic variable.
  package Perl::Metrics::Plugin::Magic;

  use base 'Perl::Metrics::Plugin';

  # Creates the metric 'all_magic'.
  # The total number of magic variables.
  sub metric_all_magic {
      my ($self, $Document) = @_;
      return scalar grep { $_->isa('PPI::Token::Magic') }
                    $Document->tokens;
  }

  # The number of $_ "scalar_it" magic vars
  sub metric_scalar_it {
      my ($self, $Document) = @_;
      return scalar grep { $_->content eq '$_' }
                    grep { $_->isa('PPI::Token::Magic') }
                    $Document->tokens;
  }

  # ... and so on, and so forth.

  1;

=head1 DESCRIPTION

The L system does not in and of itself generate any actual
metrics data, it merely acts as a processing and storage engine.

The generation of the actual metrics data is done via metrics packages,
which as implemented as C sub-classes.

=head2 Implementing Your Own Metrics Package

Implementing a metrics package is pretty easy.

First, create a Perl::Metrics::Plugin::Something package, inheriting
from C.

The create a subroutine for each metric, named metric_$name.

For each subroutine, you will be passed the plugin object itself, and the
L object to generate the metric for.

Return the metric value from the subroutine. And add as many metric_
methods as you wish. Methods not matching the pattern /^metric_(.+)$/
will be ignored, and you may use them for whatever support methods you
wish.

=head1 METHODS

=cut

use strict;
use Carp             ();
use Class::Inspector ();
use Params::Util     '_IDENTIFIER',
                     '_INSTANCE';

use vars qw{$VERSION};
BEGIN {
	$VERSION = '0.09';
}





#####################################################################
# Constructor

=pod

=head2 new

The C constructor is quite trivial at this point, and is provided
merely as a convenience. You don't really need to think about this.

=cut

sub new {
	my $class = ref $_[0] ? ref shift : shift;
	my $self  = bless {}, $class;
	$self;
}

=pod

=head2 class

A convenience method to get the class for the plugin object,
to avoid having to use ref directly (and making the intent of
any code a little clearer).

=cut

sub class { ref $_[0] || $_[0] }





#####################################################################
# Perl::Metrics::Plugin API

=pod

=head2 metrics

The C method provides the list of metrics that are provided
by the metrics package. By default, this list is automatically
generated for you scanning for C methods that reside
in the immediate package namespace.

Returns a reference to a C where the keys are the metric names,
and the values are the "version" of the metric (for versioned metrics),
or C if the metric is not versioned.

=cut

sub metrics {
	my $self = shift;
	$self->{_metrics} or
	$self->{_metrics} = $self->_metrics;
}

sub _metrics {
	my $self    = shift;
	my $class   = ref $self;
	my $funcs   = Class::Inspector->functions($class)
		or Carp::croak("Failed to get method list for '$class'");
	my %metrics = map  { $_ => undef     }
	              grep { _IDENTIFIER($_) }
	              grep { s/^metric_//s   }
	              @$funcs;
	\%metrics;
}

sub _metric {
	my ($self, $Document, $name) = @_;
	my $method = "metric_$name";
	$self->can($method) or Carp::croak("Bad metric name '$name'");
	scalar($self->$method($Document));
}

=pod

=head2 process_index

The C method will cause the metrics plugin to scan every
single file entry in the database, and run any an all metrics required to
bring to the database up to complete coverage for that plugin.

This process may take some time for large indexes.

=cut

sub process_index {
	my $self  = shift;
	my @files = Perl::Metrics::File->retrieve_all;
	@files = sort { $a->path cmp $b->path } @files;
	while ( my $file = shift @files ) {
		Perl::Metrics->_trace("Processing $file... ");
		if ( $self->process_file($file) ) {
			Perl::Metrics->_trace("done.\n");
		} else {
			Perl::Metrics->_trace("error.\n");
		}
	}
	1;
}

=pod

=head2 process_file $File

The C method takes as argument a single
L and run any and all metrics required
to bring that file up to complete coverage for the plugin.

=cut

sub process_file {
	my $self = shift;
	my $file = _INSTANCE(shift, 'Perl::Metrics::File')
		or Carp::croak("Did not pass a Perl::Metrics::File to process_file");

	# Has the file been removed since the last run
	unless ( -f $file->path ) {
		# Delete the file entry
		$file->delete;
		return 1;
	}

	# Get the metric list for the plugin, and the
	# database Metric data for this file.
	my %metrics = %{$self->metrics}; # Copy so we can destroy
	my @objects = $file->metrics(
		'package' => $self->class,
		);

	# Deal with the existing metrics objects that do not
	# require the Document in order to be processed.
	my @todo = ();
	foreach my $object ( @objects ) {
		my $name = $object->name;

		# Remove any redundant metrics
		if ( ! exists $metrics{$name} ) {
			$object->delete;
			delete $metrics{$name};
			next;
		}

		# If the metric is unversioned, we don't need to rerun
		if ( ! defined $metrics{$name} and
		     ! defined $object->version
		) {
			delete $metrics{$name};
			next;
		}

		# Must be versioned. If plugin equals stored version,
		# then no need to rerun the metric.
		if ( defined $metrics{$name}  and
		     defined $object->version and
		     $object->version == $metrics{$name}
		) {
			delete $metrics{$name};
			next;
		}

		# To do in the next pass
		push @todo, $object;
	}

	# Shortcut return now if nothing left to do
	unless ( @todo or keys %metrics ) {
		return 1;
	}

	# Any further metrics will need the document
	my $Document = eval { $file->Document };
	if ( $@ or ! $Document ) {
		# The document has gone unparsable. If this
		# is due to a PPI upgrade breaking something, we
		# need to flush out any existing metrics for the
		# document, then skip on to the next file
		$file->metrics->delete_all;
		return 0;
	}

	# Now we have the document, update the remaining metrics
	foreach my $object ( @todo ) {
		my $name = $object->name;

		# Versions differ, or it has changed from defined to
		# not, or back the front.
		$object->version($metrics{$name});
		my $value = $self->_metric($Document, $name);
		$object->value($value);
		$object->update;
		delete $metrics{$name};
	}

	# With the existing ones out the way, generate the new ones
	foreach my $name ( sort keys %metrics ) {
		my $value = $self->_metric($Document, $name);
		Perl::Metrics::Metric->insert( {
			hex_id  => $file->hex_id,
			package => $self->class,
			name    => $name,
			version => $metrics{$name},
			value   => $value,
			} );
	}

	1;
}

1;

=pod

=head1 SUPPORT

Bugs should be reported via the CPAN bug tracker at

L

For other issues, contact the author.

=head1 AUTHOR

Adam Kennedy [e-mail]

=head1 SEE ALSO

L, L

=head1 COPYRIGHT

Copyright 2005 - 2008 Adam Kennedy.

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

The full text of the license can be found in the
LICENSE file included with this module.

=cut