Implement the locus preprocessor

Locus attaches to each node in the parse tree a Text::Locus object
describing the location of the corresponding statement in the source
file.

* lib/Apache/Config/Preproc.pm: (new): Save filename.
(filename): New method.
(options): Return list.
(_preproc_section_default)
(_preproc_section_optimized): Start individual module start and
finish methods.
* lib/Apache/Config/Preproc/include.pm: Fix the call to
conf->options.
* lib/Apache/Config/Preproc/locus.pm: New module.
* t/TestPreproc.pm (dump_reformat_synclines): New method.
* t/06locus00.t: New test.
* t/06locus01.t: New test.
* t/06locus02.t: New test.
* t/06locus03.t: New test.

8 files changed, 393 insertions, 4 deletions

diff --git a/lib/Apache/Config/Preproc.pm b/lib/Apache/Config/Preproc.pm
index 418bad9..b6f6a57 100644
--- a/lib/Apache/Config/Preproc.pm
+++ b/lib/Apache/Config/Preproc.pm
@@ -32,6 +32,7 @@ sub new {
 
     my $self = $class->SUPER::new($file, @_) or return;
     bless $self, $class;
+    $self->{_filename} = $file;
     $self->{_options} = \@_;
 
     eval {
@@ -45,6 +46,8 @@ sub new {
     return $self;
 }
 
+sub filename { shift->{_filename} }
+
 sub dequote {
     my ($self, $str) = @_;
     if ($str =~ s/^"(.*)"$/$1/) {
@@ -53,7 +56,7 @@ sub dequote {
     return $str;
 }
 
-sub options { shift->{_options} }
+sub options { @{shift->{_options}} }
 
 sub _preproc {
     my ($self, $explist) = @_;
@@ -106,6 +109,9 @@ sub _preproc_section_default {
 
     return unless @$modlist;
 
+    foreach my $mod (@$modlist) {
+	$mod->can('start') && $mod->start($section);
+    }
   OUTER:
     for (my $i = 0;
 	 defined(my $d = do {
@@ -130,7 +136,9 @@ sub _preproc_section_default {
 	}
 	$i++;
     }
-    return 1;
+    foreach my $mod (@$modlist) {
+	$mod->can('finish') && $mod->finish($section);
+    }
 }
 
 # In attempt to fix the above problems I resort to a kludgy solution,
@@ -145,6 +153,9 @@ sub _preproc_section_optimized {
 
     return unless @$modlist;
 
+    foreach my $mod (@$modlist) {
+	$mod->can('start') && $mod->start($section);
+    }
   OUTER:
     for (my $i = 0; defined(my $d = $section->get_nth($i)); ) {
 	foreach my $mod (@$modlist) {
@@ -159,6 +170,9 @@ sub _preproc_section_optimized {
 	}
 	$i++;
     }
+    foreach my $mod (@$modlist) {
+	$mod->can('finish') && $mod->finish($section);
+    }
 }
 
 # The _preproc_section method upon its first invocation selects the
@@ -201,7 +215,8 @@ sub install_preproc_optimized {
     };
     *{Apache::Admin::Config::Tree::replace_inplace} = sub {
 	my ($self, $n, @items) = @_;
-	splice @{$self->{children}}, $n, 1, @items;
+	splice @{$self->{children}}, $n, 1,
+	       map { $_->{parent} = $self; $_ } @items;
     };
 
     *{_preproc_section_internal} = \&_preproc_section_optimized;
@@ -365,6 +380,17 @@ Useless if the B<compact> expansion is enabled.
 =head1 METHODS
 
 All methods are inherited from B<Apache::Admin::Config>.
+
+Additional methods:
+
+=head2 filename
+
+Returns the name of the configuration file.
+
+=head2 options
+
+Returns the list of options passed to the constructor when creating
+the object.    
     
 =head1 MODULES
 
diff --git a/lib/Apache/Config/Preproc/include.pm b/lib/Apache/Config/Preproc/include.pm
index b7e6870..32dafe9 100644
--- a/lib/Apache/Config/Preproc/include.pm
+++ b/lib/Apache/Config/Preproc/include.pm
@@ -81,7 +81,7 @@ sub expand {
 			croak "file $file already included";
 		    }
 		    if (my $inc = new Apache::Admin::Config($file,
-							    @{$self->conf->options})) {
+							    $self->conf->options)) {
 			$inc->add('directive',
 				  '$PUSH$' => $self->context_string($file),
 				  '-ontop');
diff --git a/lib/Apache/Config/Preproc/locus.pm b/lib/Apache/Config/Preproc/locus.pm
new file mode 100644
index 0000000..f3ec42a
--- /dev/null
+++ b/lib/Apache/Config/Preproc/locus.pm
@@ -0,0 +1,131 @@
+package Apache::Config::Preproc::locus;
+use strict;
+use warnings;
+use Text::Locus;
+
+sub new {
+    my ($class, $conf) = @_;
+    bless { filename => $conf->filename, line => 0, context => [] }, $class;
+}
+
+sub filename { shift->{filename} }
+
+sub context_push {
+    my ($self,$file) = @_;
+    push @{$self->{context}}, [ $self->filename, $self->{line} ];
+    $self->{filename} = $file;
+    $self->{line} = 0;
+}
+
+sub context_pop {
+    my $self = shift;
+    if (my $ctx = pop @{$self->{context}}) {
+	($self->{filename}, $self->{line}) = @$ctx;
+#	$self->{line}++;
+    }
+}
+
+sub expand {
+    my ($self, $d, $repl) = @_;
+
+    # Prevent recursion
+    return 0 if $d->can('locus');
+
+    # Handle context switches due to include statements.
+    if ($d->type eq 'directive') {
+	if ($d->name eq '$PUSH$') {
+	    if ($d->value =~ /^\"(.+)\"/) {
+		$self->context_push($1);
+		return 0;
+	    }
+	} elsif ($d->name eq '$POP$') {
+	    $self->context_pop();
+	    return 0;
+	}
+    }
+
+    # Compute and attach a locus object.
+    $self->{line}++;
+    my $locus = new Text::Locus($self->filename, $self->{line});
+    if ($d->type eq 'section') {
+	$self->lpush($locus);
+    } elsif ($d->type eq 'directive') {
+	if ((my $nl = ($d->{raw}) =~ tr/\n//) > 1) {
+	    my $l = $self->{line}+1;
+	    $self->{line} += $nl-1;
+	    $locus->add($self->filename, ($l..$self->{line}));
+	}	
+    } elsif ($d->type eq 'blank') {
+        if ($d->{length} > 1) {
+	    my $l = $self->{line}+1;
+	    $self->{line} += $d->{length}-1;	    
+	    $locus->add($self->filename, ($l..$self->{line}));
+	}
+    } elsif ($d->type eq 'comment') {
+	if (my $nl = ($d->value//'') =~ tr/\n//) {
+	    my $l = $self->{line}+1;
+	    $self->{line} += $nl;
+	    $locus->add($self->filename, ($l..$self->{line}));
+	}
+    }
+    push @$repl, Apache::Config::Preproc::locus::node->derive($d, $locus);
+    return 1;
+}
+
+sub lpush {
+    my ($self,$locus) = @_;
+    push @{$self->{postprocess}}, $locus;
+}
+
+sub lpop {
+    my ($self) = @_;
+    pop @{$self->{postprocess}}
+}
+
+sub lcheck {
+    my ($self, $item) = @_;
+    if ($self->{postprocess} && @{$self->{postprocess}}) {
+	return ${$self->{postprocess}}[$#{$self->{postprocess}}]->format eq $item->locus->format;
+    }
+}
+
+sub finish {
+    my ($self, $d) = @_;
+    if ($d->type eq 'section' && $self->lcheck($d)) {
+	$self->lpop;
+	$self->{line}++;
+	if (my @lines = $d->locus->filelines($self->filename)) {
+	    $d->locus->add($self->filename, (pop(@lines)+1..$self->{line}));
+	}
+    }
+}
+
+package Apache::Config::Preproc::locus::node;
+use Apache::Admin::Config;
+our @ISA = qw(Apache::Admin::Config::Tree);
+
+sub derive {
+    my ($class, $orig, $locus, $index) = @_;
+    my $self = bless $orig->clone;
+    $self->{_locus} = $locus;
+    $self->{_index} = $index;
+    return $self;
+}
+
+sub locus { shift->{_locus} }
+sub index { shift->{_index} }
+
+sub clone {
+    my ($self) = @_;
+    my $clone = $self->SUPER::clone;
+    $clone->{_locus} = $clone->{_locus}->clone();
+    return $clone;
+}
+
+1;
+
+    
+    
+    
+	
+
diff --git a/t/06locus00.t b/t/06locus00.t
new file mode 100644
index 0000000..543760d
--- /dev/null
+++ b/t/06locus00.t
@@ -0,0 +1,35 @@
+# -*- perl -*-
+use lib qw(t lib);
+use strict;
+use Test;
+plan test => 1;
+
+use TestPreproc;
+my $obj = new TestPreproc -expand => [qw(locus)];
+ok($obj->dump_reformat_synclines, $obj->dump_expect)
+
+__DATA__
+!>httpd.conf
+# Start of file
+
+# Comment 1
+# Comment 2
+# Comment 3
+
+
+# End of file
+!=
+# $server_root/httpd.conf:1
+# Start of file
+# $server_root/httpd.conf:2
+
+# $server_root/httpd.conf:3-5
+# Comment 1
+# Comment 2
+# Comment 3
+# $server_root/httpd.conf:6-7
+
+
+# $server_root/httpd.conf:8
+# End of file
+!$
diff --git a/t/06locus01.t b/t/06locus01.t
new file mode 100644
index 0000000..407e2a6
--- /dev/null
+++ b/t/06locus01.t
@@ -0,0 +1,40 @@
+# -*- perl -*-
+use lib qw(t lib);
+use strict;
+use Test;
+plan test => 1;
+
+use TestPreproc;
+my $obj = new TestPreproc -expand => [qw(locus)],
+                          '-no-comment-grouping' => 1,
+                          '-no-blank-grouping' => 1;
+ok($obj->dump_reformat_synclines, $obj->dump_expect)
+
+__DATA__
+!>httpd.conf
+# Start of file
+
+# Comment 1
+# Comment 2
+# Comment 3
+
+
+# End of file
+!=
+# $server_root/httpd.conf:1
+# Start of file
+# $server_root/httpd.conf:2
+
+# $server_root/httpd.conf:3
+# Comment 1
+# $server_root/httpd.conf:4
+# Comment 2
+# $server_root/httpd.conf:5
+# Comment 3
+# $server_root/httpd.conf:6
+
+# $server_root/httpd.conf:7
+
+# $server_root/httpd.conf:8
+# End of file
+!$
diff --git a/t/06locus02.t b/t/06locus02.t
new file mode 100644
index 0000000..8a09987
--- /dev/null
+++ b/t/06locus02.t
@@ -0,0 +1,71 @@
+# -*- perl -*-
+use lib qw(t lib);
+use strict;
+use Test;
+plan test => 1;
+
+use TestPreproc;
+my $obj = new TestPreproc -expand => [qw(locus)];
+ok($obj->dump_reformat_synclines eq $obj->dump_expect);
+
+__DATA__
+!>httpd.conf
+# Start of file
+ServerName localhost
+
+ServerAdmin foo@example.net
+
+<VirtualHost *:80>
+   ServerName foo
+   DocumentRoot a
+   <Directory a>
+     AllowOverride none
+     Require all granted
+   </Directory>
+</VirtualHost>
+
+<VirtualHost *:80>
+  ServerName bar
+  DocumentRoot b
+</VirtualHost>
+
+# End of file
+!=
+# $server_root/httpd.conf:1
+# Start of file
+# $server_root/httpd.conf:2
+ServerName localhost
+# $server_root/httpd.conf:3
+
+# $server_root/httpd.conf:4
+ServerAdmin foo@example.net
+# $server_root/httpd.conf:5
+
+# $server_root/httpd.conf:6-13
+<VirtualHost *:80>
+# $server_root/httpd.conf:7
+ServerName foo
+# $server_root/httpd.conf:8
+DocumentRoot a
+# $server_root/httpd.conf:9-12
+<Directory a>
+# $server_root/httpd.conf:10
+AllowOverride none
+# $server_root/httpd.conf:11
+Require all granted
+</Directory>
+</VirtualHost>
+# $server_root/httpd.conf:14
+
+# $server_root/httpd.conf:15-18
+<VirtualHost *:80>
+# $server_root/httpd.conf:16
+ServerName bar
+# $server_root/httpd.conf:17
+DocumentRoot b
+</VirtualHost>
+# $server_root/httpd.conf:19
+
+# $server_root/httpd.conf:20
+# End of file
+!$
diff --git a/t/06locus03.t b/t/06locus03.t
new file mode 100644
index 0000000..37b4c1f
--- /dev/null
+++ b/t/06locus03.t
@@ -0,0 +1,52 @@
+# -*- perl -*-
+use lib qw(t lib);
+use strict;
+use Test;
+plan test => 1;
+
+use TestPreproc;
+my $obj = new TestPreproc -expand => [qw(locus include)];
+ok($obj->dump_reformat_synclines,$obj->dump_expect);
+
+__DATA__
+!>httpd.conf
+# Start of file
+ServerRoot "$server_root"
+ServerAdmin foo@example.net
+Include vhost1.conf
+Include vhost2.conf
+PidFile logs/httpd.pid
+!>vhost1.conf
+<VirtualHost *:80>
+   ServerName foo
+   DocumentRoot a
+</VirtualHost>
+!>vhost2.conf
+<VirtualHost *:80>
+   ServerName bar
+   DocumentRoot b
+</VirtualHost>
+!=
+# $server_root/httpd.conf:1
+# Start of file
+# $server_root/httpd.conf:2
+ServerRoot "$server_root"
+# $server_root/httpd.conf:3
+ServerAdmin foo@example.net
+# $server_root/vhost1.conf:1-4
+<VirtualHost *:80>
+# $server_root/vhost1.conf:2
+ServerName foo
+# $server_root/vhost1.conf:3
+DocumentRoot a
+</VirtualHost>
+# $server_root/vhost2.conf:1-4
+<VirtualHost *:80>
+# $server_root/vhost2.conf:2
+ServerName bar
+# $server_root/vhost2.conf:3
+DocumentRoot b
+</VirtualHost>
+# $server_root/httpd.conf:6
+PidFile logs/httpd.pid
+!$    
diff --git a/t/TestPreproc.pm b/t/TestPreproc.pm
index 41d6e24..a5d0276 100644
--- a/t/TestPreproc.pm
+++ b/t/TestPreproc.pm
@@ -7,6 +7,7 @@ use File::Basename;
 use File::Temp;
 use File::Spec;
 use File::Path qw /make_path/;
+use Cwd;
 use autodie;
 
 sub import {
@@ -54,6 +55,7 @@ sub new {
     my $self = $class->SUPER::new($confname, @_);
     if ($self) {
 	$self->{_expect} = $text;
+	$self->{_cwd} = getcwd;
     } elsif (!$expect_fail) {
 	croak $Apache::Admin::Config::ERROR;
     }
@@ -67,6 +69,38 @@ sub dump_test {
     $self->dump_raw eq $self->{_expect};
 }
 
+sub dump_reformat_synclines {
+    my $self = shift;
+    dump_reformat_synclines_worker($self, qr{$self->{_cwd}});
+}
+
+
+sub dump_reformat_synclines_worker {
+    my ($tree, $dir) = @_;
+    join('', map {
+	(my $l = $_->locus->format) =~ s{$dir/}{}g;
+	"# $l\n" .
+	do {
+	    if ($_->type eq 'section') {
+		$tree->write_section($_->name, $_->value) .
+	        dump_reformat_synclines_worker($_, $dir) .
+		$tree->write_section_closing($_->name)
+	    } else {
+		my $method = "write_".$_->type;
+		my $name;
+		if ($_->type eq 'directive') {
+		    $name = $_->name;
+		} elsif ($_->type eq 'comment') {
+                    $name = $_->value;
+                } elsif ($_->type eq 'blank') {
+                    $name = $_->{length};
+                }	
+	        $tree->$method($name||'',$_->value//'');
+            }
+	};
+    } $tree->select());
+}	
+
 1;