File Coverage

blib/lib/ExtUtils/PerlPP.pm

Criterion	Covered	Total	%
statement	9	131	6.8
branch	0	74	0.0
condition	0	21	0.0
subroutine	3	9	33.3
pod	1	3	33.3
total	13	238	5.4

# -*- perl -*-
#
#
#   ExtUtils::PerlPP - A Perl Preprocessor
#
#
#   This module is Copyright (C) 1998 by
#
#       Jochen Wiedmann
#       Am Eisteich 9
#       72555 Metzingen
#       Germany
#
#       Email: [e-mail]
#       Phone: [phone]
#
#   All rights reserved.
#
#   You may distribute this module under the terms of either the GNU
#   General Public License or the Artistic License, as specified in
#   the Perl README file.
#

use strict;
use Exporter;


package ExtUtils::PerlPP;

use vars qw($VERSION @ISA @EXPORT);

@ISA = qw(Exporter);
@EXPORT = qw(ppp);
$VERSION = '0.03';


sub new {
    my $proto = shift;
    my $self = { @_ };
    bless ($self, (ref($proto) || $proto));
    $self;
}


sub ppp {
    my($in, $out, $config) = @_ ? @_ : @ARGV;
    my $parser = ExtUtils::PerlPP->new('in_fh' => $in,
				       'out_fh' => $out,
				       'config' => $config);
    $parser->parse();
}


sub _ParseVar {
    my($self, $config, $var, $subvar) = @_;
    my($text) = sprintf("%s%s", $var, (defined($subvar) ? $subvar : ""));
    my $result;
    if (!exists($config->{$var})) {
	if ($self->{'no_config_default'}) {
	    return '';
	}
	$result = $Config::Config{$var};
    } else {
	$result = $config->{$var};
    }

    while (defined($result)  &&  $subvar  &&  $subvar =~ /^\-\>(\w+)/) {
	$var = $1;
	$subvar = $';
	if ($var =~ /^\d+$/) {
	    if (ref($result) ne 'ARRAY') {
		return '';
	    }
	    $result = $result->[$var];
	} else {
	    if (ref($result) ne 'HASH') {
		return '';
	    }
	    $result = $result->{$var};
	}
    }

    if (!defined($result)) {
	$result = '';
    } elsif (ref($result) eq 'CODE') {
	$result = &$result($self, $text);
	if (!defined($result)) {
	    $result = '';
	}
    }

    $result;
}


sub _ParseVars {
    my($self, $config, $line) = @_;
    $line =~ s/\~\~(\w+)((\-\>\w+)*)\~\~/$self->_ParseVar($config, $1, $2)/eg;
    $line;
}


sub _Condition {
    my($self, $lineNum, $config, $line) = @_;
    $line = $self->_ParseVars($config, $line);
    my $result = eval $line;
    if ($@) {
	die "Error while evaluating condition at line $lineNum: $@";
    }
    $result;
}


sub parse {
    my $line;
    my $self = shift;
    my $in = $self->{'in_fh'};
    my $out = $self->{'out_fh'};
    my $config = $self->{'config'};
    my $defaultConfig = !$self->{'no_config_default'};
    my $makeDirs = !$self->{'no_makedirs'};
    my @if_stack;
    my $if_state = 1;

    if (!ref($in)) {
	require IO::File;
	my $fh = IO::File->new($in, "r");
	if (!$fh) {
	    die "Error while opening $in: $!";
	}
	$in = $fh;
    }
    if (!ref($out)) {
	# Create directories, if desired
	if ($makeDirs) {
	    require File::Basename;
	    my $base = File::Basename::dirname($out);
	    if (! -d $base) {
		require File::Path;
	        File::Path::mkpath([$base], 0, 0755);
	    }
	}

	require IO::File;
	my $fh = IO::File->new($out, "w");
	if (!$fh) {
	    die "Error while opening $out: $!";
	}
	$out = $fh;
    }
    if (!ref($config)) {
	require IO::File;
	my $fh = IO::File->new($config, "r");
	if (!$fh) {
	    die "Error while opening $config: $!";
	}
	local($/) = undef;
	my $code = $fh->getline();
	if (!defined($code)) {
	    die "Error while reading $config: $!";
	}
	my $result = eval $code;
	if ($@) {
	    die "Error while evaluating $config: $!";
	}
	$config = $result;
    }

    if ($defaultConfig) {
	require Config;
    }

    my $lineNum = 0;
    while (defined($line = $in->getline())) {
	++$lineNum;
	if ($line =~ /^\s*\~\#if\#\~/) {
	    my $new_state = $if_state  &&
		$self->_Condition($lineNum, $config, $');
	    unshift(@if_stack, [$new_state, $if_state, $lineNum]);
	    $if_state = $new_state;
	} elsif ($line =~ /^\s*\~\#elsif\#\~/) {
	    if (!@if_stack) {
		die "~#elsif#~ without ~#if#~ at line $lineNum";
	    }
	    my $if_elem = $if_stack[0];
	    $if_state = $if_elem->[1] && !$if_elem->[0] &&
		$self->_Condition($lineNum, $config, $');
	    if ($if_state) {
		$if_elem->[0] = 1;
	    }
	} elsif ($line =~ /^\s*\~\#else\#\~/) {
	    if (!@if_stack) {
		die "~#else#~ without ~#if#~ at line $lineNum";
	    }
	    my $if_elem = $if_stack[0];
	    $if_state = $if_elem->[1] && !$if_elem->[0];
	    if ($if_state) {
		$if_elem->[0] = 1;
	    }
	} elsif ($line =~ /^\s*\~\#endif\#\~/) {
	    if (!@if_stack) {
		die "~#endif#~ without ~#if#~ at line $lineNum";
	    }
	    my $if_elem = shift @if_stack;
	    $if_state = $if_elem->[1];
	} elsif ($line =~ /^\s*\~\&([a-zA-Z_]\w*)\&\~/) {
	    $line = $';
	    my $var = $1;
	    my $code = '';
	    my $oldLineNum = $lineNum;

	    while (defined($line)  &&  $line !~ /\~\&\&\~/) {
		$code .= $line;
		$line = $in->getline();
	    }
	    if (!defined($line)) {
		die "~&$var&~ without ~&&~ at line $oldLineNum";
	    }
	    if ($line =~ /\~\&\&\~/) {
		$code .= $`;
	    }
	    $self->{'config'}->{$var} = eval "sub { $code }";
	    if ($@) {
		die "Error while defining method $var at line $oldLineNum: $@";
	    }
	} elsif ($if_state) {
	    if (!$out->print($self->_ParseVars($config, $line))) {
		die "Error while writing: $!";
	    }
	}
    }
}


1;

__END__