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


line stmt bran cond sub pod time code
1             package Apache::Config::Preproc::macro;
2 5     5   36 use parent 'Apache::Config::Preproc::Expand';
  5         8  
  5         33  
3 5     5   269 use strict;
  5         9  
  5         99  
4 5     5   26 use warnings;
  5         6  
  5         120  
5 5     5   2546 use Text::ParseWords;
  5         6952  
  5         337  
6 5     5   41 use Carp;
  5         9  
  5         2613  
7              
8             our $VERSION = '1.03';
9              
10             sub new {
11 5     5 0 13 my $class = shift;
12 5         20 my $conf = shift;
13 5         38 my $self = $class->SUPER::new($conf);
14 5         37 $self->{keep} = {};
15 5 50       26 croak "bad number of arguments: @_" if @_ % 2;
16 5         11 local %_ = @_;
17 5         9 my $v;
18 5 100       17 if ($v = delete $_{keep}) {
19 1 50       3 if (ref($v)) {
20 0 0       0 croak "keep argument must be a scalar or listref"
21             unless ref($v) eq 'ARRAY';
22             } else {
23 1         2 $v = [$v];
24             }
25 1         2 @{$self->{keep}}{@$v} = @$v;
  1         3  
26             }
27 5 50       29 croak "unrecognized arguments" if keys(%_);
28 5         60 return $self;
29             }
30              
31             sub macro {
32 10     10 0 21 my ($self, $name) = @_;
33 10         36 return $self->{macro}{$name};
34             }
35              
36             sub install_macro {
37 7     7 0 544 my ($self, $defn) = @_;
38 7 100       29 return 0 if $self->{keep}{$defn->name};
39 6         21 $self->{macro}{$defn->name} = $defn;
40 6         27 return 1;
41             }
42              
43             sub expand {
44 353     353 1 481 my ($self, $d, $repl) = @_;
45 353 100 100     557 if ($d->type eq 'section' && lc($d->name) eq 'macro') {
46 7         80 return $self->install_macro(Apache::Config::Preproc::macro::defn->new($d));
47             }
48 346 100 100     1418 if ($d->type eq 'directive' && lc($d->name) eq 'use') {
49 10         106 my ($name,@args) = parse_line(qr/\s+/, 0, $d->value);
50 10 100       1023 if (my $defn = $self->macro($name)) {
51 9         27 push @$repl, $defn->expand(@args);
52 9         68 return 1;
53             }
54             }
55 337         2256 return 0;
56             }
57            
58             package Apache::Config::Preproc::macro::defn;
59 5     5   41 use strict;
  5         15  
  5         127  
60 5     5   27 use warnings;
  5         17  
  5         175  
61 5     5   31 use Text::ParseWords;
  5         17  
  5         2506  
62              
63             sub new {
64 7     7   13 my $class = shift;
65 7         10 my $d = shift;
66 7         64 my ($name, @params) = parse_line(qr/\s+/, 0, $d->value);
67 7         1237 bless {
68             name => $name,
69             params => [ @params ],
70             code => [$d->select]
71             }, $class;
72             }
73              
74 13     13   91 sub name { shift->{name} }
75 9     9   13 sub params { @{shift->{params}} }
  9         25  
76 9     9   13 sub code { @{shift->{code}} }
  9         22  
77              
78             sub expand {
79 9     9   20 my ($self, @args) = @_;
80            
81             my @rxlist = map {
82 9   50     19 my $r = shift @args // '';
  23         61  
83 23         38 my $q = quotemeta($_);
84 23         291 [ qr($q), $r ]
85             } $self->params;
86 9         34 map { $self->_node_expand($_->clone, @rxlist) } $self->code;
  13         60  
87             }
88              
89             sub _node_expand {
90 45     45   2366 my ($self, $d, @rxlist) = @_;
91              
92 45 100       84 if ($d->type eq 'directive') {
    100          
93 24         122 $d->value($self->_repl($d->value, @rxlist));
94             } elsif ($d->type eq 'section') {
95 12         111 $d->value($self->_repl($d->value, @rxlist));
96 12         307 foreach my $st ($d->select) {
97 32         809 $self->_node_expand($st, @rxlist);
98             }
99             }
100 45         787 return $d;
101             }
102              
103             sub _repl {
104 36     36   199 my ($self, $v, @rxlist) = @_;
105 36         51 foreach my $rx (@rxlist) {
106 102         342 $v =~ s{$rx->[0]}{$rx->[1]}g;
107             }
108 36         117 return $v
109             }
110              
111             1;
112              
113             __END__