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 / WrapXS.pm < prev    next >
Encoding:
Perl POD Document  |  2004-07-09  |  32.9 KB  |  1,271 lines
  1. # Copyright 2001-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::WrapXS;
  16.  
  17. use strict;
  18. use warnings FATAL => 'all';
  19.  
  20. use constant GvUNIQUE => 0; #$] >= 5.008;
  21. use Apache::TestTrace;
  22. use Apache::Build ();
  23. use ModPerl::Code ();
  24. use ModPerl::TypeMap ();
  25. use ModPerl::MapUtil qw(function_table xs_glue_dirs);
  26. use File::Path qw(rmtree mkpath);
  27. use Cwd qw(fastcwd);
  28. use Data::Dumper;
  29. use File::Spec::Functions qw(catfile catdir);
  30.  
  31. our $VERSION = '0.01';
  32.  
  33. my(@xs_includes) = ('mod_perl.h',
  34.                     map "modperl_xs_$_.h", qw(sv_convert util typedefs));
  35.  
  36. my @global_structs = qw(perl_module);
  37.  
  38. my $build = Apache::Build->build_config;
  39. push @global_structs, 'MP_debug_level' unless Apache::Build::WIN32;
  40.  
  41. sub new {
  42.     my $class = shift;
  43.  
  44.     my $self = bless {
  45.        typemap   => ModPerl::TypeMap->new,
  46.        includes  => \@xs_includes,
  47.        glue_dirs => [xs_glue_dirs()],
  48.     }, $class;
  49.  
  50.     $self->typemap->get;
  51.     $self;
  52. }
  53.  
  54. sub typemap  { shift->{typemap} }
  55.  
  56. sub includes { shift->{includes} }
  57.  
  58. sub function_list {
  59.     my $self = shift;
  60.     my(@list) = @{ function_table() };
  61.  
  62.     while (my($name, $val) = each %{ $self->typemap->function_map }) {
  63.         #entries that do not exist in C::Scan generated tables
  64.         next unless $name =~ /^DEFINE_/;
  65.         push @list, $val;
  66.     }
  67.  
  68.     return \@list;
  69. }
  70.  
  71. sub get_functions {
  72.     my $self = shift;
  73.     my $typemap = $self->typemap;
  74.  
  75.     for my $entry (@{ $self->function_list() }) {
  76.         my $func = $typemap->map_function($entry);
  77.         #print "FAILED to map $entry->{name}\n" unless $func;
  78.         next unless $func;
  79.  
  80.         my($name, $module, $class, $args) =
  81.           @{ $func } { qw(perl_name module class args) };
  82.  
  83.         $self->{XS}->{ $module } ||= [];
  84.  
  85.         #eg ap_fputs()
  86.         if ($name =~ s/^DEFINE_//) {
  87.             $func->{name} =~ s/^DEFINE_//;
  88.  
  89.             if (needs_prefix($func->{name})) {
  90.                 #e.g. DEFINE_add_output_filter
  91.                 $func->{name} = make_prefix($func->{name}, $class);
  92.             }
  93.         }
  94.  
  95.         my $xs_parms = join ', ',
  96.           map { defined $_->{default} ?
  97.                   "$_->{name}=$_->{default}" : $_->{name} } @$args;
  98.  
  99.         (my $parms = $xs_parms) =~ s/=[^,]+//g; #strip defaults
  100.  
  101.         my $proto = join "\n",
  102.           (map "    $_->{type} $_->{name}", @$args), "";
  103.  
  104.         my($dispatch, $orig_args) =
  105.           @{ $func } {qw(dispatch orig_args)};
  106.  
  107.         if ($dispatch =~ /^MPXS_/) {
  108.             $name =~ s/^mpxs_//;
  109.             $name =~ s/^$func->{prefix}//;
  110.             push @{ $self->{newXS}->{ $module } },
  111.               ["$class\::$name", $dispatch];
  112.             next;
  113.         }
  114.  
  115.         my $passthru = @$args && $args->[0]->{name} eq '...';
  116.         if ($passthru) {
  117.             $parms = '...';
  118.             $proto = '';
  119.         }
  120.  
  121.         my $return_type =
  122.           $name =~ /^DESTROY$/ ? 'void' : $func->{return_type};
  123.  
  124.         my $attrs = $self->attrs($name);
  125.  
  126.         my $code = <<EOF;
  127. $return_type
  128. $name($xs_parms)
  129. $proto
  130. $attrs
  131. EOF
  132.  
  133.         if ($dispatch || $orig_args || $func->{thx}) {
  134.             my $thx = $func->{thx} ? 'aTHX_ ' : "";
  135.  
  136.             if ($dispatch) {
  137.                 $thx = 'aTHX_ ' if $dispatch =~ /^mpxs_/i;
  138.             }
  139.             else {
  140.                 if ($orig_args and @$orig_args == @$args) {
  141.                     #args were reordered
  142.                     $parms = join ', ', @$orig_args;
  143.                 }
  144.  
  145.                 $dispatch = $func->{name};
  146.             }
  147.  
  148.             if ($passthru) {
  149.                 $thx ||= 'aTHX_ ';
  150.                 $parms = 'items, MARK+1, SP';
  151.             }
  152.  
  153.             $thx =~ s/_ $// unless $parms;
  154.  
  155.             my $retval = $return_type eq 'void' ?
  156.               ["", ""] : ["RETVAL = ", "OUTPUT:\n    RETVAL\n"];
  157.  
  158.             $code .= <<EOF;
  159.     CODE:
  160.     $retval->[0]$dispatch($thx$parms);
  161.  
  162.     $retval->[1]
  163. EOF
  164.         }
  165.  
  166.         $func->{code} = $code;
  167.         push @{ $self->{XS}->{ $module } }, $func;
  168.     }
  169. }
  170.  
  171. sub get_value {
  172.     my $e = shift;
  173.     my $val = 'val';
  174.  
  175.     if ($e->{class} eq 'PV') {
  176.         if (my $pool = $e->{pool}) {
  177.             $pool .= '(obj)';
  178.             $val = "(SvOK(ST(1)) ?
  179.                     apr_pstrndup($pool, val, val_len) : NULL)"
  180.         }
  181.     }
  182.  
  183.     return $val;
  184. }
  185.  
  186. sub get_structures {
  187.     my $self = shift;
  188.     my $typemap = $self->typemap;
  189.  
  190.     require Apache::StructureTable;
  191.     for my $entry (@$Apache::StructureTable) {
  192.         my $struct = $typemap->map_structure($entry);
  193.         next unless $struct;
  194.  
  195.         my $class = $struct->{class};
  196.  
  197.         for my $e (@{ $struct->{elts} }) {
  198.             my($name, $default, $type, $access_mode) =
  199.               @{$e}{qw(name default type access_mode)};
  200.  
  201.             (my $cast = $type) =~ s/:/_/g;
  202.             my $val = get_value($e);
  203.  
  204.             my $type_in = $type;
  205.             my $preinit = "/*nada*/";
  206.             if ($e->{class} eq 'PV' and $val ne 'val') {
  207.                 $type_in =~ s/char/char_len/;
  208.                 $preinit = "STRLEN val_len;";
  209.             }
  210.  
  211.             my $attrs = $self->attrs($name);
  212.  
  213.             my $code;
  214.             if ($access_mode eq 'ro') {
  215.                 $code = <<EOF;
  216. $type
  217. $name(obj)
  218.     $class obj
  219.  
  220. $attrs
  221.  
  222.     CODE:
  223.     RETVAL = ($cast) obj->$name;
  224.  
  225.     OUTPUT:
  226.     RETVAL
  227.  
  228. EOF
  229.             }
  230.             elsif ($access_mode eq 'rw' or $access_mode eq 'r+w_startup') {
  231.  
  232.                 my $check_runtime = $access_mode eq 'rw'
  233.                     ? ''
  234.                     : qq[MP_CROAK_IF_THREADS_STARTED("setting $name");];
  235.  
  236.                 $code = <<EOF;
  237. $type
  238. $name(obj, val=$default)
  239.     $class obj
  240.     $type_in val
  241.  
  242.     PREINIT:
  243.     $preinit
  244. $attrs
  245.  
  246.     CODE:
  247.     RETVAL = ($cast) obj->$name;
  248.  
  249.     if (items > 1) {
  250.          $check_runtime
  251.          obj->$name = ($cast) $val;
  252.     }
  253.  
  254.     OUTPUT:
  255.     RETVAL
  256.  
  257. EOF
  258.             }
  259.             elsif ($access_mode eq 'rw_char_undef') {
  260.                 my $pool = $e->{pool} 
  261.                     or die "rw_char_undef accessors need pool";
  262.                 $pool .= '(obj)';
  263. # XXX: not sure where val=$default is coming from, but for now use
  264. # hardcoded Nullsv
  265.                 $code = <<EOF;
  266. $type
  267. $name(obj, val_sv=Nullsv)
  268.     $class obj
  269.     SV *val_sv
  270.  
  271.     PREINIT:
  272. $attrs
  273.  
  274.     CODE:
  275.     RETVAL = ($cast) obj->$name;
  276.  
  277.     if (val_sv) {
  278.         if (SvOK(val_sv)) {
  279.             STRLEN val_len;
  280.             char *val = (char *)SvPV(val_sv, val_len);
  281.             obj->$name = apr_pstrndup($pool, val, val_len);
  282.         }
  283.         else {
  284.             obj->$name = NULL;
  285.         }
  286.     }
  287.  
  288.     OUTPUT:
  289.     RETVAL
  290.  
  291. EOF
  292.             }
  293.  
  294.             push @{ $self->{XS}->{ $struct->{module} } }, {
  295.                code  => $code,
  296.                class => $class,
  297.                name  => $name,
  298.             };
  299.         }
  300.     }
  301. }
  302.  
  303. sub prepare {
  304.     my $self = shift;
  305.     $self->{DIR} = 'WrapXS';
  306.     $self->{XS_DIR} = catdir fastcwd(), 'xs';
  307.  
  308.     my $verbose = Apache::TestTrace::trace_level() eq 'debug' ? 1 : 0;
  309.  
  310.     if (-e $self->{DIR}) {
  311.         rmtree([$self->{DIR}], $verbose, 1);
  312.     }
  313.  
  314.     mkpath [$self->{DIR}], $verbose, 0755;
  315. }
  316.  
  317. sub class_dirname {
  318.     my($self, $class) = @_;
  319.     my($base, $sub) = split '::', $class;
  320.     return "$self->{DIR}/$base" unless $sub; #Apache | APR
  321.     return $sub if $sub eq $self->{DIR}; #WrapXS
  322.     return "$base/$sub";
  323. }
  324.  
  325. sub class_dir {
  326.     my($self, $class) = @_;
  327.  
  328.     my $dirname = $self->class_dirname($class);
  329.     my $dir = ($dirname =~ m:/: and $dirname !~ m:^$self->{DIR}:) ?
  330.       catdir($self->{DIR}, $dirname) : $dirname;
  331.  
  332.     unless (-d $dir) {
  333.         mkpath [$dir], 0, 0755;
  334.         debug "mkdir.....$dir";
  335.     }
  336.  
  337.     $dir;
  338. }
  339.  
  340. sub class_file {
  341.     my($self, $class, $file) = @_;
  342.     catfile $self->class_dir($class), $file;
  343. }
  344.  
  345. sub cname {
  346.     my($self, $class) = @_;
  347.     $class =~ s/:/_/g;
  348.     $class;
  349. }
  350.  
  351. sub open_class_file {
  352.     my($self, $class, $file) = @_;
  353.  
  354.     if ($file =~ /^\./) {
  355.         my $sub = (split '::', $class)[-1];
  356.         $file = $sub . $file;
  357.     }
  358.  
  359.     my $name = $self->class_file($class, $file);
  360.  
  361.     open my $fh, '>', $name or die "open $name: $!";
  362.     debug "writing...$name";
  363.  
  364.     return $fh;
  365. }
  366.  
  367. sub write_makefilepl {
  368.     my($self, $class) = @_;
  369.  
  370.     my $fh = $self->open_class_file($class, 'Makefile.PL');
  371.  
  372.     my $includes = $self->includes;
  373.     my $xs = (split '::', $class)[-1] . '.c';
  374.     my $deps = {$xs => ""};
  375.  
  376.     if (my $mod_h = $self->mod_h($class, 1)) {
  377.         $deps->{$xs} .= " $mod_h";
  378.     }
  379.  
  380.     local $Data::Dumper::Terse = 1;
  381.     $deps = Dumper $deps;
  382.  
  383.     my $noedit_warning = $self->ModPerl::Code::noedit_warning_hash();
  384.  
  385.     print $fh <<EOF;
  386. $noedit_warning
  387.  
  388. use lib qw(../../../lib); #for Apache::BuildConfig
  389. use ModPerl::BuildMM ();
  390.  
  391. ModPerl::BuildMM::WriteMakefile(
  392.     'NAME'    => '$class',
  393.     'VERSION' => '0.01',
  394.     'depend'  => $deps,
  395. );
  396. EOF
  397.  
  398.     close $fh;
  399. }
  400.  
  401. sub mod_h {
  402.     my($self, $module, $complete) = @_;
  403.  
  404.     my $dirname = $self->class_dirname($module);
  405.     my $cname = $self->cname($module);
  406.     my $mod_h = "$dirname/$cname.h";
  407.  
  408.     for ($self->{XS_DIR}, @{ $self->{glue_dirs} }) {
  409.         my $file = "$_/$mod_h";
  410.         $mod_h = $file if $complete;
  411.         return $mod_h if -e $file;
  412.     }
  413.  
  414.     undef;
  415. }
  416.  
  417. sub mod_pm {
  418.     my($self, $module, $complete) = @_;
  419.  
  420.     my $dirname = $self->class_dirname($module);
  421.     my($base, $sub) = split '::', $module;
  422.     my $mod_pm = "$dirname/${sub}_pm";
  423.  
  424.     for ($self->{XS_DIR}, @{ $self->{glue_dirs} }) {
  425.         my $file = "$_/$mod_pm";
  426.         $mod_pm = $file if $complete;
  427.         return $mod_pm if -e $file;
  428.     }
  429.  
  430.     undef;
  431. }
  432.  
  433. sub class_c_prefix {
  434.     my $class = shift;
  435.     $class =~ s/:/_/g;
  436.     $class;
  437. }
  438.  
  439. sub class_mpxs_prefix {
  440.     my $class = shift;
  441.     my $class_prefix = class_c_prefix($class);
  442.     "mpxs_${class_prefix}_";
  443. }
  444.  
  445. sub needs_prefix {
  446.     my $name = shift;
  447.     $name !~ /^(ap|apr|mpxs)_/i;
  448. }
  449.  
  450. sub make_prefix {
  451.     my($name, $class) = @_;
  452.     my $class_prefix = class_mpxs_prefix($class);
  453.     return $name if $name =~ /^$class_prefix/;
  454.     $class_prefix . $name;
  455. }
  456.  
  457. sub isa_str {
  458.     my($self, $module) = @_;
  459.     my $str = "";
  460.  
  461.     if (my $isa = $self->typemap->{function_map}->{isa}->{$module}) {
  462.         while (my($sub, $base) = each %$isa) {
  463. #XXX cannot set isa in the BOOT: section because XSLoader local-ises
  464. #ISA during bootstrap
  465. #            $str .= qq{    av_push(get_av("$sub\::ISA", TRUE),
  466. #                                   newSVpv("$base",0));}
  467.             $str .= qq{\@$sub\::ISA = '$base';\n}
  468.         }
  469.     }
  470.  
  471.     $str;
  472. }
  473.  
  474. sub boot {
  475.     my($self, $module) = @_;
  476.     my $str = "";
  477.  
  478.     if (my $boot = $self->typemap->{function_map}->{boot}->{$module}) {
  479.         $str = '    mpxs_' . $self->cname($module) . "_BOOT(aTHX);\n";
  480.     }
  481.  
  482.     $str;
  483. }
  484.  
  485. my $notshared = join '|', qw(TIEHANDLE); #not sure why yet
  486.  
  487. sub attrs {
  488.     my($self, $name) = @_;
  489.     my $str = "";
  490.     return $str if $name =~ /$notshared$/o;
  491.     $str = "    ATTRS: unique\n" if GvUNIQUE;
  492.     $str;
  493. }
  494.  
  495. sub write_xs {
  496.     my($self, $module, $functions) = @_;
  497.  
  498.     my $fh = $self->open_class_file($module, '.xs');
  499.     print $fh $self->ModPerl::Code::noedit_warning_c(), "\n";
  500.     print $fh "\n#define MP_IN_XS\n\n";
  501.  
  502.     my @includes = @{ $self->includes };
  503.  
  504.     if (my $mod_h = $self->mod_h($module)) {
  505.         push @includes, $mod_h;
  506.     }
  507.  
  508.     for (@includes) {
  509.         print $fh qq{\#include "$_"\n\n};
  510.     }
  511.  
  512.     my $last_prefix = "";
  513.  
  514.     for my $func (@$functions) {
  515.         my $class = $func->{class};
  516.         my $prefix = $func->{prefix};
  517.         $last_prefix = $prefix if $prefix;
  518.  
  519.         if ($func->{name} =~ /^mpxs_/) {
  520.             #e.g. mpxs_Apache__RequestRec_
  521.             my $class_prefix = class_c_prefix($class);
  522.             if ($func->{name} =~ /$class_prefix/) {
  523.                 $prefix = class_mpxs_prefix($class);
  524.             }
  525.         }
  526.  
  527.         $prefix = $prefix ? "  PREFIX = $prefix" : "";
  528.         print $fh "MODULE = $module    PACKAGE = $class $prefix\n\n";
  529.  
  530.         print $fh $func->{code};
  531.     }
  532.  
  533.     if (my $destructor = $self->typemap->destructor($last_prefix)) {
  534.         my $arg = $destructor->{argspec}[0];
  535.  
  536.         print $fh <<EOF;
  537. void
  538. $destructor->{name}($arg)
  539.     $destructor->{class} $arg
  540.  
  541. EOF
  542.     }
  543.  
  544.     print $fh "MODULE = $module\n";
  545.     print $fh "PROTOTYPES: disabled\n\n";
  546.     print $fh "BOOT:\n";
  547.     print $fh $self->boot($module);
  548.     print $fh "    items = items; /* -Wall */\n\n";
  549.  
  550.     if (my $newxs = $self->{newXS}->{$module}) {
  551.         for my $xs (sort { $a->[0] cmp $b->[0] } @$newxs) {
  552.             print $fh qq{   cv = newXS("$xs->[0]", $xs->[1], __FILE__);\n};
  553.             print $fh qq{   GvUNIQUE_on(CvGV(cv));\n} if GvUNIQUE;
  554.         }
  555.     }
  556.  
  557.     if ($module eq 'APR::Pool') {
  558.         print $fh "    modperl_opt_interp_unselect = APR_RETRIEVE_OPTIONAL_FN(modperl_interp_unselect);\n\n";
  559.     }
  560.  
  561.     close $fh;
  562. }
  563.  
  564. sub write_pm {
  565.     my($self, $module) = @_;
  566.  
  567.     my $isa = $self->isa_str($module);
  568.  
  569.     my $code = "";
  570.     if (my $mod_pm = $self->mod_pm($module, 1)) {
  571.         open my $fh, '<', $mod_pm;
  572.         local $/;
  573.         $code = <$fh>;
  574.         close $fh;
  575.     }
  576.  
  577.     my $base   = (split '::', $module)[0];
  578.     unless (-e "lib/$base/XSLoader.pm") {
  579.         $base = 'Apache';
  580.     }
  581.     my $loader = join '::', $base, 'XSLoader';
  582.  
  583.     my $fh = $self->open_class_file($module, '.pm');
  584.     my $noedit_warning = $self->ModPerl::Code::noedit_warning_hash();
  585.     my $use_apr = ($module =~ /^APR::\w+$/) ? 'use APR ();' : '';
  586.  
  587.     print $fh <<EOF;
  588. $noedit_warning
  589.  
  590. package $module;
  591.  
  592. use strict;
  593. use warnings FATAL => 'all';
  594.  
  595. $isa
  596. $use_apr
  597. use $loader ();
  598. our \$VERSION = '0.01';
  599. $loader\::load __PACKAGE__;
  600.  
  601. $code
  602.  
  603. 1;
  604. __END__
  605. EOF
  606. }
  607.  
  608. my %typemap = (
  609.     'Apache::RequestRec' => 'T_APACHEOBJ',
  610.     'apr_time_t'         => 'T_APR_TIME',
  611.     'APR::Table'         => 'T_HASHOBJ',
  612.     'APR::Pool'          => 'T_POOLOBJ',
  613.     'APR::OS::Thread'    => 'T_UVOBJ',
  614. );
  615.  
  616. sub write_typemap {
  617.     my $self = shift;
  618.     my $typemap = $self->typemap;
  619.     my $map = $typemap->get;
  620.     my %seen;
  621.  
  622.     my $fh = $self->open_class_file('ModPerl::WrapXS', 'typemap');
  623.     print $fh $self->ModPerl::Code::noedit_warning_hash(), "\n";
  624.  
  625.     my %entries = ();
  626.     my $max_key_len = 0;
  627.     while (my($type, $class) = each %$map) {
  628.         $class ||= $type;
  629.         next if $seen{$type}++ || $typemap->special($class);
  630.  
  631.         if ($class =~ /::/) {
  632.             $entries{$class} = $typemap{$class} || 'T_PTROBJ';
  633.             $max_key_len = length $class if length $class > $max_key_len;
  634.         }
  635.         else {
  636.             $entries{$type} = $typemap{$type} || "T_$class";
  637.             $max_key_len = length $type if length $type > $max_key_len;
  638.         }
  639.     }
  640.  
  641.     for (sort keys %entries) {
  642.         printf $fh "%-${max_key_len}s %s\n", $_, $entries{$_};
  643.     }
  644.  
  645.     close $fh;
  646. }
  647.  
  648. sub write_typemap_h_file {
  649.     my($self, $method) = @_;
  650.  
  651.     $method = $method . '_code';
  652.     my($h, $code) = $self->typemap->$method();
  653.     my $file = catfile $self->{XS_DIR}, $h;
  654.  
  655.     open my $fh, '>', $file or die "open $file: $!";
  656.     print $fh $self->ModPerl::Code::noedit_warning_c(), "\n";
  657.     print $fh $code;
  658.     close $fh;
  659. }
  660.  
  661. sub write_lookup_method_file {
  662.     my $self = shift;
  663.  
  664.     my %map = ();
  665.     while (my($module, $functions) = each %{ $self->{XS} }) {
  666.         my $last_prefix = "";
  667.         for my $func (@$functions) {
  668.             my $class = $func->{class};
  669.             my $prefix = $func->{prefix};
  670.             $last_prefix = $prefix if $prefix;
  671.  
  672.             my $name = $func->{perl_name} || $func->{name};
  673.             $name =~ s/^DEFINE_//;
  674.  
  675.             if ($name =~ /^mpxs_/) {
  676.                 #e.g. mpxs_Apache__RequestRec_
  677.                 my $class_prefix = class_c_prefix($class);
  678.                 if ($name =~ /$class_prefix/) {
  679.                     $prefix = class_mpxs_prefix($class);
  680.                 }
  681.             }
  682.             elsif ($name =~ /^ap_sub_req/) {
  683.                 $prefix = 'ap_sub_req_';
  684.             }
  685.  
  686.             $name =~ s/^$prefix// if $prefix;
  687.  
  688.             push @{ $map{$name} }, [$module, $class];
  689.         }
  690.  
  691.         # pure XS wrappers don't have the information about the
  692.         # arguments they receive, since they manipulate the arguments
  693.         # stack directly. therefore for these methods we can't tell
  694.         # what are the objects they are invoked on
  695.         for my $xs (@{ $self->{newXS}->{$module} || []}) {
  696.             push @{ $map{$1} }, [$module, undef] if $xs->[0] =~ /.+::(.+)/;
  697.         }
  698.     }
  699.  
  700.     local $Data::Dumper::Terse    = 1;
  701.     local $Data::Dumper::Sortkeys = 1;
  702.     $Data::Dumper::Terse    = $Data::Dumper::Terse;    # warn
  703.     $Data::Dumper::Sortkeys = $Data::Dumper::Sortkeys; # warn
  704.     my $methods = Dumper(\%map);
  705.     $methods =~ s/\n$//;
  706.  
  707.     my $package = "ModPerl::MethodLookup";
  708.     my $file = catfile "lib", "ModPerl", "MethodLookup.pm";
  709.     debug "creating $file";
  710.     open my $fh, ">$file" or die "Can't open $file: $!";
  711.  
  712.     my $noedit_warning = $self->ModPerl::Code::noedit_warning_hash();
  713.  
  714.     print $fh <<EOF;
  715. $noedit_warning
  716. package $package;
  717.  
  718. use strict;
  719. use warnings;
  720.  
  721. my \$methods = $methods;
  722.  
  723. EOF
  724.  
  725.     print $fh <<'EOF';
  726.  
  727. use base qw(Exporter);
  728.  
  729. our @EXPORT = qw(print_method print_module print_object);
  730.  
  731. use constant MODULE => 0;
  732. use constant OBJECT  => 1;
  733.  
  734. my $modules;
  735. my $objects;
  736.  
  737. sub _get_modules {
  738.     for my $method (sort keys %$methods) { 
  739.         for my $item ( @{ $methods->{$method} }) {
  740.             push @{ $modules->{$item->[MODULE]} }, [$method, $item->[OBJECT]];
  741.         }
  742.     }
  743. }
  744.  
  745. sub _get_objects {
  746.     for my $method (sort keys %$methods) { 
  747.         for my $item ( @{ $methods->{$method} }) {
  748.             next unless defined $item->[OBJECT];
  749.             push @{ $objects->{$item->[OBJECT]} }, [$method, $item->[MODULE]];
  750.         }
  751.     }
  752. }
  753.  
  754. # if there is only one replacement method in 2.0 API we can
  755. # automatically lookup it, up however if there are more than one
  756. # (e.g. new()), we need to use a fully qualified value here
  757. # of course the same if the package is not a mod_perl one.
  758. #
  759. # the first field represents the replacement method or undef if none
  760. # exists, the second field is for extra comments (e.g. when there is
  761. # no replacement method)
  762. my $methods_compat = {
  763.     # Apache::
  764.     gensym            => ['Symbol::gensym',
  765.                           'or use "open my $fh, $file"'],
  766.     module            => ['Apache::Module::loaded',
  767.                           ''],
  768.     define            => ['exists_config_define',
  769.                           ''],
  770.     httpd_conf        => ['add_config',
  771.                           ''],
  772.     SERVER_VERSION    => ['get_server_version',
  773.                           ''],
  774.     can_stack_handlers=> [undef,
  775.                           'there is no more need for that method in mp2'],
  776.  
  777.     # Apache::RequestRec
  778.     soft_timeout      => [undef,
  779.                           'there is no more need for that method in mp2'],
  780.     hard_timeout      => [undef,
  781.                           'there is no more need for that method in mp2'],
  782.     kill_timeout      => [undef,
  783.                           'there is no more need for that method in mp2'],
  784.     reset_timeout     => [undef,
  785.                           'there is no more need for that method in mp2'],
  786.     cleanup_for_exec  => [undef,
  787.                           'there is no more need for that method in mp2'],
  788.     send_http_header  => ['content_type',
  789.                           ''],
  790.     header_in         => ['headers_in',
  791.                           'this method works in mod_perl 1.0 too'],
  792.     header_out        => ['headers_out',
  793.                           'this method works in mod_perl 1.0 too'],
  794.     err_header_out    => ['err_headers_out',
  795.                           'this method works in mod_perl 1.0 too'],
  796.     register_cleanup  => ['cleanup_register',
  797.                           ''],
  798.     post_connection   => ['cleanup_register',
  799.                           ''],
  800.     content           => [undef, # XXX: Apache::Request::what?
  801.                           'use CGI.pm or Apache::Request instead'],
  802.     clear_rgy_endav   => ['special_list_clear',
  803.                           ''],
  804.     stash_rgy_endav   => [undef,
  805.                           ''],
  806.     run_rgy_endav     => ['special_list_call',
  807.                           'this method is no longer needed'],
  808.     seqno             => [undef,
  809.                           'internal to mod_perl 1.0'],
  810.     chdir_file        => [undef, # XXX: to be resolved
  811.                           'temporary unavailable till the issue with chdir' .
  812.                           ' in the threaded env is resolved'],
  813.     log_reason        => ['log_error',
  814.                           'not in the Apache 2.0 API'],
  815.     READLINE          => [undef, # XXX: to be resolved
  816.                           ''],
  817.     send_fd_length    => [undef,
  818.                           'not in the Apache 2.0 API'],
  819.     send_fd           => ['sendfile',
  820.                           'requires an offset argument'],
  821.     is_main           => ['main',
  822.                           'not in the Apache 2.0 API'],
  823.     cgi_var           => ['subprocess_env',
  824.                           'subprocess_env can be used with mod_perl 1.0'],
  825.     cgi_env           => ['subprocess_env',
  826.                           'subprocess_env can be used with mod_perl 1.0'],
  827.     each_byterange    => [undef,
  828.                           'now handled internally by ap_byterange_filter'],
  829.     set_byterange     => [undef,
  830.                           'now handled internally by ap_byterange_filter'],
  831.  
  832.     # Apache::File
  833.     open              => [undef,
  834.                           ''],
  835.     close             => [undef, # XXX: also defined in APR::Socket
  836.                           ''],
  837.     tmpfile           => [undef,
  838.                           'not in the Apache 2.0 API, ' .
  839.                           'use File::Temp instead'],
  840.  
  841.     # Apache::Util
  842.     size_string       => ['format_size',
  843.                           ''],
  844.     escape_uri        => ['unescape_path',
  845.                           ''],
  846.     unescape_uri      => ['unescape_url',
  847.                           ''],
  848.     escape_html       => [undef, # XXX: will be ap_escape_html
  849.                           'ap_escape_html now requires a pool object'],
  850.     parsedate         => ['parse_http',
  851.                           ''],
  852.     validate_password => ['password_validate',
  853.                           ''],
  854.  
  855.     # Apache::Table
  856.     #new               => ['make',
  857.     #                      ''], # XXX: there are other 'new' methods
  858.  
  859.     # Apache::Connection
  860.     auth_type         => ['ap_auth_type',
  861.                           'now resides in the request object'],
  862. };
  863.  
  864. sub avail_methods_compat {
  865.     return keys %$methods_compat;
  866. }
  867.  
  868. sub avail_methods {
  869.     return keys %$methods;
  870. }
  871.  
  872. sub avail_modules {
  873.     my %modules = ();
  874.     for my $method (keys %$methods) {
  875.         for my $item ( @{ $methods->{$method} }) {
  876.             $modules{$item->[MODULE]}++;
  877.         }
  878.     }
  879.     return keys %modules;
  880. }
  881.  
  882. sub preload_all_modules {
  883.     _get_modules() unless $modules;
  884.     eval "require $_" for keys %$modules;
  885. }
  886.  
  887. sub _print_func {
  888.     my $func = shift;
  889.     my @args = @_ ? @_ : @ARGV;
  890.     no strict 'refs';
  891.     print( ($func->($_))[0]) for @args;
  892. }
  893.  
  894. sub print_module { _print_func('lookup_module', @_) }
  895. sub print_object { _print_func('lookup_object', @_) }
  896.  
  897. sub print_method {
  898.     my @args = @_ ? @_ : @ARGV;
  899.     while (@args) {
  900.          my $method = shift @args;
  901.          my $object = (@args && 
  902.              (ref($args[0]) || $args[0] =~ /^(Apache|ModPerl|APR)/))
  903.              ? shift @args
  904.              : undef;
  905.          print( (lookup_method($method, $object))[0]);
  906.     }
  907. }
  908.  
  909. sub sep { return '-' x (shift() + 20) . "\n" }
  910.  
  911. # what modules contain the passed method.
  912. # an optional object or a reference to it can be passed to help
  913. # resolve situations where there is more than one module containing
  914. # the same method. Inheritance is supported.
  915. sub lookup_method {
  916.     my ($method, $object) = @_;
  917.  
  918.     unless (defined $method) {
  919.         my $hint = "No 'method' argument was passed\n";
  920.         return ($hint);
  921.     }
  922.  
  923.     # strip the package name for the fully qualified method
  924.     $method =~ s/.+:://;
  925.  
  926.     if (exists $methods_compat->{$method}) {
  927.         my ($replacement, $comment) = @{$methods_compat->{$method}};
  928.         my $hint = "'$method' is not a part of the mod_perl 2.0 API\n";
  929.         $comment = length $comment ? " $comment\n" : "";
  930.  
  931.         # some removed methods have no replacement
  932.         return $hint . "$comment" unless defined $replacement;
  933.  
  934.         $hint .= "use '$replacement' instead. $comment";
  935.  
  936.         # if fully qualified don't look up its container
  937.         return $hint if $replacement =~ /::/;
  938.  
  939.         my ($modules_hint, @modules) = lookup_method($replacement, $object);
  940.         return $hint . $modules_hint;
  941.     }
  942.     elsif (!exists $methods->{$method}) {
  943.         my $hint = "Don't know anything about method '$method'\n";
  944.         return ($hint);
  945.     }
  946.  
  947.     my @items = @{ $methods->{$method} };
  948.     if (@items == 1) {
  949.         my $module = $items[0]->[MODULE];
  950.         my $hint = "To use method '$method' add:\n" . "\tuse $module ();\n";
  951.         # we should really check that the method matches the object if
  952.         # any was passed, but it may not always work
  953.         return ($hint, $module);
  954.     }
  955.     else {
  956.         if (defined $object) {
  957.             my $class = ref $object || $object;
  958.             for my $item (@items) {
  959.                 # real class or inheritance
  960.                 if ($class eq $item->[OBJECT] or
  961.                     (ref($object) && $object->isa($item->[OBJECT]))) {
  962.                     my $module = $item->[MODULE];
  963.                     my $hint = "To use method '$method' add:\n" .
  964.                         "\tuse $module ();\n";
  965.                     return ($hint, $module);
  966.                 }
  967.             }
  968.             # fall-through
  969.             local $" = ", ";
  970.             my @modules = map $_->[MODULE], @items;
  971.             my $hint = "Several modules (@modules) contain method '$method' " .
  972.                 "but none of them matches class '$class';\n";
  973.             return ($hint);
  974.  
  975.         }
  976.         else {
  977.             my %modules = map { $_->[MODULE] => 1 } @items;
  978.             # remove dups if any (e.g. $s->add_input_filter and
  979.             # $r->add_input_filter are loaded by the same Apache::Filter)
  980.             my @modules = keys %modules;
  981.             my $hint;
  982.             if (@modules == 1) {
  983.                 $hint = "To use method '$method' add:\n\tuse $modules[0] ();\n";
  984.                 return ($hint, $modules[0]);
  985.             }
  986.             else {
  987.                 $hint = "There is more than one class with method '$method'\n" .
  988.                     "try one of:\n" . join '', map {"\tuse $_ ();\n"} @modules;
  989.                 return ($hint, @modules);
  990.             }
  991.         }
  992.     }
  993. }
  994.  
  995. # what methods are contained in the passed module name
  996. sub lookup_module {
  997.     my ($module) = shift;
  998.  
  999.     unless (defined $module) {
  1000.         my $hint = "no 'module' argument was passed\n";
  1001.         return ($hint);
  1002.     }
  1003.  
  1004.     _get_modules() unless $modules;
  1005.  
  1006.     unless (exists $modules->{$module}) {
  1007.         my $hint = "don't know anything about module '$module'\n";
  1008.         return ($hint);
  1009.     }
  1010.  
  1011.     my @methods;
  1012.     my $max_len = 6;
  1013.     for ( @{ $modules->{$module} } ) {
  1014.         $max_len = length $_->[0] if length $_->[0] > $max_len;
  1015.         push @methods, $_->[0];
  1016.     }
  1017.  
  1018.     my $format = "%-${max_len}s %s\n";
  1019.     my $banner = sprintf($format, "Method", "Invoked on object type");
  1020.     my $hint = join '',
  1021.         ("\nModule '$module' contains the following XS methods:\n\n", 
  1022.          $banner,  sep(length($banner)),
  1023.          map( { sprintf $format, $_->[0], $_->[1]||'???'}
  1024.              @{ $modules->{$module} }),
  1025.          sep(length($banner)));
  1026.  
  1027.     return ($hint, @methods);
  1028. }
  1029.  
  1030. # what methods can be invoked on the passed object (or its reference)
  1031. sub lookup_object {
  1032.     my ($object) = shift;
  1033.  
  1034.     unless (defined $object) {
  1035.         my $hint = "no 'object' argument was passed\n";
  1036.         return ($hint);
  1037.     }
  1038.  
  1039.     _get_objects() unless $objects;
  1040.  
  1041.     # a real object was passed?
  1042.     $object = ref $object || $object;
  1043.  
  1044.     unless (exists $objects->{$object}) {
  1045.         my $hint = "don't know anything about objects of type '$object'\n";
  1046.         return ($hint);
  1047.     }
  1048.  
  1049.     my @methods;
  1050.     my $max_len = 6;
  1051.     for ( @{ $objects->{$object} } ) {
  1052.         $max_len = length $_->[0] if length $_->[0] > $max_len;
  1053.         push @methods, $_->[0];
  1054.     }
  1055.  
  1056.     my $format = "%-${max_len}s %s\n";
  1057.     my $banner = sprintf($format, "Method", "Module");
  1058.     my $hint = join '',
  1059.         ("\nObjects of type '$object' can invoke the following XS methods:\n\n",
  1060.          $banner, sep(length($banner)),
  1061.          map({ sprintf $format, $_->[0], $_->[1]} @{ $objects->{$object} }),
  1062.          sep(length($banner)));
  1063.  
  1064.     return ($hint, @methods);
  1065.  
  1066. }
  1067.  
  1068. 1;
  1069. EOF
  1070.     close $fh;
  1071. }
  1072.  
  1073. sub generate {
  1074.     my $self = shift;
  1075.  
  1076.     $self->prepare;
  1077.  
  1078.     for (qw(ModPerl::WrapXS Apache APR ModPerl)) {
  1079.         $self->write_makefilepl($_);
  1080.     }
  1081.  
  1082.     $self->write_typemap;
  1083.  
  1084.     for (qw(typedefs sv_convert)) {
  1085.         $self->write_typemap_h_file($_);
  1086.     }
  1087.  
  1088.     $self->get_functions;
  1089.     $self->get_structures;
  1090.     $self->write_export_file('exp') if Apache::Build::AIX;
  1091.     $self->write_export_file('def') if Apache::Build::WIN32;
  1092.  
  1093.     while (my($module, $functions) = each %{ $self->{XS} }) {
  1094. #        my($root, $sub) = split '::', $module;
  1095. #        if (-e "$self->{XS_DIR}/$root/$sub/$sub.xs") {
  1096. #            $module = join '::', $root, "Wrap$sub";
  1097. #        }
  1098.         $self->write_makefilepl($module);
  1099.         $self->write_xs($module, $functions);
  1100.         $self->write_pm($module);
  1101.     }
  1102.  
  1103.     $self->write_lookup_method_file;
  1104. }
  1105.  
  1106. #three .sym files are generated:
  1107. #global   - global symbols
  1108. #ithreads - #ifdef USE_ITHREADS functions
  1109. #inline   - __inline__ functions
  1110. #the inline symbols are needed #ifdef MP_DEBUG
  1111. #since __inline__ will be turned off
  1112.  
  1113. my %multi_export = map { $_, 1 } qw(exp);
  1114.  
  1115. sub open_export_files {
  1116.     my($self, $name, $ext) = @_;
  1117.  
  1118.     my $dir = $self->{XS_DIR};
  1119.     my %handles;
  1120.     my @types = qw(global inline ithreads);
  1121.  
  1122.     if ($multi_export{$ext}) {
  1123.         #write to multiple files
  1124.         for my $type (@types) {
  1125.             my $file = "$dir/${name}_$type.$ext";
  1126.  
  1127.             open my $fh, '>', $file or
  1128.               die "open $file: $!";
  1129.  
  1130.             $handles{$type} = $fh;
  1131.         }
  1132.     }
  1133.     else {
  1134.         #write to one file
  1135.         my $file = "$dir/$name.$ext";
  1136.  
  1137.         open my $fh, '>', $file or
  1138.           die "open $file: $!";
  1139.  
  1140.         for my $type (@types) {
  1141.             $handles{$type} = $fh;
  1142.         }
  1143.     }
  1144.  
  1145.     \%handles;
  1146. }
  1147.  
  1148. sub func_is_static {
  1149.     my($self, $entry) = @_;
  1150.     if (my $attr = $entry->{attr}) {
  1151.         return 1 if grep { $_ eq 'static' } @$attr;
  1152.     }
  1153.     return 0;
  1154. }
  1155.  
  1156. sub func_is_inline {
  1157.     my($self, $entry) = @_;
  1158.     if (my $attr = $entry->{attr}) {
  1159.         return 1 if grep { $_ eq '__inline__' } @$attr;
  1160.     }
  1161.     return 0;
  1162. }
  1163.  
  1164. sub export_file_header_exp {
  1165.     my $self = shift;
  1166.     "#!\n";
  1167. }
  1168.  
  1169. sub export_file_format_exp {
  1170.     my($self, $val) = @_;
  1171.     "$val\n";
  1172. }
  1173.  
  1174. sub export_file_header_def {
  1175.     my $self = shift;
  1176.     "LIBRARY\n\nEXPORTS\n\n";
  1177. }
  1178.  
  1179. sub export_file_format_def {
  1180.     my($self, $val) = @_;
  1181.     "   $val\n";
  1182. }
  1183.  
  1184. my $ithreads_exports = join '|', qw{
  1185. modperl_cmd_interp_
  1186. modperl_interp_ modperl_list_ modperl_tipool_
  1187. };
  1188.  
  1189. sub export_func_handle {
  1190.     my($self, $entry, $handles) = @_;
  1191.  
  1192.     if ($self->func_is_inline($entry)) {
  1193.         return $handles->{inline};
  1194.     }
  1195.     elsif ($entry->{name} =~ /^($ithreads_exports)/) {
  1196.         return $handles->{ithreads};
  1197.     }
  1198.  
  1199.     $handles->{global};
  1200. }
  1201.  
  1202. sub write_export_file {
  1203.     my($self, $ext) = @_;
  1204.  
  1205.     my %files = (
  1206.         modperl => $ModPerl::FunctionTable,
  1207.         apache  => $Apache::FunctionTable,
  1208.         apr     => $APR::FunctionTable,
  1209.     );
  1210.  
  1211.     my $header = \&{"export_file_header_$ext"};
  1212.     my $format = \&{"export_file_format_$ext"};
  1213.  
  1214.     while (my($key, $table) = each %files) {
  1215.         my $handles = $self->open_export_files($key, $ext);
  1216.  
  1217.     my %seen; #only write header once if this is a single file
  1218.         for my $fh (values %$handles) {
  1219.             next if $seen{$fh}++;
  1220.             print $fh $self->$header();
  1221.         }
  1222.  
  1223.         # add the symbols which aren't the function table
  1224.         if ($key eq 'modperl') {
  1225.             my $fh = $handles->{global};
  1226.             for my $name (@global_structs) {
  1227.                 print $fh $self->$format($name);
  1228.             }
  1229.         }
  1230.  
  1231.         for my $entry (@$table) {
  1232.             next if $self->func_is_static($entry);
  1233.             my $name = $entry->{name};
  1234.  
  1235.             #C::Scan doesnt always pickup static __inline__
  1236.             next if $name =~ /^mpxs_/o;
  1237.  
  1238.             my $fh = $self->export_func_handle($entry, $handles);
  1239.  
  1240.             print $fh $self->$format($name);
  1241.         }
  1242.  
  1243.         %seen = (); #only close handle once if this is a single file
  1244.         for my $fh (values %$handles) {
  1245.             next if $seen{$fh}++;
  1246.             close $fh;
  1247.         }
  1248.     }
  1249. }
  1250.  
  1251. sub stats {
  1252.     my $self = shift;
  1253.  
  1254.     $self->get_functions;
  1255.     $self->get_structures;
  1256.  
  1257.     my %stats;
  1258.  
  1259.     while (my($module, $functions) = each %{ $self->{XS} }) {
  1260.         $stats{$module} += @$functions;
  1261.         if (my $newxs = $self->{newXS}->{$module}) {
  1262.             $stats{$module} += @$newxs;
  1263.         }
  1264.     }
  1265.  
  1266.     return \%stats;
  1267. }
  1268.  
  1269. 1;
  1270. __END__
  1271.