You are viewing a plain text version of this content. The canonical link for it is here.
Posted to dev@perl.apache.org by "Philippe M. Chiasson" <go...@cpan.org> on 2003/01/27 13:00:28 UTC
[mp2 Patch] Apache::Directive->lookup($directive, [$args]);
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: dev-unsubscribe@perl.apache.org
For additional commands, e-mail: dev-help@perl.apache.org
Re: [mp2 Patch] Apache::Directive->lookup($directive, [$args]);
Posted by Stas Bekman <st...@stason.org>.
>>Regarding the xs and the test, you still had quite a few indentation problems,
>>plus too wide lines (keep under 74 or so), but I've fixed those and committed.
>
>
> Hargh ! I am still trying to figure out a way to automatically indent my
> stuff, but I am failing miserably... Can't get indent to produce
> mod_perl perfect code...
Well, I use cperl-mode in xemacs with a few tweaks it works great for me.
>>Good work, gozer! Now figure out how to get the hash preserve the keys order
>>;)
> I'd put that as a TODO item and in the meantime I'll look if I can just
> plug Tie::IxHash in there instead of a regular hash.
I remember Doug was against creating any dependancies on the external modules.
>>May be it's better to s/as_hash/as_list/, it's easy to coerce a list into a
>>hash.
>
>
> Hmm... Not sure it would be any better. Really, as_hash is used
> internally when looking up containers, like <VirtualHost> sections. It's
> after having written it that I realized it could be exposed on the Perl
> side.
Sure, but we can have both representations. Or, you can use APR::Table records
as values, which if i remember correctly preserve the order. Though I don't
think this will work with nesting, unless some magic is applied, because the
keys have to be strings.
> Figuring out a way to return a Tie::IxHash ref would certainly be the
> best solution IMHO.
it certainly can be an optional thing, or at least something for now and fixed
later to have a native solution.
__________________________________________________________________
Stas Bekman JAm_pH ------> Just Another mod_perl Hacker
http://stason.org/ mod_perl Guide ---> http://perl.apache.org
mailto:stas@stason.org http://use.perl.org http://apacheweek.com
http://modperlbook.org http://apache.org http://ticketmaster.com
---------------------------------------------------------------------
To unsubscribe, e-mail: dev-unsubscribe@perl.apache.org
For additional commands, e-mail: dev-help@perl.apache.org
Re: [mp2 Patch] Apache::Directive->lookup($directive, [$args]);
Posted by "Philippe M. Chiasson" <go...@cpan.org>.
On Wed, 2003-01-29 at 11:57, Stas Bekman wrote:
> Philippe M. Chiasson wrote:
> > Made a few minor style changes to the original patches. Thanks for the
> > extra eyeballing Stas ;-)
>
> I've committed the doc after massaging it. Still can't decide what the best
> look-n-feel for the API docs to choose, but we are getting there.
Better to have something than nuthin ;-p
> Regarding the xs and the test, you still had quite a few indentation problems,
> plus too wide lines (keep under 74 or so), but I've fixed those and committed.
Hargh ! I am still trying to figure out a way to automatically indent my
stuff, but I am failing miserably... Can't get indent to produce
mod_perl perfect code...
> Finally you've forgotten the table file, but I've grabbed the one from your
> previous post, so it's ok. ;)
Thanks, and sorry abot that.
> Good work, gozer! Now figure out how to get the hash preserve the keys order
> ;)
I'd put that as a TODO item and in the meantime I'll look if I can just
plug Tie::IxHash in there instead of a regular hash.
> May be it's better to s/as_hash/as_list/, it's easy to coerce a list into a
> hash.
Hmm... Not sure it would be any better. Really, as_hash is used
internally when looking up containers, like <VirtualHost> sections. It's
after having written it that I realized it could be exposed on the Perl
side.
Figuring out a way to return a Tie::IxHash ref would certainly be the
best solution IMHO.
> __________________________________________________________________
> Stas Bekman JAm_pH ------> Just Another mod_perl Hacker
> http://stason.org/ mod_perl Guide ---> http://perl.apache.org
> mailto:stas@stason.org http://use.perl.org http://apacheweek.com
> http://modperlbook.org http://apache.org http://ticketmaster.com
>
>
> ---------------------------------------------------------------------
> To unsubscribe, e-mail: dev-unsubscribe@perl.apache.org
> For additional commands, e-mail: dev-help@perl.apache.org
>
>
Re: [mp2 Patch] Apache::Directive->lookup($directive, [$args]);
Posted by Stas Bekman <st...@stason.org>.
Philippe M. Chiasson wrote:
> Made a few minor style changes to the original patches. Thanks for the
> extra eyeballing Stas ;-)
I've committed the doc after massaging it. Still can't decide what the best
look-n-feel for the API docs to choose, but we are getting there.
Regarding the xs and the test, you still had quite a few indentation problems,
plus too wide lines (keep under 74 or so), but I've fixed those and committed.
Finally you've forgotten the table file, but I've grabbed the one from your
previous post, so it's ok. ;)
Good work, gozer! Now figure out how to get the hash preserve the keys order
;) May be it's better to s/as_hash/as_list/, it's easy to coerce a list into a
hash.
__________________________________________________________________
Stas Bekman JAm_pH ------> Just Another mod_perl Hacker
http://stason.org/ mod_perl Guide ---> http://perl.apache.org
mailto:stas@stason.org http://use.perl.org http://apacheweek.com
http://modperlbook.org http://apache.org http://ticketmaster.com
---------------------------------------------------------------------
To unsubscribe, e-mail: dev-unsubscribe@perl.apache.org
For additional commands, e-mail: dev-help@perl.apache.org
Re: [mp2 Patch] Apache::Directive->lookup($directive, [$args]);
Posted by "Philippe M. Chiasson" <go...@cpan.org>.
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_ | ...
Re: [mp2 Patch] Apache::Directive->lookup($directive, [$args]);
Posted by Stas Bekman <st...@stason.org>.
Philippe M. Chiasson wrote:
> 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 ;-)
+1, looks cool! see a few minor comments inlined, mostly the usual style issues.
> P.S. I also kinda wanted lookup() to finish off <Perl > sections ;-p
Go gozer!
> $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
s|mod_perl-2.0//; as of yesterday ;)
> @@ -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;
use Data::Dumper; ?
> + print Dumper($tree->as_hash);
> +
> + while ($node) {
where does $node come from?
> + #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;
> + }
> + }
> + }
indent 4?
> +=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.
wrap 74, s/it's/its/
> +=head1 API
> +
> +Function arguments (if any) and return values are shown in the
> +function's synopsis.
We decided to use =head2 for functions, rather =over/=item/..., so one can
link to them and they appear in the TOC.
> +=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;
But you test it next, so this could be dropped, no?
> - 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;
same here, t_cmp knows to deal with undef if that's what you are trying to
test for.
> - 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)
> +{
- indentation of the args is off.
- also since it's static and not exposed, you can s/mpxs_apache_directive_//
> + HV *subhash;
> + AV *args_array;
> + SV **hash_ent = hv_fetch(hash, key, keylen, 0);
> +
> + if(value) {
indent here and everywhere beneath, should be 'if ()
> + 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) {
indent here and below
> + 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);
indent
> + }
> +
> +
> + 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);
debug? probably convert it into a trace print 'd'?
[...]
__________________________________________________________________
Stas Bekman JAm_pH ------> Just Another mod_perl Hacker
http://stason.org/ mod_perl Guide ---> http://perl.apache.org
mailto:stas@stason.org http://use.perl.org http://apacheweek.com
http://modperlbook.org http://apache.org http://ticketmaster.com
---------------------------------------------------------------------
To unsubscribe, e-mail: dev-unsubscribe@perl.apache.org
For additional commands, e-mail: dev-help@perl.apache.org
Re: [mp2 Patch] Apache::Directive->lookup($directive, [$args]);
Posted by Stas Bekman <st...@stason.org>.
BTW, the Apache::Directive->as_hash method is nice, but I guess that it's not
very useful, since the original order of things is lost, which will break
things if you try to feed them back or just trying to view them. If we could
use the functionality of Tie::IxHash where the keys sorting is preserved that
would be really useful then. Would do you think.
__________________________________________________________________
Stas Bekman JAm_pH ------> Just Another mod_perl Hacker
http://stason.org/ mod_perl Guide ---> http://perl.apache.org
mailto:stas@stason.org http://use.perl.org http://apacheweek.com
http://modperlbook.org http://apache.org http://ticketmaster.com
---------------------------------------------------------------------
To unsubscribe, e-mail: dev-unsubscribe@perl.apache.org
For additional commands, e-mail: dev-help@perl.apache.org