padre 1.00+dfsg-3 / usr / share / perl5 / Padre / SLOC.pm

package Padre::SLOC;

# A basic Source Lines of Code counter/accumulator

use 5.008;
use strict;
use warnings;
use Params::Util ();
use Padre::MIME  ();

our $VERSION    = '1.00';
our $COMPATIBLE = '0.95';

# Differentiate content between different types
my %CONTENT = (
	'application/javascript' => 'code',
	'application/x-pasm'     => 'code',
	'application/x-perl'     => 'code',
	'application/x-perl6'    => 'code',
	'application/x-php'      => 'code',
	'application/x-ruby'     => 'code',
	'application/x-tcl'      => 'code',
	'text/x-actionscript'    => 'code',
	'text/x-adasrc'          => 'code',
	'text/x-cobol'           => 'code',
	'text/x-csrc'            => 'code',
	'text/x-haskell'         => 'code',
	'text/x-java'            => 'code',
	'text/x-pascal'          => 'code',
	'text/x-perlxs'          => 'code',
	'text/x-python'          => 'code',
);





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

sub new {
	my $class = shift;
	return bless {}, $class;
}





######################################################################
# Statistics Capture

sub add {
	my $self = shift;
	my $add  = shift;
	foreach my $key ( sort keys %$add ) {
		next unless $add->{$key};
		$self->{$key} ||= 0;
		$self->{$key} += $add->{$key};
	}
	return 1;
}

sub add_text {
	my $self = shift;
	my $text = shift;
	my $mime = shift;

	# Normalise newlines
	$$text =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;

	# Detect MIME if not provided
	$mime ||= Padre::MIME->detect(
		text => $$text,
	);

	# Get the line count for the file
	my $count = $self->count_mime( $text, $mime );

	# Add the line counts for the scalar
	$self->add($count);
}

sub add_file {
	my $self = shift;
	my $file = shift;
	unless ( Params::Util::_INSTANCE( $file, 'Padre::File' ) ) {
		require Padre::File::Local;
		$file = Padre::File::Local->new($file);
	}

	# Load the file
	my $text = $file->read;
	return unless defined $text;

	# Detect the MIME type
	my $type = Padre::MIME->detect(
		file => $file->filename,
		text => $text,
	) or return;

	# Hand off to the more generic method
	$self->add_text( \$text, Padre::MIME->find($type) );
}

sub add_document {
	my $self     = shift;
	my $document = shift;
	my $text     = $document->text_get or return;
	my $mime     = $document->mime or return;
	$self->add_text( \$text, $mime );
}

sub add_editor {
	my $self     = shift;
	my $editor   = shift;
	my $document = $editor->document or return;
	$self->add_document($document);
}





######################################################################
# Statistics Reporting

sub total_content {
	my $self  = shift;
	my $total = 0;
	foreach my $key ( sort keys %$self ) {
		my ( $lang, $type ) = split /\s+/, $key;
		if ( $type eq 'content' ) {
			$total += $self->{$key};
		}
	}
	return $total;
}

sub report_languages {
	my $self = shift;
	my %hash = ();
	foreach my $key ( sort keys %$self ) {
		my ( $lang, $type ) = split /\s+/, $key;
		$hash{$lang} ||= 0;
		$hash{$lang} += $self->{$key};
	}
	return \%hash;
}

sub report_types {
	my $self = shift;
	my %hash = ();
	foreach my $key ( sort keys %$self ) {
		my ( $lang, $type ) = split /\s+/, $key;
		$hash{$type} ||= 0;
		$hash{$type} += $self->{$key};
	}
	return \%hash;
}

sub smart_types {
	my $self = shift;
	my %hash = ();
	foreach my $key ( sort keys %$self ) {
		my ( $lang, $type ) = split /\s+/, $key;
		next unless $CONTENT{$lang};
		if ( $type eq 'content' ) {
			$type = $CONTENT{$lang};
		}
		$hash{$type} ||= 0;
		$hash{$type} += $self->{$key};
	}
	return \%hash;
}





######################################################################
# SLOC Counters

sub count_mime {
	my $self = shift;
	my $text = shift;
	my $mime = shift;

	# Dispatch to language-specific counting methods
	if ( $mime->type eq 'application/x-perl' ) {
		return $self->count_perl5( $text, $mime );
	}
	if ( $mime->type eq 'text/x-pod' ) {
		return $self->count_perl5( $text, $mime );
	}

	# Fall back to the generic counting methods
	if ( $mime->comment ) {
		return $self->count_commented( $text, $mime );
	} else {
		return $self->count_uncommented( $text, $mime );
	}
}

sub count_perl5 {
	my $self  = shift;
	my $text  = shift;
	my %count = (
		'text/x-pod comment'         => 0,
		'text/x-pod blank'           => 0,
		'application/x-perl content' => 0,
		'application/x-perl comment' => 0,
		'application/x-perl blank'   => 0,
	);

	my $content = 1;
	foreach my $line ( split /\n/, $$text, -1 ) {
		if ( $line !~ /\S/ ) {
			if ($content) {
				$count{'application/x-perl blank'}++;
			} else {
				$count{'text/x-pod blank'}++;
			}
		} elsif ( $line =~ /^=cut\s*/ ) {
			$count{'text/x-pod comment'}++;
			$content = 1;
		} elsif ($content) {
			if ( $line =~ /^=\w+/ ) {
				$count{'text/x-pod comment'}++;
				$content = 0;
			} elsif ( $line =~ /^\s*#/ ) {
				$count{'application/x-perl comment'}++;
			} else {
				$count{'application/x-perl content'}++;
			}
		} else {
			$count{'text/x-pod comment'}++;
		}
	}

	return \%count;
}

# Find SLOC information for languages which have comments
sub count_commented {
	my $self    = shift;
	my $text    = shift;
	my $mime    = shift;
	my $type    = $mime->type;
	my $comment = $mime->comment or return undef;
	my $matches = $comment->line_match;
	my %count   = (
		"$type content" => 0,
		"$type comment" => 0,
		"$type blank"   => 0,
	);

	foreach my $line ( split /\n/, $$text ) {
		if ( $line !~ /\S/ ) {
			$count{"$type blank"}++;
		} elsif ( $line =~ $matches ) {
			$count{"$type comment"}++;
		} else {
			$count{"$type content"}++;
		}
	}

	return \%count;
}

# Find SLOC information for languages which do not have comments
sub count_uncommented {
	my $self  = shift;
	my $text  = shift;
	my $mime  = shift;
	my $type  = $mime->type;
	my %count = (
		"$type content" => 0,
		"$type blank"   => 0,
	);

	foreach my $line ( split /\n/, $$text ) {
		if ( $line !~ /\S/ ) {
			$count{"$type blank"}++;
		} else {
			$count{"$type content"}++;
		}
	}

	return \%count;
}

1;

# Copyright 2008-2013 The Padre development team as listed in Padre.pm.
# LICENSE
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl 5 itself.