File Coverage

blib/lib/Filter/HereDocIndent.pm

Criterion	Covered	Total	%
statement	65	74	87.8
branch	19	28	67.8
condition			n/a
subroutine	11	12	91.6
pod	0	4	0.0
total	95	118	80.5

package Filter::HereDocIndent;
use strict;
use Filter::Util::Call;
# use Debug::ShowStuff ':all';
use re 'taint';
use vars qw($VERSION $debug);

# documentation at end of file


# version
$VERSION = '1.01';

# constants
use constant REG => 1;
use constant HEREDOC => 2;
use constant POD => 3; # reserved for later improvement


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

	# default INDENT_CONTENT
	defined($opts{'INDENT_CONTENT'}) or $opts{'INDENT_CONTENT'} = 1;
	$self->{'INDENT_CONTENT'} = $opts{'INDENT_CONTENT'};

	# NWS: strip {nws} out of heredocs
	$self->{'NWS'} = $opts{'NWS'};

	# default state
	$self->{'state'} = REG;

	# return object
	return $self;
}
#
# new
#------------------------------------------------------------------


#------------------------------------------------------------------
# import routine: creates filter object and adds it
# to the filters array
#
sub import {
	my ($class, %opts) = @_;

	# add filter if set to do so
	if ( defined($opts{'filter_add'}) ? $opts{'filter_add'} : 1 ) {
		filter_add($class->new(%opts));
	}
}
#
# import routine
#------------------------------------------------------------------


#------------------------------------------------------------------
# filter: this sub is run for every line in the calling script
#
sub filter {
	my $self = shift;
	my $status = filter_read() ;
	my $line = $_;

	($status, $line) = $self->process_line($status, $line);

	# set line and return value
	$_= $line;
	$status;
}
#
# filter
#------------------------------------------------------------------



#------------------------------------------------------------------
# filter_block
#
sub filter_block {
	my ($self, $block) = @_;
	my (@lines, $status, $rv);

	# parse block into lines
	@lines = split("\n", $block);

	# loop through lines
	LINE_LOOP:
	foreach my $line (@lines) {
		($status, $line) = $self->process_line(1, "$line\n");
	}

	# get return string
	$rv = join('', @lines);

	# return
	return $rv;
}
#
# filter_block
#------------------------------------------------------------------



#------------------------------------------------------------------
# process_line
#
sub process_line {
	my ($self, $status, $line) = @_;

	# if we're at the end of the file
	if (! $status) {
		# for debugging this module
		if ($debug)
			{print STDERR "\n--------------------------\n"}
	}

	# if in here doc
	elsif ($self->{'state'} == HEREDOC) {
		# if this is the end of the heredoc
		if ($line =~ m|^(\s*)$self->{'del_regex'}\s*$|) {
			my $len = length($1);

			if ($self->{'INDENT_CONTENT'}) {
				foreach my $el (@{$self->{'lines'}}) {
					$el =~ s|^\s{$len}|| or $el =~ s|^\s+||;
					$el eq '' and $el = "\n";
				}
			}

			$line = join('', @{$self->{'lines'}}, $self->{'del'}, "\n");

			# add empty lines so that line numbers match up with original code
			# NOTE: The following line still doesn't address the issue of
			# {nws} removals
			# $line .= "\n" x scalar(@{$self->{'lines'}});

			foreach (@{$self->{'lines'}})
				{ $line .= "\n" }

			# remove whitespace
			if ($self->{'NWS'}) {
				$line =~ s|\s*\{nws\}\s*||gs;
			}

			# set state to regular code
			$self->{'state'} = REG;
		}

		# else add to lines array
		else {
			push @{$self->{'lines'}}, $line;
			$line = '';
		}
	}

	# else in regular code
	else {
		# if this line starts a heredoc
		if ($line =~ m/
			^              # start of line
			[^#]*          # anything except a comment marker
			<<
			\s*

			(
				'[^']+'
				|
				"[^"]+"
				|
				\w+
			)

			[^'"]*
			;
			\s*

			/sx
			) {

			$self->{'del'} = $1;
			$self->{'del'} =~ s|^'(.*)'$|$1| or $self->{'del'} =~ s|^"(.*)"$|$1|;
			$self->{'del_regex'} = quotemeta($self->{'del'});

			$self->{'lines'} = [];
			$self->{'state'} = HEREDOC;
		}
	}

	# for debugging this module
	print STDERR $line if $debug;

	return ($status, $line);
}
#
# process_line
#------------------------------------------------------------------



# return true
1;

__END__