Made a few minor style changes to the original patches. Thanks for the extra eyeballing Stas ;-)
--- /dev/null 2002-08-31 07:31:37.000000000 +0800
+++ docs/api/Apache/Directive.pod 2003-01-29 10:59:37.000000000 +0800
@@ -0,0 +1,133 @@
+=head1 NAME
+
+Apache::Directive -- A Perl API for manipulating Apache configuration tree
+
+=head1 SYNOPSIS
+
+ use Apache::Directive;
+
+ my $tree = Apache::Directive->conftree;
+
+ my $documentroot = $tree->lookup('DocumentRoot');
+
+ my $vhost = $tree->lookup('VirtualHost', 'localhost:8000');
+ my $servername = $vhost->{'ServerName'};
+
+ print $tree->as_string;
+
+ use Data::Dumper;
+ print Dumper($tree->as_hash);
+
+ my $node = $tree;
+ while ($node) {
+
+ #do something with $node
+
+ if (my $kid = $node->first_child) {
+ $node = $kid;
+ }
+ elsif (my $next = $node->next) {
+ $node = $next;
+ }
+ else {
+ if (my $parent = $node->parent) {
+ $node = $parent->next;
+ }
+ else {
+ $node = undef;
+ }
+ }
+ }
+
+=head1 DESCRIPTION
+
+C<Apache::Directive> allows its users to search and navigate the internal Apache
+configuration.
+
+Internally, this information is stored in a tree structure. Each node in
+the tree has a reference to it's parent (if it's not the root), its first
+child (if any), and to its next sibling.
+
+=head1 API
+
+Function arguments (if any) and return values are shown in the
+function's synopsis.
+
+=head2 conftree()
+
+ $tree = Apache::Directive->conftree();
+
+Returns the root of the configuration tree.
+
+=head2 next()
+
+ $node = $node->next;
+
+Returns the next sibbling of C<$node>, undef otherwise
+
+=head2 first_child()
+
+ $subtree = $node->first_child;
+
+Returns the first child node of C<$node>, undef otherwise
+
+=head2 parent()
+
+ $parent = $node->parent;
+
+Returns the parent of C<$node>, undef if this node is the root node
+
+=head2 directive()
+
+ $name = $node->directive;
+
+Returns the name of the directive in C<$node>
+
+=head2 args()
+
+ $args = $node->args;
+
+Returns the arguments to this C<$node>
+
+=head2 filename()
+
+ $fname = $node->filename;
+
+Returns the filename this C<$node> was created from
+
+=head2 line_number()
+
+ $lineno = $node->line_number;
+
+Returns the line number in C<filename> this C<$node> was created from
+
+=head2 as_string()
+
+ print $tree->as_string();
+
+Returns a string representation of the configuration tree, in httpd.conf format.
+
+=head2 as_hash()
+
+ $config = $tree->as_hash();
+
+Returns a hash representation of the configuration tree, in a format suitable
+for inclusion in E<lt>PerlE<gt> sections
+
+=head2 lookup($directive, [$args])
+
+Returns node(s) matching a certain value. In list context, it will return all
+matching nodes.
+In scalar context, it will return only the first matching node.
+
+If called with only one C<$directive> value, this will return all nodes from that
+directive:
+
+ @Alias = $tree->lookup('Alias');
+
+Would return all nodes for Alias directives.
+
+If called with an extra C<$args> argument, this will return only nodes where both the
+directive
+and the args matched:
+
+ $VHost = $tree->lookup('VirtualHosts', '_default_:8000');
+
+=cut
Index: t/response/TestApache/conftree.pm
===================================================================
RCS file: /home/cvspublic/modperl-2.0/t/response/TestApache/conftree.pm,v
retrieving revision 1.4
diff -u -I'$Id' -I'$Revision' -r1.4 conftree.pm
--- t/response/TestApache/conftree.pm 19 May 2002 01:12:24 -0000 1.4
+++ t/response/TestApache/conftree.pm 29 Jan 2003 03:07:50 -0000
@@ -4,6 +4,7 @@
use warnings FATAL => 'all';
use Apache::Test;
+use Apache::TestUtil;
use Apache::TestConfig ();
use Apache::Directive ();
@@ -14,7 +15,7 @@
my $r = shift;
my $cfg = Apache::Test::config();
- plan $r, tests => 7;
+ plan $r, tests => 8;
ok $cfg;
@@ -26,43 +27,35 @@
ok $tree;
- my $port = find_config_val($tree, 'Listen');
+ my $port = $tree->lookup('Listen');
- ok $port;
+ ok t_cmp($vars->{port}, $port);
- ok $port == $vars->{port};
+ my $documentroot = $tree->lookup('DocumentRoot');
- my $documentroot = find_config_val($tree, 'DocumentRoot');
+ ok t_cmp('HASH' , ref($tree->as_hash()), 'as_hash');
- ok $documentroot;
+ ok t_cmp(qq("$vars->{documentroot}"), $documentroot);
- ok $documentroot eq qq("$vars->{documentroot}");
+ ok t_cmp(qq("$vars->{documentroot}"), $tree->lookup("DocumentRoot"));
- Apache::OK;
-}
-
-sub find_config_val {
- my($tree, $directive) = @_;
-
- while ($tree) {
- if ($directive eq $tree->directive) {
- return $tree->args;
+ #XXX: This test isn't so good, but it's quite problematic to try and _really_
+compare $cfg and $tree...
+ {
+ my %vhosts = map { $cfg->{vhosts}{$_}{'name'} => { %{$cfg->{vhosts}{$_}},
+index => $_}} keys %{$cfg->{vhosts}};
+ foreach my $v (keys %vhosts) {
+ $vhosts{ $vhosts{$v}{'index'} } = $vhosts{$v};
}
- if (my $kid = $tree->first_child) {
- $tree = $kid;
- } elsif (my $next = $tree->next) {
- $tree = $next;
- }
- else {
- if (my $parent = $tree->parent) {
- $tree = $parent->next;
- }
- else {
- $tree = undef;
+ my $vhost_failed;
+ foreach my $vhost ($tree->lookup("VirtualHost")) {
+ unless(exists $vhosts{$vhost->{'ServerName'} ||
+$vhost->{'PerlProcessConnectionHandler'}}) {
+ $vhost_failed++;
}
}
+
+ ok !$vhost_failed;
}
-}
+ Apache::OK;
+}
1;
Index: xs/Apache/Directive/Apache__Directive.h
===================================================================
RCS file: /home/cvspublic/modperl-2.0/xs/Apache/Directive/Apache__Directive.h,v
retrieving revision 1.5
diff -u -I'$Id' -I'$Revision' -r1.5 Apache__Directive.h
--- xs/Apache/Directive/Apache__Directive.h 5 Sep 2002 01:47:39 -0000 1.5
+++ xs/Apache/Directive/Apache__Directive.h 29 Jan 2003 03:08:01 -0000
@@ -17,3 +17,163 @@
return sv;
}
+
+
+/* Adds an entry to a hash, vivifying hash/array for multiple entries */
+static void hash_insert(pTHX_ HV *hash, const char *key,
+ int keylen, const char *args,
+ int argslen, SV *value)
+{
+ HV *subhash;
+ AV *args_array;
+ SV **hash_ent = hv_fetch(hash, key, keylen, 0);
+
+ if (value) {
+ if (!hash_ent) {
+ subhash = newHV();
+ hv_store(hash, key, keylen, newRV_noinc((SV *)subhash), 0);
+ }
+ else {
+ subhash = (HV *)SvRV(*hash_ent);
+ }
+
+ hv_store(subhash, args, argslen, value, 0);
+ }
+ else {
+ if (hash_ent) {
+ if(SvROK(*hash_ent) && (SVt_PVAV == SvTYPE(SvRV(*hash_ent)))) {
+ args_array = (AV *)SvRV(*hash_ent);
+ }
+ else {
+ args_array = newAV();
+ av_push(args_array, newSVsv(*hash_ent));
+ hv_store(hash, key, keylen, newRV_noinc((SV *)args_array), 0);
+ }
+ av_push(args_array, newSVpv(args, argslen));
+ }
+ else {
+ hv_store(hash, key, keylen, newSVpv(args, argslen), 0);
+ }
+ }
+}
+
+static MP_INLINE SV* mpxs_Apache__Directive_as_hash(pTHX_ ap_directive_t *tree)
+{
+ const char *directive;
+ int directive_len;
+ const char *args;
+ int args_len;
+
+ HV *hash = newHV();
+ SV *subtree;
+
+ while (tree) {
+ directive = tree->directive;
+ directive_len = strlen(directive);
+ args = tree->args;
+ args_len = strlen(args);
+
+ if (tree->first_child) {
+
+ /* Skip the prefix '<' */
+ if('<' == directive[0]) {
+ directive++;
+ directive_len--;
+ }
+
+ /* Skip the postfix '>' */
+ if('>' == args[args_len-1]) {
+ args_len--;
+ }
+
+ subtree = mpxs_Apache__Directive_as_hash(aTHX_ tree->first_child);
+ hash_insert(aTHX_ hash, directive, directive_len,
+ args, args_len, subtree);
+ }
+ else {
+ hash_insert(aTHX_ hash, directive, directive_len,
+ args, args_len, Nullsv);
+ }
+
+
+ tree = tree->next;
+ }
+
+ return newRV_noinc((SV *)hash);
+}
+
+static XS(MPXS_Apache__Directive_lookup)
+{
+ dXSARGS;
+
+ if (items < 2 || items > 3) {
+ Perl_croak(aTHX_ "Usage: Apache::Directive::lookup(self, key, [args])");
+ }
+
+ mpxs_PPCODE({
+ Apache__Directive tree;
+ char *value;
+ const char *directive;
+ const char *args;
+ int args_len;
+ int directive_len;
+
+ char *key = (char *)SvPV_nolen(ST(1));
+ int scalar_context = (G_SCALAR == GIMME_V);
+
+ if (SvROK(ST(0)) && sv_derived_from(ST(0), "Apache::Directive")) {
+ IV tmp = SvIV((SV*)SvRV(ST(0)));
+ tree = INT2PTR(Apache__Directive,tmp);
+ }
+ else {
+ tree = ap_conftree;
+ }
+
+ if (items < 3) {
+ value = NULL;
+ }
+ else {
+ value = (char *)SvPV_nolen(ST(2));
+ }
+
+ while (tree) {
+ directive = tree->directive;
+ directive_len = strlen(directive);
+
+ /* Remove starting '<' for container directives */
+ if (directive[0] == '<') {
+ directive++;
+ directive_len--;
+ }
+
+ if (0 == strncasecmp(directive, key, directive_len)) {
+
+ if (value) {
+ args = tree->args;
+ args_len = strlen(args);
+
+ /* Skip the postfix '>' */
+ if ('>' == args[args_len-1]) {
+ args_len--;
+ }
+
+ }
+
+ if ( (!value) || (0 == strncasecmp(args, value, args_len)) ) {
+ if (tree->first_child) {
+ XPUSHs(sv_2mortal(mpxs_Apache__Directive_as_hash(aTHX_
+tree->first_child)));
+ }
+ else {
+ XPUSHs(sv_2mortal(newSVpv(tree->args, 0)));
+ }
+
+ if (scalar_context) {
+ break;
+ }
+ }
+ }
+
+ tree = tree->next ? tree->next : NULL;
+ }
+ });
+}
Index: xs/maps/modperl_functions.map
===================================================================
RCS file: /home/cvspublic/modperl-2.0/xs/maps/modperl_functions.map,v
retrieving revision 1.51
diff -u -I'$Id' -I'$Revision' -r1.51 modperl_functions.map
--- xs/maps/modperl_functions.map 24 Jan 2003 07:39:29 -0000 1.51
+++ xs/maps/modperl_functions.map 29 Jan 2003 03:08:06 -0000
@@ -123,4 +123,6 @@
MODULE=Apache::Directive
mpxs_Apache__Directive_as_string
+ mpxs_Apache__Directive_as_hash
+ Apache__Directive_lookup | MPXS_ | ...
signature.asc
Description: This is a digitally signed message part
