dougm 2002/10/06 19:35:18 Modified: . Changes STATUS lib/ModPerl TestRun.pm src/modules/perl mod_perl.c modperl_cmd.c modperl_cmd.h t/conf modperl_extra.pl t/directive .cvsignore todo possible_new_features.txt Added: lib/Apache PerlSection.pm t/response/TestDirective perldo.pm Log: Submitted by: gozer Reviewed by: dougm add default <Perl> handler Apache::PerlSection. make <Perl> blocks to be EXEC_ON_READ so apache does not parse the contents. add "Perl" directive for general use and for which <Perl> sections are stuffed into. Revision Changes Path 1.51 +6 -0 modperl-2.0/Changes Index: Changes =================================================================== RCS file: /home/cvs/modperl-2.0/Changes,v retrieving revision 1.50 retrieving revision 1.51 diff -u -r1.50 -r1.51 --- Changes 7 Oct 2002 02:05:43 -0000 1.50 +++ Changes 7 Oct 2002 02:35:18 -0000 1.51 @@ -10,6 +10,12 @@ =item 1.99_08-dev +add default <Perl> handler Apache::PerlSection. +make <Perl> blocks to be EXEC_ON_READ so apache does not parse the contents. +add "Perl" directive for general use and for which <Perl> sections are +stuffed into. +[Philippe M. Chiasson <[EMAIL PROTECTED]>] + rename overloaded LoadModule directive to PerlLoadModule =item 1.99_07 - September 25, 2002 1.13 +1 -5 modperl-2.0/STATUS Index: STATUS =================================================================== RCS file: /home/cvs/modperl-2.0/STATUS,v retrieving revision 1.12 retrieving revision 1.13 diff -u -r1.12 -r1.13 --- STATUS 17 Sep 2002 02:46:20 -0000 1.12 +++ STATUS 7 Oct 2002 02:35:18 -0000 1.13 @@ -54,10 +54,6 @@ Needs Patch or Further Investigation: ------------------------------------- -* pluggable <Perl> sections have been implemented but need a default - handler to actually convert the Perl code into apache config - [Philippe M. Chiasson <[EMAIL PROTECTED]> is working on one] - * Apache->httpd_conf compat method mapping to Apache::Server->add_config * directive handlers are supported but need some work for 1.x compat 1.1 modperl-2.0/lib/Apache/PerlSection.pm Index: PerlSection.pm =================================================================== package Apache::PerlSection; use strict; use warnings FATAL => 'all'; our $VERSION = '0.01'; use ModPerl::Symdump (); use Apache::CmdParms (); use Apache::Directive (); use constant SPECIAL_NAME => 'PerlConfig'; sub new { my($package, @args) = @_; return bless { @args }, ref($package) || $package; } sub server { return shift->{'parms'}->server() } sub directives { return shift->{'directives'} ||= [] } sub handler : method { my($self, $parms, $args) = @_; unless (ref $self) { $self = $self->new('parms' => $parms, 'args' => $args); } my $package = $args->get('package'); my $special = $self->SPECIAL_NAME; my $root = ModPerl::Symdump->new($package); my %convert = ( 'scalars' => sub { no strict 'refs'; return ${ $_[0] } }, 'arrays' => sub { no strict 'refs'; return \@{ $_[0] } }, 'hashes' => sub { no strict 'refs'; return \%{ $_[0] } }, ); for my $type (sort keys %convert) { for my $entry (grep { !/$special/ } $root->$type()) { (my $name = $entry) =~ s/${package}:://; $self->dump($name, $convert{$type}->($entry)); } } { no strict 'refs'; $self->dump_special(${"${package}::$special"}, @{"${package}::$special"} ); } $self->post_config(); Apache::OK; } sub dump_special { my($self, @data) = @_; $self->add_config(@data); } sub dump { my($self, $name, $entry) = @_; my $type = ref $entry; if ($type eq 'ARRAY') { $self->dump_array($name, $entry); } elsif ($type eq 'HASH') { $self->dump_hash($name, $entry); } else { $self->dump_entry($name, $entry); } } sub dump_hash { my($self, $name, $hash) = @_; for my $entry (sort keys %{ $hash || {} }) { my $item = $hash->{$entry}; my $type = ref($item); if ($type eq 'HASH') { $self->dump_section($name, $entry, $item); } elsif ($type eq 'ARRAY') { for my $e (@$item) { $self->dump_section($name, $entry, $e); } } } } sub dump_section { my($self, $name, $loc, $hash) = @_; $self->add_config("<$name $loc>\n"); for my $entry (sort keys %{ $hash || {} }) { $self->dump_entry($entry, $hash->{$entry}); } $self->add_config("</$name>\n"); } sub dump_array { my($self, $name, $entries) = @_; for my $entry (@$entries) { $self->dump_entry($name, $entry); } } sub dump_entry { my($self, $name, $entry) = @_; my $type = ref $entry; if ($type eq 'SCALAR') { $self->add_config("$name $$entry\n"); } elsif ($type eq 'ARRAY') { $self->add_config("$name @$entry\n"); } elsif ($type eq 'HASH') { $self->dump_hash($name, $entry); } elsif ($type) { #XXX: Could do $type->can('httpd_config') here on objects ??? die "Unknown type '$type' for directive $name"; } elsif (defined $entry) { $self->add_config("$name $entry\n"); } } sub add_config { my($self, $config) = @_; return unless defined $config; chomp($config); push @{ $self->directives }, $config; } sub post_config { my($self) = @_; my $errmsg = $self->server->add_config($self->directives); die $errmsg if $errmsg; } 1; __END__ 1.6 +15 -3 modperl-2.0/lib/ModPerl/TestRun.pm Index: TestRun.pm =================================================================== RCS file: /home/cvs/modperl-2.0/lib/ModPerl/TestRun.pm,v retrieving revision 1.5 retrieving revision 1.6 diff -u -r1.5 -r1.6 --- TestRun.pm 7 Oct 2002 02:05:43 -0000 1.5 +++ TestRun.pm 7 Oct 2002 02:35:18 -0000 1.6 @@ -30,9 +30,16 @@ #XXX: issue for these is they need to happen after PerlSwitches #XXX: this should only be done for the modperl-2.0 tests - $self->postamble(<<'EOF'); -<Perl handler=ModPerl::Test::perl_section> - $Foo = 'bar'; + my $htdocs = $self->{vars}{documentroot}; + $self->postamble(<<"EOF"); +<Perl > +push \@Alias, ['/perl_sections', '$htdocs'], +\$Location{'/perl_sections'} = { + 'PerlInitHandler' => 'ModPerl::Test::add_config', + 'AuthType' => 'Basic', + 'AuthName' => 'PerlSection', + 'PerlAuthenHandler' => 'TestHooks::authen', + }; </Perl> EOF @@ -46,6 +53,11 @@ <Location /TestDirective::loadmodule> MyOtherTest value </Location> +EOF + + #XXX: this should only be done for the modperl-2.0 tests + $self->postamble(<<'EOF'); + Perl $TestDirective::perl::worked="yes"; EOF #XXX: this should only be done for the modperl-2.0 tests 1.143 +2 -1 modperl-2.0/src/modules/perl/mod_perl.c Index: mod_perl.c =================================================================== RCS file: /home/cvs/modperl-2.0/src/modules/perl/mod_perl.c,v retrieving revision 1.142 retrieving revision 1.143 diff -u -r1.142 -r1.143 --- mod_perl.c 7 Oct 2002 02:05:43 -0000 1.142 +++ mod_perl.c 7 Oct 2002 02:35:18 -0000 1.143 @@ -629,7 +629,8 @@ MP_CMD_DIR_ITERATE2("PerlAddVar", add_var, "PerlAddVar"), MP_CMD_DIR_TAKE2("PerlSetEnv", set_env, "PerlSetEnv"), MP_CMD_SRV_TAKE1("PerlPassEnv", pass_env, "PerlPassEnv"), - MP_CMD_SRV_RAW_ARGS("<Perl", perl, "NOT YET IMPLEMENTED"), + MP_CMD_SRV_RAW_ARGS_ON_READ("<Perl", perl, "Perl Code"), + MP_CMD_SRV_RAW_ARGS("Perl", perldo, "Perl Code"), MP_CMD_DIR_RAW_ARGS_ON_READ("=pod", pod, "Start of POD"), MP_CMD_DIR_RAW_ARGS_ON_READ("=back", pod, "End of =over"), 1.32 +93 -35 modperl-2.0/src/modules/perl/modperl_cmd.c Index: modperl_cmd.c =================================================================== RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_cmd.c,v retrieving revision 1.31 retrieving revision 1.32 diff -u -r1.31 -r1.32 --- modperl_cmd.c 7 Oct 2002 02:05:43 -0000 1.31 +++ modperl_cmd.c 7 Oct 2002 02:35:18 -0000 1.32 @@ -245,26 +245,24 @@ return modperl_cmd_post_read_request_handlers(parms, mconfig, arg); } -static const char *modperl_cmd_parse_args(pTHX_ apr_pool_t *p, +static const char *modperl_cmd_parse_args(apr_pool_t *p, const char *args, - HV **hv) + apr_table_t **t) { const char *orig_args = args; char *pair, *key, *val; - *hv = newHV(); + *t = apr_table_make(p, 2); while (*(pair = ap_getword(p, &args, ',')) != '\0') { key = ap_getword_nc(p, &pair, '='); val = pair; if (!(*key && *val)) { - SvREFCNT_dec(*hv); - *hv = Nullhv; return apr_pstrcat(p, "invalid args spec: ", orig_args, NULL); } - hv_store(*hv, key, strlen(key), newSVpv(val,0), 0); + apr_table_set(*t, key, val); } return NULL; @@ -273,21 +271,67 @@ MP_CMD_SRV_DECLARE(perl) { apr_pool_t *p = parms->pool; - server_rec *s = parms->server; const char *endp = ap_strrchr_c(arg, '>'); const char *errmsg; - modperl_handler_t *handler; - AV *args = Nullav; - HV *hv = Nullhv; - SV **handler_name; + char *code = ""; + char line[MAX_STRING_LEN]; + apr_table_t *args; + ap_directive_t **current = mconfig; + + if (!endp) { + return modperl_cmd_unclosed_directive(parms); + } + + arg = apr_pstrndup(p, arg, endp - arg); + + if ((errmsg = modperl_cmd_parse_args(p, arg, &args))) { + return errmsg; + } + + while (!ap_cfg_getline(line, sizeof(line), parms->config_file)) { + /*XXX: Not sure how robust this is */ + if (strEQ(line, "</Perl>")) { + break; + } + + /*XXX: Less than optimal */ + code = apr_pstrcat(p, code, line, NULL); + } + + /* Here, we have to replace our current config node for the next pass */ + if (!*current) { + *current = apr_pcalloc(p, sizeof(**current)); + } + + (*current)->filename = parms->config_file->name; + (*current)->line_num = parms->config_file->line_number; + (*current)->directive = apr_pstrdup(p, "Perl"); + (*current)->args = code; + (*current)->data = args; + + return NULL; +} + +#define MP_DEFAULT_PERLSECTION_HANDLER "Apache::PerlSection" +#define MP_DEFAULT_PERLSECTION_PACKAGE "Apache::ReadConfig" + +MP_CMD_SRV_DECLARE(perldo) +{ + apr_pool_t *p = parms->pool; + server_rec *s = parms->server; + apr_table_t *options = NULL; + const char *handler_name = NULL; + modperl_handler_t *handler = NULL; + const char *package_name = NULL; int status = OK; + AV *args = Nullav; #ifdef USE_ITHREADS MP_dSCFG(s); pTHX; #endif - if (endp == NULL) { - return modperl_cmd_unclosed_directive(parms); + if (!(arg && *arg)) { + return NULL; } /* we must init earlier than normal */ @@ -302,32 +346,46 @@ aTHX = scfg->mip->parent->perl; #endif - arg = apr_pstrndup(p, arg, endp - arg); - - if ((errmsg = modperl_cmd_parse_args(aTHX_ p, arg, &hv))) { - return errmsg; - } + /* data will be set by a <Perl> section */ + if ((options = parms->directive->data)) { + if (!(handler_name = apr_table_get(options, "handler"))) { + handler_name = apr_pstrdup(p, MP_DEFAULT_PERLSECTION_HANDLER); + apr_table_set(options, "handler", handler_name); + } + + handler = modperl_handler_new(p, handler_name); + + if (!(package_name = apr_table_get(options, "package"))) { + package_name = apr_pstrdup(p, MP_DEFAULT_PERLSECTION_PACKAGE); + apr_table_set(options, "package", package_name); + } - if (!(handler_name = hv_fetch(hv, "handler", strlen("handler"), 0))) { - /* XXX: we will have a default handler in the future */ - return "no <Perl> handler specified"; + /* put the code about to be executed in the configured package */ + arg = apr_pstrcat(p, "package ", package_name, ";", arg, NULL); } - handler = modperl_handler_new(p, SvPVX(*handler_name)); - - modperl_handler_make_args(aTHX_ &args, - "Apache::CmdParms", parms, - "HV", hv, - NULL); + eval_pv(arg, FALSE); - status = modperl_callback(aTHX_ handler, p, NULL, s, args); - - SvREFCNT_dec((SV*)args); - - if (status != OK) { - return SvTRUE(ERRSV) ? SvPVX(ERRSV) : - apr_psprintf(p, "<Perl> handler %s failed with status=%d", - handler->name, status); + if (SvTRUE(ERRSV)) { + return SvPVX(ERRSV); + } + + if (handler) { + /*XXX: This will return a blessed APR::Table, but not a tied one ;-( */ + modperl_handler_make_args(aTHX_ &args, + "Apache::CmdParms", parms, + "APR::Table", options, + NULL); + + status = modperl_callback(aTHX_ handler, p, NULL, s, args); + + SvREFCNT_dec((SV*)args); + + if (status != OK) { + return SvTRUE(ERRSV) ? SvPVX(ERRSV) : + apr_psprintf(p, "<Perl> handler %s failed with status=%d", + handler->name, status); + } } return NULL; 1.20 +5 -0 modperl-2.0/src/modules/perl/modperl_cmd.h Index: modperl_cmd.h =================================================================== RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_cmd.h,v retrieving revision 1.19 retrieving revision 1.20 diff -u -r1.19 -r1.20 --- modperl_cmd.h 16 Sep 2002 19:14:16 -0000 1.19 +++ modperl_cmd.h 7 Oct 2002 02:35:18 -0000 1.20 @@ -27,6 +27,7 @@ MP_CMD_SRV_DECLARE(options); MP_CMD_SRV_DECLARE(init_handlers); MP_CMD_SRV_DECLARE(perl); +MP_CMD_SRV_DECLARE(perldo); MP_CMD_SRV_DECLARE(pod); MP_CMD_SRV_DECLARE(pod_cut); MP_CMD_SRV_DECLARE(END); @@ -69,6 +70,10 @@ #define MP_CMD_SRV_RAW_ARGS(name, item, desc) \ AP_INIT_RAW_ARGS( name, modperl_cmd_##item, NULL, \ RSRC_CONF, desc ) + +#define MP_CMD_SRV_RAW_ARGS_ON_READ(name, item, desc) \ + AP_INIT_RAW_ARGS( name, modperl_cmd_##item, NULL, \ + RSRC_CONF|EXEC_ON_READ, desc ) #define MP_CMD_SRV_FLAG(name, item, desc) \ AP_INIT_FLAG( name, modperl_cmd_##item, NULL, \ 1.20 +0 -37 modperl-2.0/t/conf/modperl_extra.pl Index: modperl_extra.pl =================================================================== RCS file: /home/cvs/modperl-2.0/t/conf/modperl_extra.pl,v retrieving revision 1.19 retrieving revision 1.20 diff -u -r1.19 -r1.20 --- modperl_extra.pl 5 Sep 2002 01:49:32 -0000 1.19 +++ modperl_extra.pl 7 Oct 2002 02:35:18 -0000 1.20 @@ -72,43 +72,6 @@ Apache::OK; } -#<Perl handler=ModPerl::Test::perl_section> -# ... -#</Perl> -sub ModPerl::Test::perl_section { - my($parms, $args) = @_; - - require Apache::CmdParms; - require Apache::Directive; - - my $code = $parms->directive->as_string; - my $package = $args->{package} || 'Apache::ReadConfig'; - -## a real handler would do something like: -# eval "package $package; $code"; -# die $@ if $@; -## feed %Apache::ReadConfig:: to Apache::Server->add_config - - my $htdocs = Apache::server_root_relative($parms->pool, 'htdocs'); - - my @cfg = ( - "Alias /perl_sections $htdocs", - "<Location /perl_sections>", -# " require valid-user", - " PerlInitHandler ModPerl::Test::add_config", - " AuthType Basic", - " AuthName PerlSection", - " PerlAuthenHandler TestHooks::authen", - "</Location>", - ); - - my $errmsg = $parms->server->add_config(\@cfg); - - die $errmsg if $errmsg; - - Apache::OK; -} - END { warn "END in modperl_extra.pl, pid=$$\n"; } 1.3 +1 -0 modperl-2.0/t/directive/.cvsignore Index: .cvsignore =================================================================== RCS file: /home/cvs/modperl-2.0/t/directive/.cvsignore,v retrieving revision 1.2 retrieving revision 1.3 diff -u -r1.2 -r1.3 --- .cvsignore 16 Sep 2002 19:14:17 -0000 1.2 +++ .cvsignore 7 Oct 2002 02:35:18 -0000 1.3 @@ -1,3 +1,4 @@ env.t loadmodule.t pod.t +perldo.t 1.1 modperl-2.0/t/response/TestDirective/perldo.pm Index: perldo.pm =================================================================== package TestDirective::perldo; use strict; use warnings FATAL => 'all'; use Apache::Test; use Apache::TestUtil; use Apache::Const -compile => 'OK'; sub handler { my $r = shift; plan $r, tests => 1; ok t_cmp('yes', $TestDirective::perl::worked); Apache::OK; } 1; 1.14 +0 -6 modperl-2.0/todo/possible_new_features.txt Index: possible_new_features.txt =================================================================== RCS file: /home/cvs/modperl-2.0/todo/possible_new_features.txt,v retrieving revision 1.13 retrieving revision 1.14 diff -u -r1.13 -r1.14 --- possible_new_features.txt 9 Apr 2002 07:32:56 -0000 1.13 +++ possible_new_features.txt 7 Oct 2002 02:35:18 -0000 1.14 @@ -14,12 +14,6 @@ - allow <Perl></Perl> configuration sections to have read access to internal configuration structures (would be nice if we could tie a %namespace::) -- allow things like <Perl main> -- the code will be placed into 'main' - package. Of course any package can be specified and the default is - Apache::ReadConfig. That would place a little meme-fleck into - people's brains to remind them that the default package is - Apache::ReadConfig. - - setuid/gid before running any Perl code - implement PerlINC (or similar) as a nicer interface for the working