Following a discussion about how to best access the information stored in
Apache's configuration tree, I now submit Apache::Directive->lookup()
In a nutshell, one could now do this:
my $tree = Apache::Directive->conftree;
my $port = $tree->lookup('Listen');
Or even cooler:
my @vhosts = Apache::Directive->lookup('VirtualHost');
Or to search
my $vhost = Apache::Directive->lookup('VirtualHost','localhost:8888');
Feedback please ;-)
P.S. I also kinda wanted lookup() to finish off <Perl > sections ;-p
$Id: Apache-Directive-lookup.patch,v 1.7 2003/01/27 11:59:23 gozer Exp $
--- /dev/null 2002-08-31 07:31:37.000000000 +0800
+++ docs/api/mod_perl-2.0/Apache/Directive.pod 2003-01-25 17:23:56.000000000 +0800
@@ -0,0 +1,134 @@
+=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;
+ print Dumper($tree->as_hash);
+
+ 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), it's 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.
+
+=over 4
+
+=item * conftree()
+
+ $tree = Apache::Directive->conftree();
+
+Returns the root of the configuration tree.
+
+=item * next()
+
+ $node = $node->next;
+
+Returns the next sibbling of C<$node>, undef otherwise
+
+=item * first_child()
+
+ $subtree = $node->first_child;
+
+Returns the first child node of C<$node>, undef otherwise
+
+=item * parent()
+
+ $parent = $node->parent;
+
+Returns the parent of C<$node>, undef if this node is the root node
+
+=item * directive()
+
+ $name = $node->directive;
+
+Returns the name of the directive in C<$node>
+
+=item * args()
+
+ $args = $node->args;
+
+Returns the arguments to this C<$node>
+
+=item * filename()
+
+ $fname = $node->filename;
+
+Returns the filename this C<$node> was created from
+
+=item * line_number()
+
+ $lineno = $node->line_number;
+
+Returns the line number in C<filename> this C<$node> was created from
+
+=item * as_string()
+
+ print $tree->as_string();
+
+Returns a string representation of the configuration tree, in httpd.conf format.
+
+=item * 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
+
+=item * 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');
+
+=back
+
+=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 -b -B -r1.4 conftree.pm
--- t/response/TestApache/conftree.pm 19 May 2002 01:12:24 -0000 1.4
+++ t/response/TestApache/conftree.pm 27 Jan 2003 11:54:38 -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 => 10;
ok $cfg;
@@ -26,43 +27,39 @@
ok $tree;
- my $port = find_config_val($tree, 'Listen');
+ my $port = $tree->lookup('Listen');
ok $port;
- ok $port == $vars->{port};
+ ok t_cmp($vars->{port}, $port);
- my $documentroot = find_config_val($tree, 'DocumentRoot');
+ my $documentroot = $tree->lookup('DocumentRoot');
+
+ ok t_cmp('HASH' , ref($tree->as_hash()), 'as_hash');
ok $documentroot;
- ok $documentroot eq qq("$vars->{documentroot}");
+ ok t_cmp(qq("$vars->{documentroot}"), $documentroot);
- Apache::OK;
-}
+ ok t_cmp(qq("$vars->{documentroot}"), $tree->lookup("DocumentRoot"));
-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 -b -B -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 27 Jan 2003 11:54:39 -0000
@@ -17,3 +17,164 @@
return sv;
}
+
+
+/* Adds an entry to a hash, vivifying hash/array for multiple entries */
+static void mpxs_apache_directive_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);
+ mpxs_apache_directive_hash_insert(aTHX_ hash, directive, directive_len,
+ args, args_len, subtree);
+ }
+ else {
+ mpxs_apache_directive_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)) ) {
+ fprintf(stderr,"Matched for %s\n", directive);
+ 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.46
diff -u -b -B -r1.46 modperl_functions.map
--- xs/maps/modperl_functions.map 6 Dec 2002 16:19:36 -0000 1.46
+++ xs/maps/modperl_functions.map 27 Jan 2003 11:54:41 -0000
@@ -110,4 +110,6 @@
MODULE=Apache::Directive
mpxs_Apache__Directive_as_string
+ mpxs_Apache__Directive_as_hash
+ Apache__Directive_lookup | MPXS_ | ...
Index: xs/tables/current/ModPerl/FunctionTable.pm
===================================================================
RCS file: /home/cvspublic/modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm,v
retrieving revision 1.90
diff -u -b -B -r1.90 FunctionTable.pm
--- xs/tables/current/ModPerl/FunctionTable.pm 11 Jan 2003 00:02:16 -0000 1.90
+++ xs/tables/current/ModPerl/FunctionTable.pm 27 Jan 2003 11:54:43 -0000
@@ -3807,6 +3807,19 @@
]
},
{
+ 'return_type' => 'int',
+ 'name' => 'Apache__Directive_lookup',
+ 'attr' => [
+ 'static'
+ ],
+ 'args' => [
+ {
+ 'type' => 'PerlInterpreter *',
+ 'name' => 'my_perl'
+ },
+ ]
+ },
+ {
'return_type' => 'PerlInterpreter *',
'name' => 'modperl_startup',
'args' => [
@@ -4802,6 +4815,24 @@
{
'return_type' => 'SV *',
'name' => 'mpxs_Apache__Directive_as_string',
+ 'attr' => [
+ 'static',
+ '__inline__'
+ ],
+ 'args' => [
+ {
+ 'type' => 'PerlInterpreter *',
+ 'name' => 'my_perl'
+ },
+ {
+ 'type' => 'ap_directive_t *',
+ 'name' => 'self'
+ }
+ ]
+ },
+ {
+ 'return_type' => 'SV *',
+ 'name' => 'mpxs_Apache__Directive_as_hash',
'attr' => [
'static',
'__inline__'
--------------------------------------------------------------------------------
Philippe M. Chiasson /gozer\@(cpan|ectoplasm)\.org/ 88C3A5A5
(122FF51B/C634E37B)
http://gozer.ectoplasm.org/ F9BF E0C2 480E 7680 1AE5 3631 CB32 A107
88C3 A5A5
Q: It is impossible to make anything foolproof because fools are so
ingenious.
perl
-e'$$=\${gozer};{$_=unpack(P7,pack(L,$$));/^JAm_pH\n$/&&print||$$++&&redo}'
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
