File Coverage

lib/Apache/Config/Preproc.pm

Criterion	Covered	Total	%
statement	83	111	74.7
branch	20	38	52.6
condition	3	8	37.5
subroutine	17	20	85.0
pod	3	6	50.0
total	126	183	68.8

package Apache::Config::Preproc;
use parent 'Apache::Admin::Config';
use strict;
use warnings;
use Carp;
use version 0.77;

our $VERSION = '1.05_02';

sub import {
    my $class = shift;
    if (defined(my $kw = shift)) {
	if ($kw eq ':default') {
	    install_preproc_default()
	} elsif ($kw eq ':optimized') {
	    install_preproc_optimized()
	} else {
	    croak "Unrecognized import parameter: $kw"
	}
    }
    if (@_) {
	croak "Too many import parameters";
    }
    $class->SUPER::import();
}

sub new {
    my $class = shift;
    my $file = shift;
    my $explist = Apache::Admin::Config::Tree::_get_arg(\@_, '-expand')
	|| [ qw(include) ];

    my $self = $class->SUPER::new($file, @_) or return;
    bless $self, $class;
    $self->{_filename} = $file;
    $self->{_options} = \@_;

    eval {
	$self->_preproc($explist);
    };
    if ($@) {
	$Apache::Admin::Config::ERROR = $@;
	return;
    }

    return $self;
}

sub filename { shift->{_filename} }

sub dequote {
    my ($self, $str) = @_;
    if ($str =~ s/^"(.*)"$/$1/) {
	$str =~ s/\\"/"/g;
    }
    return $str;
}

sub options { @{shift->{_options}} }

sub _preproc {
    my ($self, $explist) = @_;

    $self->_preproc_section($self,
			  [ map {
			      my ($mod,@arg);
			      if (ref($_) eq 'HASH') {
				  ($mod,my $ref) = each %$_;
				  @arg = @$ref;
			      } elsif (ref($_) eq 'ARRAY') {
				  @arg = @$_;
				  $mod = shift @arg;
			      } else {
				  $mod = $_;
			      }
			      $mod = 'Apache::Config::Preproc::'.$mod;
			      (my $file = $mod) =~ s|::|/|g;
			      require $file . '.pm';
			      $mod->new($self, @arg)
			    } @$explist ]);
}

# As of version 0.95, the Apache::Admin::Config package provides no
# methods for iterating over all configuration file statements, excepting
# the select method with the -which => N argument, which returns Nth
# statement or undef if N is out of range.  This method has two drawbacks:
#
#   1. It iterates over entire statement tree no matter what arguments are
#      given (see Apache/Admin/Config.pm, lines 417-439)
#   2. It makes unnecessary memory allocations (ibid., line 437).
#   3. When N is out of range, the following warning is emitted
#      in -w mode:
#         Use of uninitialized value $_[0] in string at
#         /usr/share/perl5/overload.pm line 119
#      That's because it unreferences the undefined value and passes it
#      to the overload::StrVal method (ibid., line 443).
#
# This means that time complexity of the code below is O(N**2).  This is
# further aggravated by the fact that no method is provided for inline
# modification of the source tree, except for the 'add' method, which again
# iterates over entire tree in order to locate the element, after which
# the new one should be inserted.
#
# Thus, the following default implementation of the _preproc_section function
# is highly inefficient:

sub _preproc_section_default {
    my ($self, $section, $modlist) = @_;

    return unless @$modlist;

    $_->begin_section($section) foreach (@$modlist);
  OUTER:
    for (my $i = 0;
	 defined(my $d = do {
	     local $SIG{__WARN__} = sub {
		 my $msg = shift;
		 warn "$msg" unless $msg =~ /uninitialized/;
	     };
	     $section->select(-which => $i) }); ) {
	foreach my $mod (@$modlist) {
	    if ($mod->expand($d, \my @repl)) {
		my $prev = $d;
		foreach my $r (@repl) {
		    $prev = $section->add($r, -after => $prev);
		}
		$d->unlink;
		next OUTER;
	    }
	    if ($d->type eq 'section') {
		$self->_preproc_section_default($d, $modlist);
	    }
	}
	$i++;
    }
    $_->end_section($section) foreach (@$modlist);
}

# In an attempt to fix the above problems I resort to a kludgy solution,
# which directly modifies the Apache::Admin::Config::Tree namespace
# and defines two missing functions in it: get_nth(N), which returns
# the Nth statement or undef if N is greater than the source tree
# length, and replace_inplace(N, A), which replaces the Nth statement
# with statements from the array A.  With these two methods at hand,
# the following implementation is used:
sub _preproc_section_optimized {
    my ($self, $section, $modlist) = @_;

    return unless @$modlist;

    $_->begin_section($section) foreach (@$modlist);
  OUTER:
    for (my $i = 0; defined(my $d = $section->get_nth($i)); ) {
	foreach my $mod (@$modlist) {
	    if ($mod->expand($d, \my @repl)) {
		$section->replace_inplace($i, @repl);
		next OUTER;
	    }
	    if ($d->type eq 'section') {
		$self->_preproc_section_optimized($d, $modlist);
	    }
	}
	$i++;
    }
    $_->end_section($section) foreach (@$modlist);
}

# The _preproc_section method upon its first invocation selects the
# right implementation to use.  If the version of the Apache::Admin::Config
# module is 0.95 or if the object has attribute {tree}{children} and it is
# a list reference, the function installs the two new methods in the
# Apache::Admin::Config::Tree namespace and selects the optimized
# implementation.  Otherwise, the default implementation is used.
#
# The decision can be forced when requiring the module.  To select the
# default implementation, do
#
#   use Apache::Config::Preproc qw(:default);
#
# To select the optimized implementation:
#
#   use Apache::Config::Preproc qw(:optimized);
#
sub _preproc_section {
    my $self = shift;
    unless ($self->can('_preproc_section_internal')) {
	if ((version->parse($Apache::Admin::Config::VERSION) == version->parse('0.95')
	    || (exists($self->{children}) && ref($self->{tree}{children}) eq 'ARRAY'))) {
	    install_preproc_optimized()
	} else {
	    install_preproc_default()
	}
    }
    $self->_preproc_section_internal(@_);
}

sub install_preproc_optimized {
    no warnings 'once';
    *{Apache::Admin::Config::Tree::get_nth} = sub {
	my ($self, $n) = @_;
	if ($n < @{$self->{children}}) {
	    return $self->{children}[$n];
	}
	return undef
    };
    *{Apache::Admin::Config::Tree::replace_inplace} = sub {
	my ($self, $n, @items) = @_;
	splice @{$self->{children}}, $n, 1,
	       map { $_->{parent} = $self; $_ } @items;
    };

    *{_preproc_section_internal} = \&_preproc_section_optimized;
}

sub install_preproc_default {
    *{_preproc_section_internal} = \&_preproc_section_default;
}

1;
__END__