File Coverage

/root/.cpan/build/Inline-0.54_02-wb8_n3/blib/lib/Inline/denter.pm

Criterion	Covered	Total	%
statement	95	149	63.7
branch	18	56	32.1
condition	4	16	25.0
subroutine	12	16	75.0
pod	0	2	0.0
total	129	239	53.9

package Inline::denter;

use strict;
use Carp;
use AutoLoader 'AUTOLOAD';

sub new {
    my $class = shift;
    bless {width => 4,
	   comma => " : ",
	   level => 0,
	   tabwidth => 8,
	  }, $class;
}

# Prevent a taint exception being thrown by AutoLoader.pm.
# Serves no other purpose.
sub DESTROY {
}

sub undent {
    local $/ = "\n";
    my ($o, $text) = @_;
    my ($comma) = $o->{comma};
    my $package = caller;
    $package = caller(1) if $package eq 'Inline::denter';
    %{$o->{xref}} = ();
    @{$o->{objects}} = ();
    @{$o->{context}} = ();
    my $glob = '';
    chomp $text;
    @{$o->{lines}} = split $/, $text;
    $o->{level} = 0;
    $o->{line} ||= 1;
    $o->_setup_line;
    while (not $o->{done}) {
	if ($o->{level} == 0 and
	    $o->{content} =~ /^(\w+)\s*$comma\s*(.*)$/) {
	    $o->{content} = $2;
	    no strict 'refs';
	    push @{$o->{objects}}, "$1";
	}
	push @{$o->{objects}}, $o->_undent_data;
    }
    return @{$o->{objects}};
}

sub _undent_data {
    my $o = shift;
    my ($obj, $class) = ('', '');
    my @refs;
    my %refs;
    while ($o->{content} =~ s/^\\(?:\((\w+)\))?((\%|\@|\$|\\).*)/$2/) {
	push @refs, $1;
	$refs{$1} = scalar @refs;
    }
    if ($o->{content} =~ /^([\%\@\$])
	                  (\w(?:\w|::)*)?
                          \s*$/x
       ) {
	my $foo;
	$obj = ($1 eq '%') ? {} : ($1 eq '@') ? [] : \$foo;
	$class = $2 || '';
	if ($1 eq '%') {
	    %$obj = $o->_undent_hash;
	}
	elsif ($1 eq '@') {
	    @$obj = $o->_undent_array;
	}
	else {
	    $$obj = $o->_undent_scalar;
	}
	bless $obj, $class if length $class;
    }
    elsif ($o->{content} =~ /^\?\s*$/) {
	$obj = $o->_undent_undef;
    }
    else {
	$obj = $o->_undent_value;
    }
    while (@refs) {
	my $ref = pop @refs;
	my $copy = $obj;
	$obj = \ $copy;
	$o->{xref}{$ref} = $obj if $ref;
    }
    return $obj;
}

sub _undent_value {
    my $o = shift;
    my $value = '';
    if ($o->{content} =~ /^\<\<(\w+)(\-?)\s*$/) {
	my ($marker, $chomp) = ($1, $2);
	my $line = $o->{line};
	$o->_next_line;
	while (not $o->{done} and
	       $o->{lines}[0] ne $marker) {
	    $value .= $o->{lines}[0] . "\n";
	    $o->_next_line;
	}
	croak M03_no_value_end_marker($marker, $line) if $o->{done};
	chomp $value if $chomp;
    }
    elsif ($o->{content} =~ /^\"/) {
	croak $o->M04_mismatched_quotes unless $o->{content} =~ /^\".*\"\s*$/;
	($value = $o->{content}) =~ s/^\"|\"\s*$//g;
    }
    else {
	$value = $o->{content};
    }
    $o->_next_line;
    $o->_setup_line;
    return $value;
}

sub _undent_hash {
    my @values;
    my $o = shift;
    my $level = $o->{level} + 1;
    $o->_next_line;
    $o->_setup_line;
    while ($o->{level} == $level) {
	my ($key, $value) = split $o->{comma}, $o->{content};
	croak $o->M05_invalid_key_value unless (defined $key and defined $value);
	$o->{content} = $value;
	push @values, $o->_get_key($key), $o->_undent_data;;
    }
    croak $o->M06_invalid_indent_level if $o->{level} > $level;
    return @values;
}

sub _get_key {
    my ($o, $key) = @_;
    return $key unless $key =~ /^\<\<(\w+)(\-?)/;
    my ($marker, $chomp) = ($1, $2);
    $key = '';
    my $line = $o->{line};
    $o->_next_line;
    while (not $o->{done} and
	   $o->{lines}[0] ne $marker) {
	$key .= $o->{lines}[0] . "\n";
	$o->_next_line;
    }
    croak M02_no_key_end_marker($marker, $line) if $o->{done};
    chomp $key if $chomp;
    $o->_next_line;
    $o->_setup_line;
    return $key;
}

sub _undent_array {
    my @values;
    my $o = shift;
    my $level = $o->{level} + 1;
    $o->_next_line;
    $o->_setup_line;
    while ($o->{level} == $level) {
	push @values, $o->_undent_data;
    }
    croak $o->M06_invalid_indent_level if $o->{level} > $level;
    return @values;
}

sub _undent_scalar {
    my $values;
    my $o = shift;
    my $level = $o->{level} + 1;
    $o->_next_line;
    $o->_setup_line;
    croak $o->M06_invalid_indent_level if $o->{level} != $level;
    croak $o->M07_invalid_scalar_value if $o->{content} =~ /^[\%\@\$\\]/;
    return $o->_undent_undef if $o->{content} =~ /^\?/;
    return $o->_undent_value;
}

sub _undent_undef {
    my $o = shift;
    $o->_next_line;
    $o->_setup_line;
    return undef;
}

sub _next_line {
    my $o = shift;
    $o->{done}++, $o->{level} = -1, return unless @{$o->{lines}};
    local $_ = shift @{$o->{lines}};
    $o->{line}++;
}

sub _setup_line {
    my $o = shift;
    $o->{done}++, $o->{level} = -1, return unless @{$o->{lines}};
    my ($width, $tabwidth) = @{$o}{qw(width tabwidth)};
    while (1) {
	local $_ = $o->{lines}[0];
	# expand tabs in leading whitespace;
	$o->next_line, next if /^(\s*$|\#)/; # skip comments and blank lines
	while (s{^( *)(\t+)}
	       {' ' x (length($1) + length($2) * $tabwidth -
		       length($1) % $tabwidth)}e){}
	croak $o->M01_invalid_indent_width unless /^(( {$width})*)(\S.*)$/;
	$o->{level} = length($1) / $width;
	$o->{content} = $3;
	last;
    }
}

1;
__END__