File Coverage

lib/Apache/Config/Preproc/macro.pm

Criterion	Covered	Total	%
statement	80	81	98.7
branch	17	22	77.2
condition	7	8	87.5
subroutine	19	19	100.0
pod	1	4	25.0
total	124	134	92.5

package Apache::Config::Preproc::macro;
use parent 'Apache::Config::Preproc::Expand';
use strict;
use warnings;
use Text::ParseWords;
use Carp;

our $VERSION = '1.03';

sub new {
    my $class = shift;
    my $conf = shift;
    my $self = $class->SUPER::new($conf);
    $self->{keep} = {};
    croak "bad number of arguments: @_" if @_ % 2;
    local %_ = @_;
    my $v;
    if ($v = delete $_{keep}) {
	if (ref($v)) {
	    croak "keep argument must be a scalar or listref"
		unless ref($v) eq 'ARRAY';
	} else {
	    $v = [$v];
	}
	@{$self->{keep}}{@$v} = @$v;
    }
    croak "unrecognized arguments" if keys(%_);
    return $self;
}

sub macro {
    my ($self, $name) = @_;
    return $self->{macro}{$name};
}

sub install_macro {
    my ($self, $defn) = @_;
    return 0 if $self->{keep}{$defn->name};
    $self->{macro}{$defn->name} = $defn;
    return 1;
}

sub expand {
    my ($self, $d, $repl) = @_;
    if ($d->type eq 'section' && lc($d->name) eq 'macro') {
	return $self->install_macro(Apache::Config::Preproc::macro::defn->new($d));
    }
    if ($d->type eq 'directive' && lc($d->name) eq 'use') {
	my ($name,@args) = parse_line(qr/\s+/, 0, $d->value);
	if (my $defn = $self->macro($name)) {
	    push @$repl, $defn->expand(@args);
	    return 1;
	}
    }
    return 0;
}

package Apache::Config::Preproc::macro::defn;
use strict;
use warnings;
use Text::ParseWords;

sub new {
    my $class = shift;
    my $d = shift;
    my ($name, @params) = parse_line(qr/\s+/, 0, $d->value);
    bless {
	name => $name,
	params => [ @params ],
	code => [$d->select]
    }, $class;
}

sub name { shift->{name} }
sub params { @{shift->{params}} }
sub code { @{shift->{code}} }

sub expand {
    my ($self, @args) = @_;

    my @rxlist = map {
	my $r = shift @args // '';
	my $q = quotemeta($_);
	[ qr($q), $r ]
    } $self->params;
    map { $self->_node_expand($_->clone, @rxlist) } $self->code;
}

sub _node_expand {
    my ($self, $d, @rxlist) = @_;

    if ($d->type eq 'directive') {
	$d->value($self->_repl($d->value, @rxlist));
    } elsif ($d->type eq 'section') {
	$d->value($self->_repl($d->value, @rxlist));
	foreach my $st ($d->select) {
	    $self->_node_expand($st, @rxlist);
	}
    }
    return $d;
}

sub _repl {
    my ($self, $v, @rxlist) = @_;
    foreach my $rx (@rxlist) {
	$v =~ s{$rx->[0]}{$rx->[1]}g;
    }
    return $v
}

1;

__END__