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