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