home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / Code.pm < prev    next >
Encoding:
Perl POD Document  |  2004-07-02  |  29.3 KB  |  1,132 lines
  1. # Copyright 2000-2004 The Apache Software Foundation
  2. #
  3. # Licensed under the Apache License, Version 2.0 (the "License");
  4. # you may not use this file except in compliance with the License.
  5. # You may obtain a copy of the License at
  6. #
  7. #     http://www.apache.org/licenses/LICENSE-2.0
  8. #
  9. # Unless required by applicable law or agreed to in writing, software
  10. # distributed under the License is distributed on an "AS IS" BASIS,
  11. # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  12. # See the License for the specific language governing permissions and
  13. # limitations under the License.
  14. #
  15. package ModPerl::Code;
  16.  
  17. use strict;
  18. use warnings FATAL => 'all';
  19.  
  20. use Config;
  21. use File::Spec::Functions qw(catfile catdir);
  22.  
  23. use mod_perl ();
  24. use Apache::Build ();
  25.  
  26. use Apache::TestConfig ();
  27. use Apache::TestTrace;
  28.  
  29. our $VERSION = '0.01';
  30. our @ISA = qw(Apache::Build);
  31.  
  32. my %handlers = (
  33.     Process    => [qw(ChildInit ChildExit)], #Restart PreConfig
  34.     Files      => [qw(OpenLogs PostConfig)],
  35.     PerSrv     => [qw(PostReadRequest Trans MapToStorage)],
  36.     PerDir     => [qw(HeaderParser
  37.                       Access Authen Authz
  38.                       Type Fixup Response Log Cleanup
  39.                       InputFilter OutputFilter)],
  40.     Connection => [qw(ProcessConnection)],
  41.     PreConnection => [qw(PreConnection)],
  42. );
  43.  
  44. my %hooks = map { $_, canon_lc($_) }
  45.     map { @{ $handlers{$_} } } keys %handlers;
  46.  
  47. my %not_ap_hook = map { $_, 1 } qw(child_exit response cleanup
  48.                                    output_filter input_filter);
  49.  
  50. my %not_request_hook = map { $_, 1 } qw(child_init process_connection
  51.                                         pre_connection open_logs post_config);
  52.  
  53. my %hook_proto = (
  54.     Process    => {
  55.         ret  => 'void',
  56.         args => [{type => 'apr_pool_t', name => 'p'},
  57.                  {type => 'server_rec', name => 's'},
  58.                  {type => 'dummy', name => 'MP_HOOK_VOID'}],
  59.     },
  60.     Files      => {
  61.         ret  => 'int',
  62.         args => [{type => 'apr_pool_t', name => 'pconf'},
  63.                  {type => 'apr_pool_t', name => 'plog'},
  64.                  {type => 'apr_pool_t', name => 'ptemp'},
  65.                  {type => 'server_rec', name => 's'},
  66.                  {type => 'dummy', name => 'MP_HOOK_RUN_ALL'}],
  67.     },
  68.     PerSrv     => {
  69.         ret  => 'int',
  70.         args => [{type => 'request_rec', name => 'r'}, 
  71.                  {type => 'dummy', name => 'MP_HOOK_RUN_ALL'}],
  72.     },
  73.     Connection => {
  74.         ret  => 'int',
  75.         args => [{type => 'conn_rec', name => 'c'},
  76.                  {type => 'dummy', name => 'MP_HOOK_RUN_FIRST'}],
  77.     },
  78.     PreConnection => {
  79.         ret  => 'int',
  80.         args => [{type => 'conn_rec', name => 'c'},
  81.                  {type => 'void', name => 'csd'},
  82.                  {type => 'dummy', name => 'MP_HOOK_RUN_ALL'}],
  83.     },
  84. );
  85.  
  86. my %cmd_push = (
  87.     InputFilter  => 'modperl_cmd_push_filter_handlers',
  88.     OutputFilter => 'modperl_cmd_push_filter_handlers',
  89. );
  90. my $cmd_push_default = 'modperl_cmd_push_handlers';
  91. sub cmd_push {
  92.     $cmd_push{+shift} || $cmd_push_default;
  93. }
  94.  
  95. $hook_proto{PerDir} = $hook_proto{PerSrv};
  96.  
  97. my $scfg_get = 'MP_dSCFG(parms->server)';
  98.  
  99. my $dcfg_get = "$scfg_get;\n" .
  100.   '    modperl_config_dir_t *dcfg = (modperl_config_dir_t *)dummy';
  101.  
  102. my %directive_proto = (
  103.     PerSrv     => {
  104.         args => [{type => 'cmd_parms', name => 'parms'},
  105.                  {type => 'void', name => 'dummy'},
  106.                  {type => 'const char', name => 'arg'}],
  107.         cfg  => {get => $scfg_get, name => 'scfg'},
  108.         scope => 'RSRC_CONF',
  109.     },
  110.     PerDir     => {
  111.         args => [{type => 'cmd_parms', name => 'parms'},
  112.                  {type => 'void', name => 'dummy'},
  113.                  {type => 'const char', name => 'arg'}],
  114.         cfg  => {get => $dcfg_get, name => 'dcfg'},
  115.         scope => 'OR_ALL',
  116.     },
  117. );
  118.  
  119. for my $class (qw(Process Connection PreConnection Files)) {
  120.     $directive_proto{$class}->{cfg}->{name} = 'scfg';
  121.     $directive_proto{$class}->{cfg}->{get} = $scfg_get;
  122.  
  123.     for (qw(args scope)) {
  124.         $directive_proto{$class}->{$_} = $directive_proto{PerSrv}->{$_};
  125.     }
  126. }
  127.  
  128. while (my($k,$v) = each %directive_proto) {
  129.     $directive_proto{$k}->{ret} = 'const char *';
  130.     my $handlers = join '_', 'handlers', canon_lc($k);
  131.     $directive_proto{$k}->{handlers} =
  132.       join '->', $directive_proto{$k}->{cfg}->{name}, $handlers;
  133. }
  134.  
  135. #XXX: allow disabling of PerDir hooks on a PerDir basis
  136. my @hook_flags = (map { canon_uc($_) } keys %hooks);
  137. my @ithread_opts = qw(CLONE PARENT);
  138. my %flags = (
  139.     Srv => ['NONE', @ithread_opts, qw(ENABLE AUTOLOAD MERGE_HANDLERS),
  140.             @hook_flags, 'UNSET'],
  141.     Dir => [qw(NONE PARSE_HEADERS SETUP_ENV MERGE_HANDLERS GLOBAL_REQUEST UNSET)],
  142.     Req => [qw(NONE SET_GLOBAL_REQUEST PARSE_HEADERS SETUP_ENV 
  143.                CLEANUP_REGISTERED PERL_SET_ENV_DIR PERL_SET_ENV_SRV)],
  144.     Interp => [qw(NONE IN_USE PUTBACK CLONED BASE)],
  145.     Handler => [qw(NONE PARSED METHOD OBJECT ANON AUTOLOAD DYNAMIC FAKE)],
  146. );
  147.  
  148. $flags{DirSeen} = $flags{Dir};
  149.  
  150. my %flags_options = map { $_,1 } qw(Srv Dir);
  151.  
  152. my %flags_field = (
  153.     DirSeen => 'flags->opts_seen',
  154.     (map { $_, 'flags->opts' } keys %flags_options),
  155. );
  156.  
  157. sub new {
  158.     my $class = shift;
  159.     bless {
  160.        handlers        => \%handlers,
  161.        hook_proto      => \%hook_proto,
  162.        directive_proto => \%directive_proto,
  163.        flags           => \%flags,
  164.        path            => 'src/modules/perl',
  165.     }, $class;
  166. }
  167.  
  168. sub path { shift->{path} }
  169.  
  170. sub handler_desc {
  171.     my($self, $h_add, $c_add) = @_;
  172.     local $" = ",\n";
  173.     while (my($class, $h) = each %{ $self->{handler_index_desc} }) {
  174.         my $func = canon_func('handler', 'desc', $class);
  175.         my $array = join '_', 'MP', $func;
  176.         my $proto = "const char *$func(int idx)";
  177.  
  178.         $$h_add .= "$proto;\n";
  179.  
  180.         $$c_add .= <<EOF;
  181. static const char * $array [] = {
  182. @{ [ map { $_ ? qq(    "$_") : '    NULL' } @$h, '' ] }
  183. };
  184.  
  185. $proto
  186. {
  187.     return $array [idx];
  188. }
  189.  
  190. EOF
  191.     }
  192. }
  193.  
  194. sub generate_handler_index {
  195.     my($self, $h_fh) = @_;
  196.  
  197.     my $type = 1;
  198.  
  199.     while (my($class, $handlers) = each %{ $self->{handlers} }) {
  200.         my $i = 0;
  201.         my $n = @$handlers;
  202.         my $handler_type = canon_define('HANDLER_TYPE', $class);
  203.  
  204.         print $h_fh "\n#define ",
  205.           canon_define('HANDLER_NUM', $class), " $n\n\n";
  206.  
  207.         print $h_fh "#define $handler_type $type\n\n";
  208.  
  209.         $type++;
  210.  
  211.         for my $name (@$handlers) {
  212.             my $define = canon_define($name, 'handler');
  213.             $self->{handler_index}->{$class}->[$i] = $define;
  214.             $self->{handler_index_type}->{$class}->[$i] = $handler_type;
  215.             $self->{handler_index_desc}->{$class}->[$i] = "Perl${name}Handler";
  216.             print $h_fh "#define $define $i\n";
  217.             $i++;
  218.         }
  219.     }
  220. }
  221.  
  222. sub generate_handler_hooks {
  223.     my($self, $h_fh, $c_fh) = @_;
  224.  
  225.     my @register_hooks;
  226.  
  227.     while (my($class, $prototype) = each %{ $self->{hook_proto} }) {
  228.         my $callback = canon_func('callback', $class);
  229.         my $return = $prototype->{ret} eq 'void' ? '' : 'return';
  230.         my $i = -1;
  231.  
  232.         for my $handler (@{ $self->{handlers}{$class} }) {
  233.             my $name = canon_func($handler, 'handler');
  234.             $i++;
  235.  
  236.             if (my $hook = $hooks{$handler}) {
  237.                 next if $not_ap_hook{$hook};
  238.  
  239.                 my $order = $not_request_hook{$hook} ? 'APR_HOOK_FIRST'
  240.                                                      : 'APR_HOOK_REALLY_FIRST';
  241.  
  242.                 push @register_hooks,
  243.                   "    ap_hook_$hook($name, NULL, NULL, $order);";
  244.             }
  245.  
  246.             my($protostr, $pass) = canon_proto($prototype, $name);
  247.             my $ix = $self->{handler_index}->{$class}->[$i];
  248.  
  249.             if ($callback =~ m/modperl_callback_per_(dir|srv)/) {
  250.                 if ($ix =~ m/AUTH|TYPE|TRANS|MAP/) {
  251.                     $pass =~ s/MP_HOOK_RUN_ALL/MP_HOOK_RUN_FIRST/;
  252.                 }
  253.             }
  254.  
  255.             print $h_fh "\n$protostr;\n";
  256.  
  257.             print $c_fh <<EOF;
  258. $protostr
  259. {
  260.     $return $callback($ix, $pass);
  261. }
  262.  
  263. EOF
  264.         }
  265.     }
  266.  
  267.     local $" = "\n";
  268.     my $hooks_proto = 'void modperl_register_handler_hooks(void)';
  269.     my $h_add = "$hooks_proto;\n";
  270.     my $c_add = "$hooks_proto {\n@register_hooks\n}\n";
  271.  
  272.     $self->handler_desc(\$h_add, \$c_add);
  273.  
  274.     return ($h_add, $c_add);
  275. }
  276.  
  277. sub generate_handler_find {
  278.     my($self, $h_fh, $c_fh) = @_;
  279.  
  280.     my $proto = 'int modperl_handler_lookup(const char *name, int *type)';
  281.     my(%ix, %switch);
  282.  
  283.     print $h_fh "$proto;\n";
  284.  
  285.     print $c_fh <<EOF;
  286. $proto
  287. {
  288.     if (*name == 'P' && strnEQ(name, "Perl", 4)) {
  289.         name += 4;
  290.     }
  291.  
  292.     switch (*name) {
  293. EOF
  294.  
  295.     while (my($class, $handlers) = each %{ $self->{handlers} }) {
  296.         my $i = 0;
  297.  
  298.         for my $name (@$handlers) {
  299.             $name =~ /^([A-Z])/;
  300.             push @{ $switch{$1} }, $name;
  301.             $ix{$name}->{name} = $self->{handler_index}->{$class}->[$i];
  302.             $ix{$name}->{type} = $self->{handler_index_type}->{$class}->[$i++];
  303.         }
  304.     }
  305.  
  306.     for my $key (sort keys %switch) {
  307.         my $names = $switch{$key};
  308.         print $c_fh "      case '$key':\n";
  309.  
  310.         #support $r->push_handlers(PerlHandler => ...)
  311.         if ($key eq 'H') {
  312.             print $c_fh <<EOF;
  313.           if (strEQ(name, "Handler")) {
  314.               *type = $ix{'Response'}->{type};
  315.               return $ix{'Response'}->{name};
  316.           }
  317. EOF
  318.         }
  319.  
  320.         for my $name (@$names) {
  321.             my $n = length($name);
  322.             print $c_fh <<EOF;
  323.           if (strnEQ(name, "$name", $n)) {
  324.               *type = $ix{$name}->{type};
  325.               return $ix{$name}->{name};
  326.           }
  327. EOF
  328.         }
  329.     }
  330.  
  331.     print $c_fh "    };\n    return -1;\n}\n";
  332.  
  333.     return ("", "");
  334. }
  335.  
  336. sub generate_handler_directives {
  337.     my($self, $h_fh, $c_fh) = @_;
  338.  
  339.     my @cmd_entries;
  340.  
  341.     while (my($class, $handlers) = each %{ $self->{handlers} }) {
  342.         my $prototype = $self->{directive_proto}->{$class};
  343.         my $i = 0;
  344.  
  345.         for my $h (@$handlers) {
  346.             my $h_name = join $h, qw(Perl Handler);
  347.             my $name = canon_func('cmd', $h, 'handlers');
  348.             my $cmd_name = canon_define('cmd', $h, 'entry');
  349.             my $protostr = canon_proto($prototype, $name);
  350.             my $flag = 'MpSrv' . canon_uc($h);
  351.             my $ix = $self->{handler_index}->{$class}->[$i++];
  352.             my $av = "$prototype->{handlers} [$ix]";
  353.             my $cmd_push = cmd_push($h);
  354.  
  355.             print $h_fh "$protostr;\n";
  356.  
  357.             push @cmd_entries, $cmd_name;
  358.  
  359.             print $h_fh <<EOF;
  360.  
  361. #define $cmd_name \\
  362. AP_INIT_ITERATE("$h_name", $name, NULL, \\
  363.  $prototype->{scope}, "Subroutine name")
  364.  
  365. EOF
  366.             print $c_fh <<EOF;
  367.  
  368. $protostr
  369. {
  370.     $prototype->{cfg}->{get};
  371.     if (!MpSrvENABLE(scfg)) {
  372.         return apr_pstrcat(parms->pool,
  373.                            "Perl is disabled for server ",
  374.                            parms->server->server_hostname, NULL);
  375.     }
  376.     if (!$flag(scfg)) {
  377.         return apr_pstrcat(parms->pool,
  378.                            "$h_name is disabled for server ",
  379.                            parms->server->server_hostname, NULL);
  380.     }
  381.     MP_TRACE_d(MP_FUNC, "push \@%s, %s\\n", parms->cmd->name, arg);
  382.     return $cmd_push(&($av), arg, parms->pool);
  383. }
  384. EOF
  385.         }
  386.     }
  387.  
  388.     my $h_add =  '#define MP_CMD_ENTRIES \\' . "\n" . join ', \\'."\n", @cmd_entries;
  389.  
  390.     return ($h_add, "");
  391. }
  392.  
  393. sub generate_flags {
  394.     my($self, $h_fh, $c_fh) = @_;
  395.  
  396.     my $n = 1;
  397.  
  398.     (my $dlsrc = uc $Config{dlsrc}) =~ s/\.xs$//i;
  399.  
  400.     print $h_fh "\n#define MP_SYS_$dlsrc 1\n";
  401.  
  402.     while (my($class, $opts) = each %{ $self->{flags} }) {
  403.         my @lookup = ();
  404.         my %lookup = ();
  405.         my $lookup_proto = "";
  406.         my %dumper;
  407.         if ($flags_options{$class}) {
  408.             $lookup_proto = join canon_func('flags', 'lookup', $class),
  409.               'U32 ', '(const char *str)';
  410.             push @lookup, "$lookup_proto {";
  411.         }
  412.  
  413.         my $flags = join $class, qw(Mp FLAGS);
  414.         my $field = $flags_field{$class} || 'flags';
  415.  
  416.         print $h_fh "\n#define $flags(p) (p)->$field\n";
  417.  
  418.         $class = "Mp$class";
  419.         print $h_fh "\n#define ${class}Type $n\n";
  420.         $n++;
  421.  
  422.         my $i = 0;
  423.         my $max_len = 0;
  424.         for my $f (@$opts) {
  425.             my $x = sprintf "0x%08x", $i;
  426.             my $flag = "${class}_f_$f";
  427.             my $cmd  = $class . $f;
  428.             my $name = canon_name($f);
  429.             $lookup{$name} = $flag;
  430.             $max_len = length $name if $max_len < length $name;
  431.             print $h_fh <<EOF;
  432.  
  433. /* $f */
  434. #define $flag $x
  435. #define $cmd(p)  ($flags(p) & $flag)
  436. #define ${cmd}_On(p)  ($flags(p) |= $flag)
  437. #define ${cmd}_Off(p) ($flags(p) &= ~$flag)
  438.  
  439. EOF
  440.             $dumper{$name} =
  441.               qq{modperl_trace(NULL, " $name %s", \\
  442.                          ($flags(p) & $x) ? "On " : "Off");};
  443.  
  444.             $i += $i || 1;
  445.         }
  446.         if (@lookup) {
  447.             my $indent1 = " " x 4;
  448.             my $indent2 = " " x 8;
  449.             my %switch = ();
  450.             for (keys %lookup) {
  451.                 if (/^(\w)/) {
  452.                     my $gap = " " x ($max_len - length $_);
  453.                     push @{ $switch{$1} }, 
  454.                         qq{if (strEQ(str, "$_"))$gap return $lookup{$_};};
  455.                 }
  456.             }
  457.  
  458.             push @lookup, '', $indent1 . "switch (*str) {";
  459.             for (keys %switch) {
  460.                 push @lookup, $indent1 . "  case '$_':";
  461.                 push @lookup, map { $indent2 . $_ } @{ $switch{$_} };
  462.             }
  463.             push @lookup, map { $indent1 . $_ } ("}\n", "return 0;\n}\n\n");
  464.  
  465.             print $c_fh join "\n", @lookup;
  466.             print $h_fh "$lookup_proto;\n";
  467.         }
  468.  
  469.         delete $dumper{None}; #NONE
  470.         print $h_fh join ' \\'."\n", 
  471.           "#define ${class}_dump_flags(p, str)",
  472.                      qq{modperl_trace(NULL, "$class flags dump (%s):", str);},
  473.                      map $dumper{$_}, sort keys %dumper;
  474.     }
  475.  
  476.     print $h_fh "\n#define MpSrvHOOKS_ALL_On(p) MpSrvFLAGS(p) |= (",
  477.       (join '|', map { 'MpSrv_f_' . $_ } @hook_flags), ")\n";
  478.  
  479.     print $h_fh "\n#define MpSrvOPT_ITHREAD_ONLY(o) \\\n",
  480.       (join ' || ', map("(o == MpSrv_f_$_)", @ithread_opts)), "\n";
  481.  
  482.     ();
  483. }
  484.  
  485. my %trace = (
  486.     'a' => 'Apache API interaction',
  487.     'c' => 'configuration for directive handlers',
  488.     'd' => 'directive processing',
  489.     'e' => 'environment variables',
  490.     'f' => 'filters',
  491.     'g' => 'globals management',
  492.     'h' => 'handlers',
  493.     'i' => 'interpreter pool management',
  494.     'm' => 'memory allocations',
  495.     'o' => 'I/O',
  496.     'r' => 'Perl runtime interaction',
  497.     's' => 'Perl sections',
  498.     't' => 'benchmark-ish timings',
  499. );
  500.  
  501. sub generate_trace {
  502.     my($self, $h_fh) = @_;
  503.  
  504.     my $v = $self->{build}->{VERSION};
  505.  
  506.     print $h_fh qq(#define MP_VERSION_STRING "mod_perl/$v"\n);
  507.  
  508.     my $i = 1;
  509.     my @trace = sort keys %trace;
  510.     my $opts = join '', @trace;
  511.     my $tl = "MP_debug_level";
  512.  
  513.     print $h_fh <<EOF;
  514. #define MP_TRACE_OPTS "$opts"
  515.  
  516. #ifdef MP_TRACE
  517. #define MP_TRACE_any if ($tl) modperl_trace
  518. #define MP_TRACE_any_do(exp) if ($tl) { \\
  519. exp; \\
  520. }
  521. #else
  522. #define MP_TRACE_any if (0) modperl_trace
  523. #define MP_TRACE_any_do(exp)
  524. #endif
  525.  
  526. EOF
  527.  
  528.     my @dumper;
  529.     for my $type (sort @trace) {
  530.         my $define = "#define MP_TRACE_$type";
  531.         my $define_do = join '_', $define, 'do';
  532.  
  533.         print $h_fh <<EOF;
  534. #ifdef MP_TRACE
  535. $define if ($tl & $i) modperl_trace
  536. $define_do(exp) if ($tl & $i) { \\
  537. exp; \\
  538. }
  539. #else
  540. $define if (0) modperl_trace
  541. $define_do(exp)
  542. #endif
  543. EOF
  544.         push @dumper,
  545.           qq{modperl_trace(NULL, " $type %s ($trace{$type})", ($tl & $i) ? "On " : "Off");};
  546.         $i += $i;
  547.     }
  548.  
  549.     print $h_fh join ' \\'."\n", 
  550.                      '#define MP_TRACE_dump_flags()',
  551.                      qq{modperl_trace(NULL, "mod_perl trace flags dump:");},
  552.                      @dumper;
  553.  
  554.     ();
  555. }
  556.  
  557. sub generate_largefiles {
  558.     my($self, $h_fh) = @_;
  559.  
  560.     my $flags = $self->perl_config('ccflags_uselargefiles');
  561.  
  562.     return unless $flags;
  563.  
  564.     for my $flag (split /\s+/, $flags) {
  565.         next if $flag =~ /^-/; # skip -foo flags
  566.         my($name, $val) = split '=', $flag;
  567.         $val ||= '';
  568.         $name =~ s/^-D//;
  569.         print $h_fh "#define $name $val\n";
  570.     }
  571. }
  572.  
  573. sub ins_underscore {
  574.     $_[0] =~ s/([a-z])([A-Z])/$1_$2/g;
  575. }
  576.  
  577. sub canon_uc {
  578.     my $s = shift;
  579.     ins_underscore($s);
  580.     uc $s;
  581. }
  582.  
  583. sub canon_lc {
  584.     my $s = shift;
  585.     ins_underscore($s);
  586.     lc $s;
  587. }
  588.  
  589. sub canon_func {
  590.     join '_', 'modperl', map { canon_lc($_) } @_;
  591. }
  592.  
  593. sub canon_name {
  594.     local $_ = shift;
  595.     s/([A-Z]+)/ucfirst(lc($1))/ge;
  596.     s/_//g;
  597.     $_;
  598. }
  599.  
  600. sub canon_define {
  601.     join '_', 'MP', map { canon_uc($_) } @_;
  602. }
  603.  
  604. sub canon_args {
  605.     my $args = shift->{args};
  606.     my @pass = map { $_->{name} } @$args;
  607.     my @in;
  608.     foreach my $href (@$args) {
  609.         push @in, "$href->{type} *$href->{name}"
  610.             unless $href->{type} eq 'dummy';
  611.     }
  612.     return wantarray ? (\@in, \@pass) : \@in;
  613. }
  614.  
  615. sub canon_proto {
  616.     my($prototype, $name) = @_;
  617.     my($in,$pass) = canon_args($prototype);
  618.  
  619.     local $" = ', ';
  620.  
  621.     my $p = "$prototype->{ret} $name(@$in)";
  622.     $p =~ s/\* /*/;
  623.     return wantarray ? ($p, "@$pass") : $p;
  624. }
  625.  
  626. my %sources = (
  627.    generate_handler_index      => {h => 'modperl_hooks.h'},
  628.    generate_handler_hooks      => {h => 'modperl_hooks.h',
  629.                                    c => 'modperl_hooks.c'},
  630.    generate_handler_directives => {h => 'modperl_directives.h',
  631.                                    c => 'modperl_directives.c'},
  632.    generate_handler_find       => {h => 'modperl_hooks.h',
  633.                                    c => 'modperl_hooks.c'},
  634.    generate_flags              => {h => 'modperl_flags.h',
  635.                                    c => 'modperl_flags.c'},
  636.    generate_trace              => {h => 'modperl_trace.h'},
  637.    generate_largefiles         => {h => 'modperl_largefiles.h'},
  638.    generate_constants          => {h => 'modperl_constants.h',
  639.                                    c => 'modperl_constants.c'},
  640. );
  641.  
  642. my @c_src_names = qw(interp tipool log config cmd options callback handler
  643.                      gtop util io io_apache filter bucket mgv pcw global env
  644.                      cgi perl perl_global perl_pp sys module svptr_table
  645.                      const constants apache_compat error debug
  646.                      common_util common_log);
  647. my @h_src_names = qw(perl_unembed);
  648. my @g_c_names = map { "modperl_$_" } qw(hooks directives flags xsinit);
  649. my @c_names   = ('mod_perl', (map "modperl_$_", @c_src_names));
  650. sub c_files { [map { "$_.c" } @c_names, @g_c_names] }
  651. sub o_files { [map { "$_.o" } @c_names, @g_c_names] }
  652. sub o_pic_files { [map { "$_.lo" } @c_names, @g_c_names] }
  653.  
  654. my @g_h_names = map { "modperl_$_" } qw(hooks directives flags trace
  655.                                         largefiles);
  656. my @h_names = (@c_names, map { "modperl_$_" } @h_src_names,
  657.                qw(types time apache_includes perl_includes apr_includes
  658.                   common_includes common_types));
  659. sub h_files { [map { "$_.h" } @h_names, @g_h_names] }
  660.  
  661. sub clean_files {
  662.     my @c_names = @g_c_names;
  663.     my @h_names = @g_h_names;
  664.  
  665.     for (\@c_names, \@h_names) {
  666.         push @$_, 'modperl_constants';
  667.     }
  668.  
  669.     [(map { "$_.c" } @c_names), (map { "$_.h" } @h_names)];
  670. }
  671.  
  672. sub classname {
  673.     my $self = shift || __PACKAGE__;
  674.     ref($self) || $self;
  675. }
  676.  
  677. sub noedit_warning_c {
  678.     my $class = classname(shift);
  679.  
  680.     my $v = join '/', $class, $class->VERSION;
  681.     my $trace = Apache::TestConfig::calls_trace();
  682.     $trace =~ s/^/ * /mg;
  683.     return <<EOF;
  684.  
  685. /*
  686.  * *********** WARNING **************
  687.  * This file generated by $v
  688.  * Any changes made here will be lost
  689.  * ***********************************
  690. $trace */
  691.  
  692. EOF
  693. }
  694.  
  695. #this is named hash after the `#' character
  696. #rather than named perl, since #comments are used
  697. #non-Perl files, e.g. Makefile, typemap, etc.
  698. sub noedit_warning_hash {
  699.     my $class = classname(shift);
  700.  
  701.     (my $warning = noedit_warning_c($class)) =~ s/^/\# /mg;
  702.     return $warning;
  703. }
  704.  
  705. sub init_file {
  706.     my($self, $name) = @_;
  707.  
  708.     return unless $name;
  709.     return if $self->{init_files}->{$name}++;
  710.  
  711.     my(@preamble);
  712.     if ($name =~ /\.h$/) {
  713.         (my $d = uc $name) =~ s/\./_/;
  714.         push @preamble, "#ifndef $d\n#define $d\n";
  715.         push @{ $self->{postamble}->{$name} }, "\n#endif /* $d */\n";
  716.     }
  717.     elsif ($name =~ /\.c/) {
  718.         push @preamble, qq{\#include "mod_perl.h"\n\n};
  719.     }
  720.  
  721.     my $file = "$self->{path}/$name";
  722.     debug "generating...$file";
  723.     unlink $file;
  724.     open my $fh, '>>', $file or die "open $file: $!";
  725.     print $fh @preamble, noedit_warning_c();
  726.  
  727.     $self->{fh}->{$name} = $fh;
  728. }
  729.  
  730. sub fh {
  731.     my($self, $name) = @_;
  732.     return unless $name;
  733.     $self->{fh}->{$name};
  734. }
  735.  
  736. sub postamble {
  737.     my $self = shift;
  738.     for my $name (keys %{ $self->{fh} }) {
  739.         next unless my $av = $self->{postamble}->{$name};
  740.         print { $self->fh($name) } @$av;
  741.     }
  742. }
  743.  
  744. sub generate {
  745.     my($self, $build) = @_;
  746.  
  747.     $self->{build} = $build;
  748.  
  749.     for my $s (values %sources) {
  750.         for (qw(h c)) {
  751.             $self->init_file($s->{$_});
  752.         }
  753.     }
  754.  
  755.     for my $method (reverse sort keys %sources) {
  756.         my($h_fh, $c_fh) = map {
  757.             $self->fh($sources{$method}->{$_});
  758.         } qw(h c);
  759.         my($h_add, $c_add) = $self->$method($h_fh, $c_fh);
  760.         if ($h_add) {
  761.             print $h_fh $h_add;
  762.         }
  763.         if ($c_add) {
  764.             print $c_fh $c_add;
  765.         }
  766.         debug "$method...done";
  767.     }
  768.  
  769.     $self->postamble;
  770.  
  771.     my $xsinit = "$self->{path}/modperl_xsinit.c";
  772.     debug "generating...$xsinit";
  773.  
  774.     #create bootstrap method for static xs modules
  775.     my $static_xs = [keys %{ $build->{XS} }];
  776.     ExtUtils::Embed::xsinit($xsinit, 1, $static_xs);
  777.  
  778.     #$self->generate_constants_pod();
  779. }
  780.  
  781. my $constant_prefixes = join '|', qw{APR? MODPERL_RC};
  782.  
  783. sub generate_constants {
  784.     my($self, $h_fh, $c_fh) = @_;
  785.  
  786.     require Apache::ConstantsTable;
  787.  
  788.     print $c_fh qq{\#include "modperl_const.h"\n};
  789.     print $h_fh "#define MP_ENOCONST -3\n\n";
  790.  
  791.     generate_constants_lookup($h_fh, $c_fh);
  792.     generate_constants_group_lookup($h_fh, $c_fh);
  793. }
  794.  
  795. my %shortcuts = (
  796.      NOT_FOUND => 'HTTP_NOT_FOUND',
  797.      FORBIDDEN => 'HTTP_FORBIDDEN',
  798.      AUTH_REQUIRED => 'HTTP_UNAUTHORIZED',
  799.      SERVER_ERROR => 'HTTP_INTERNAL_SERVER_ERROR',
  800.      REDIRECT => 'HTTP_MOVED_TEMPORARILY',
  801. );
  802.  
  803. #backwards compat with older httpd/apr
  804. #XXX: remove once we require newer httpd/apr
  805. my %ifdef = map { $_, 1 } 
  806.     qw(APLOG_TOCLIENT APR_LIMIT_NOFILE), # added in ???
  807.     qw(AP_MPMQ_STARTING AP_MPMQ_RUNNING AP_MPMQ_STOPPING 
  808.        AP_MPMQ_MPM_STATE); # added in 2.0.49
  809.  
  810. sub constants_ifdef {
  811.     my $name = shift;
  812.  
  813.     if ($ifdef{$name}) {
  814.         return ("#ifdef $name\n", "#endif /* $name */\n");
  815.     }
  816.  
  817.     ("", "");
  818. }
  819.  
  820. sub constants_lookup_code {
  821.     my($h_fh, $c_fh, $constants, $class) = @_;
  822.  
  823.     my(%switch, %alias);
  824.  
  825.     %alias = %shortcuts;
  826.  
  827.     my $postfix = lc $class;
  828.     my $package = $class . '::';
  829.     my $package_len = length $package;
  830.     my($first_let) = $class =~ /^(\w)/;
  831.  
  832.     my $func = canon_func(qw(constants lookup), $postfix);
  833.     my $proto = "SV \*$func(pTHX_ const char *name)";
  834.  
  835.     print $h_fh "$proto;\n";
  836.  
  837.     print $c_fh <<EOF;
  838.  
  839. $proto
  840. {
  841.     if (*name == '$first_let' && strnEQ(name, "$package", $package_len)) {
  842.         name += $package_len;
  843.     }
  844.  
  845.     switch (*name) {
  846. EOF
  847.  
  848.     for (@$constants) {
  849.         if (s/^($constant_prefixes)(_)?//o) {
  850.             $alias{$_} = join $2 || "", $1, $_;
  851.         }
  852.         else {
  853.             $alias{$_} ||= $_;
  854.         }
  855.         next unless /^([A-Z])/;
  856.         push @{ $switch{$1} }, $_;
  857.     }
  858.  
  859.     for my $key (sort keys %switch) {
  860.         my $names = $switch{$key};
  861.         print $c_fh "      case '$key':\n";
  862.  
  863.         for my $name (@$names) {
  864.             my @ifdef = constants_ifdef($alias{$name});
  865.             print $c_fh <<EOF;
  866. $ifdef[0]
  867.           if (strEQ(name, "$name")) {
  868. EOF
  869.  
  870.             if ($name eq 'DECLINE_CMD' || 
  871.                 $name eq 'DIR_MAGIC_TYPE' ||
  872.                 $name eq 'CRLF') {
  873.                 print $c_fh <<EOF;
  874.               return newSVpv($alias{$name}, 0);
  875. EOF
  876.             }
  877.             else {
  878.                 print $c_fh <<EOF;
  879.               return newSViv($alias{$name});
  880. EOF
  881.             }
  882.  
  883.             print $c_fh <<EOF;
  884.           }
  885. $ifdef[1]
  886. EOF
  887.         }
  888.         print $c_fh "      break;\n";
  889.     }
  890.  
  891.     print $c_fh <<EOF
  892.     };
  893.     Perl_croak(aTHX_ "unknown $class\:: constant %s", name);
  894.     return newSViv(MP_ENOCONST);
  895. }
  896. EOF
  897. }
  898.  
  899. sub generate_constants_lookup {
  900.     my($h_fh, $c_fh) = @_;
  901.  
  902.     while (my($class, $groups) = each %$Apache::ConstantsTable) {
  903.         my $constants = [map { @$_ } values %$groups];
  904.  
  905.         constants_lookup_code($h_fh, $c_fh, $constants, $class);
  906.     }
  907. }
  908.  
  909. sub generate_constants_group_lookup {
  910.     my($h_fh, $c_fh) = @_;
  911.  
  912.     while (my($class, $groups) = each %$Apache::ConstantsTable) {
  913.         constants_group_lookup_code($h_fh, $c_fh, $class, $groups);
  914.     }
  915. }
  916.  
  917. sub constants_group_lookup_code {
  918.     my($h_fh, $c_fh, $class, $groups) = @_;
  919.     my @tags;
  920.     my @code;
  921.  
  922.     $class = lc $class;
  923.     while (my($group, $constants) = each %$groups) {
  924.     push @tags, $group;
  925.         my $name = join '_', 'MP_constants', $class, $group;
  926.     print $c_fh "\nstatic const char *$name [] = { \n",
  927.           (map {
  928.               my @ifdef = constants_ifdef($_);
  929.               s/^($constant_prefixes)_?//o;
  930.               qq($ifdef[0]   "$_",\n$ifdef[1])
  931.           } @$constants), "   NULL,\n};\n";
  932.     }
  933.  
  934.     my %switch;
  935.     for (@tags) {
  936.         next unless /^([A-Z])/i;
  937.         push @{ $switch{$1} }, $_;
  938.     }
  939.  
  940.     my $func = canon_func(qw(constants group lookup), $class);
  941.  
  942.     my $proto = "const char **$func(const char *name)";
  943.  
  944.     print $h_fh "$proto;\n";
  945.     print $c_fh "\n$proto\n{\n", "   switch (*name) {\n";
  946.  
  947.     for my $key (sort keys %switch) {
  948.     my $val = $switch{$key};
  949.     print $c_fh "\tcase '$key':\n";
  950.     for my $group (@$val) {
  951.             my $name = join '_', 'MP_constants', $class, $group;
  952.         print $c_fh qq|\tif(strEQ("$group", name))\n\t   return $name;\n|;
  953.     }
  954.         print $c_fh "      break;\n";
  955.     }
  956.  
  957.     print $c_fh <<EOF;
  958.     };
  959.     Perl_croak_nocontext("unknown $class\:: group `%s'", name);
  960.     return NULL;
  961. }
  962. EOF
  963. }
  964.  
  965. my %seen_const = ();
  966. # generates APR::Const and Apache::Const manpages in ./tmp/
  967. sub generate_constants_pod {
  968.     my($self) = @_;
  969.  
  970.     my %data = ();
  971.     generate_constants_group_lookup_doc(\%data);
  972.     generate_constants_lookup_doc(\%data);
  973.  
  974.     # XXX: may be dump %data into ModPerl::MethodLookup and provide an
  975.     # easy api to map const groups to constants and vice versa
  976.  
  977.     require File::Path;
  978.     my $file = "Const.pod";
  979.     for my $class (keys %data) {
  980.         my $path = catdir "tmp", $class;
  981.         File::Path::mkpath($path, 0, 0755);
  982.         my $filepath = catfile $path, $file;
  983.         open my $fh, ">$filepath" or die "Can't open $filepath: $!\n";
  984.  
  985.         print $fh <<"EOF";
  986. =head1 NAME
  987.  
  988. $class\::Const - Perl Interface for $class Constants
  989.  
  990. =head1 SYNOPSIS
  991.  
  992. =head1 CONSTANTS
  993.  
  994. EOF
  995.  
  996.         my $groups = $data{$class};
  997.         for my $group (sort keys %$groups) {
  998.             print $fh <<"EOF";
  999.  
  1000.  
  1001.  
  1002. =head2 C<:$group>
  1003.  
  1004.   use $class\::Const -compile qw(:$group);
  1005.  
  1006. The C<:$group> group is for XXX constants.
  1007.  
  1008. EOF
  1009.  
  1010.             for my $const (sort @{ $groups->{$group} }) {
  1011.                 print $fh "=head3 C<$class\::$const>\n\n\n";
  1012.             }
  1013.         }
  1014.  
  1015.         print $fh "=cut\n";
  1016.     }
  1017. }
  1018.  
  1019. sub generate_constants_lookup_doc {
  1020.     my($data) = @_;
  1021.  
  1022.     while (my($class, $groups) = each %$Apache::ConstantsTable) {
  1023.         my $constants = [map { @$_ } values %$groups];
  1024.  
  1025.         constants_lookup_code_doc($constants, $class, $data);
  1026.     }
  1027. }
  1028.  
  1029. sub generate_constants_group_lookup_doc {
  1030.     my($data) = @_;
  1031.  
  1032.     while (my($class, $groups) = each %$Apache::ConstantsTable) {
  1033.         constants_group_lookup_code_doc($class, $groups, $data);
  1034.     }
  1035. }
  1036.  
  1037. sub constants_group_lookup_code_doc {
  1038.     my($class, $groups, $data) = @_;
  1039.     my @tags;
  1040.     my @code;
  1041.  
  1042.     while (my($group, $constants) = each %$groups) {
  1043.         $data->{$class}{$group} = [
  1044.             map {
  1045.                 my @ifdef = constants_ifdef($_);
  1046.                 s/^($constant_prefixes)_?//o;
  1047.                 $seen_const{$class}{$_}++;
  1048.                 $_;
  1049.             } @$constants
  1050.         ];
  1051.     }
  1052. }
  1053.  
  1054. sub constants_lookup_code_doc {
  1055.     my($constants, $class, $data) = @_;
  1056.  
  1057.     my(%switch, %alias);
  1058.  
  1059.     %alias = %shortcuts;
  1060.  
  1061.     my $postfix = lc $class;
  1062.     my $package = $class . '::';
  1063.     my $package_len = length $package;
  1064.  
  1065.     my $func = canon_func(qw(constants lookup), $postfix);
  1066.  
  1067.     for (@$constants) {
  1068.         if (s/^($constant_prefixes)(_)?//o) {
  1069.             $alias{$_} = join $2 || "", $1, $_;
  1070.         }
  1071.         else {
  1072.             $alias{$_} ||= $_;
  1073.         }
  1074.         next unless /^([A-Z])/;
  1075.         push @{ $switch{$1} }, $_;
  1076.     }
  1077.  
  1078.     for my $key (sort keys %switch) {
  1079.         my $names = $switch{$key};
  1080.         for my $name (@$names) {
  1081.             my @ifdef = constants_ifdef($alias{$name});
  1082.             push @{ $data->{$class}{other} }, $name
  1083.                 unless $seen_const{$class}{$name}
  1084.         }
  1085.     }
  1086. }
  1087.  
  1088. # src/modules/perl/*.c files needed to build APR/APR::* outside
  1089. # of mod_perl.so
  1090. sub src_apr_ext {
  1091.     return map { "modperl_$_" } (qw(error bucket),
  1092.                                   map { "common_$_" } qw(util log));
  1093. }
  1094.  
  1095. 1;
  1096. __END__
  1097.  
  1098. =head1 NAME
  1099.  
  1100. ModPerl::Code - Generate mod_perl glue code
  1101.  
  1102. =head1 SYNOPSIS
  1103.  
  1104.   use ModPerl::Code ();
  1105.   my $code = ModPerl::Code->new;
  1106.   $code->generate;
  1107.  
  1108. =head1 DESCRIPTION
  1109.  
  1110. This module provides functionality for generating mod_perl glue code.
  1111. Reason this code is generated rather than written by hand include:
  1112.  
  1113. =over 4
  1114.  
  1115. =item consistency
  1116.  
  1117. =item thin and clean glue code
  1118.  
  1119. =item enable/disable features (without #ifdefs)
  1120.  
  1121. =item adapt to changes in Apache
  1122.  
  1123. =item experiment with different approaches to gluing
  1124.  
  1125. =back
  1126.  
  1127. =head1 AUTHOR
  1128.  
  1129. Doug MacEachern
  1130.  
  1131. =cut
  1132.