1use strict;
2use ModPerl::MM;
3
4use 5.005;
5
6use Apache::Test5005compat;
7
8use Apache::TestMM qw(test clean);
9use Apache::TestReport ();
10use Apache::TestSmoke ();
11use Apache::TestRun ();
12use Apache::TestConfigPerl ();
13use Apache::TestSmokePerl ();
14use Apache::TestReportPerl ();
15
16use Config;
17use File::Find qw(finddepth);
18use File::Basename;
19use Apache2::Build;
20use constant WIN32 => Apache2::Build::WIN32;
21use Cwd;
22use ExtUtils::XSBuilder::ParseSource;
23
24my $version = "2.XX-dev"; # DUMMY VALUE
25
26my $cwd = WIN32 ?
27    Win32::GetLongPathName(cwd) : cwd;
28$cwd =~ m{^(.+)/glue/perl$} or die "Can't find base directory";
29my $base_dir = $1;
30my $inc_dir = "$base_dir/include";
31my $lib_dir = "$base_dir/library";
32my $xs_dir = "$base_dir/glue/perl/xsbuilder";
33
34sub slurp($$)
35{
36    open my $file, $_[1] or die "Can't open $_[1]: $!";
37    read $file, $_[0], -s $file;
38}
39
40sub cmp_tuples {
41    my ($num_a, $num_b) = @_;
42
43    while (@$num_a && @$num_b) {
44        my $cmp = shift @$num_a <=> shift @$num_b;
45        return $cmp if $cmp;
46    }
47
48    return @$num_a <=> @$num_b;
49}
50
51sub autoconf_foo {
52    my ($config, $re_start, $re_end, $re_match) = @_;
53
54    $$config =~ /^${re_start}APACHE2_INCLUDES${re_end}($re_match)/m or
55        die "Can't find apache include directory";
56    my $apache_includes = $1;
57    $$config =~ /^${re_start}APR_INCLUDES${re_end}($re_match)/m or
58        die "Can't find apache include directory";
59    $apache_includes .= " $1";
60
61    my $apr_libs ="";
62
63    $$config =~ m/^${re_start}APREQ_LIBNAME${re_end}($re_match)/m or
64        die "Can't find apreq libname";
65
66    ## XXX: 2.60 bug/hack
67    my $apreq_libname = $1;
68
69    $$config =~ m/^${re_start}PACKAGE_VERSION${re_end}($re_match)/m or
70        die "Can't find package version";
71    my $version = $1;
72
73	## Code around an autoconf 2.60 bug
74	## http://lists.gnu.org/archive/html/bug-autoconf/2006-06/msg00127.html
75	## $ grep @PACKAGE_VERSION config.status-2.59 config.status-2.60
76	## config.status-2.59:s,@PACKAGE_VERSION@,2.09,;t t
77	## config.status-2.60:s,@PACKAGE_VERSION@,|#_!!_#|2.09,g
78	foreach ($apache_includes, $apreq_libname, $version) {
79	    s/\|#_!!_#\|//g;
80	}
81
82    return ($apache_includes, $apr_libs, $apreq_libname, $version);
83}
84
85my ($apache_includes, $apache_dir, $apr_libs, $apreq_libname, $perl_lib);
86
87if (WIN32) {
88    # XXX May need fixing, Randy!
89    slurp my $config => "$base_dir/configure.ac";
90    $config =~ /^AC_INIT[^,]+,\s*([^,\s]+)/m or
91        die "Can't find version string";
92    $version = $1;
93    slurp my $make => "$base_dir/Makefile";
94    $make =~ /^APACHE=(\S+)/m or
95        die "Cannot find top-level Apache directory";
96    ($apache_dir = $1) =~ s!\\!/!g;
97    ($apache_includes = "-I$apache_dir" . '/include') =~ s!\\!/!g;
98    ($apr_libs = "-L$apache_dir" . '/lib') =~ s!\\!/!g;
99    $make =~ /^APR_LIB=(\S+)/m or
100        die "Cannot find apr lib";
101    $apr_libs .= ' -l' . basename($1, '.lib');
102    $make =~ /^APU_LIB=(\S+)/m or
103        die "Cannot find aprutil lib";
104    $apr_libs .= ' -l' . basename($1, '.lib');
105    $apreq_libname = 'apreq2';
106    $perl_lib = $Config{installsitelib} . '\auto\libaprext';
107    $perl_lib =~ s{\\}{\\\\}g;
108}
109else {
110    slurp my $config => "$base_dir/config.status";
111
112    $config =~ /GNU Autoconf (\d+\.\d+)/;
113    my $autoconf_ver = $1;
114
115    ### XXX: Lord have mercy on us.....
116    if (cmp_tuples([split /\./, $autoconf_ver], [qw(2 61)]) > 0) {
117        ### Autoconf >=2.62 changed the format of the file
118        ### I.E.: S["APACHE2_INCLUDES"]="-I/usr/local/include/apache2"
119        ($apache_includes, $apr_libs, $apreq_libname, $version) =
120           autoconf_foo(\$config, qr/S\[\"/, qr/\"\]=\"/, qr/[^\"]+/);
121    }
122    else {
123       ### I.E.: s,@APACHE2_INCLUDES@,-I/usr/local/include/apache22,;t t
124       ($apache_includes, $apr_libs, $apreq_libname, $version) =
125          autoconf_foo(\$config, qr/s,\@/, qr/\@,/, qr/[^,]+/);
126    }
127
128}
129
130
131my $apreq_libs;
132
133if (WIN32) {
134 $apreq_libs = qq{-L$base_dir/win32/libs -llib$apreq_libname -lmod_apreq2 -L$perl_lib -llibaprext -L$apache_dir/lib -lmod_perl};
135} else {
136    my $apreq2_config = "$base_dir/apreq2-config";
137    my $bindir = qx{$apreq2_config --bindir};
138    chomp $bindir;
139    $apreq2_config = "$bindir/apreq2-config" if $ENV{INSTALL};
140    $apreq_libs = qx{$apreq2_config --link-ld --ldflags --libs};
141    chomp $apreq_libs;
142}
143
144my $mp2_typemaps = Apache2::Build->new->typemaps;
145
146package My::ParseSource;
147use base qw/ExtUtils::XSBuilder::ParseSource/;
148use constant WIN32 => ($^O =~ /Win32/i);
149my @dirs = ("$base_dir/include", "$base_dir/module/apache2");
150sub package {'APR::Request'}
151sub unwanted_includes {[qw/apreq_config.h apreq_private_apache2.h/]}
152
153# ParseSource.pm v 0.23 bug: line 214 should read
154# my @dirs = @{$self->include_dirs};
155# for now, we override it here just to work around the bug
156
157sub find_includes {
158    my $self = shift;
159    return $self->{includes} if $self->{includes};
160    require File::Find;
161    my(@dirs) = @{$self->include_dirs};
162    unless (-d $dirs[0]) {
163        die "could not find include directory";
164    }
165    # print "Will search @dirs for include files...\n" if ($verbose) ;
166    my @includes;
167    my $unwanted = join '|', @{$self -> unwanted_includes} ;
168
169    for my $dir (@dirs) {
170        File::Find::finddepth({
171                               wanted => sub {
172                                   return unless /\.h$/;
173                                   return if ($unwanted && (/^($unwanted)/o));
174                                   my $dir = $File::Find::dir;
175                                   push @includes, "$dir/$_";
176                               },
177                               follow => not WIN32,
178                              }, $dir);
179    }
180    return $self->{includes} = $self -> sort_includes (\@includes) ;
181}
182
183sub include_dirs {\@dirs}
184
185package My::WrapXS;
186use base qw/ExtUtils::XSBuilder::WrapXS/;
187our $VERSION = $version;
188use constant WIN32 => ($^O =~ /Win32/i);
189
190##################################################
191# Finally, we get to the actual script...
192
193__PACKAGE__ -> run;
194
195my @scripts = ();
196
197use File::Spec::Functions qw(catfile);
198
199File::Find::finddepth(sub {
200    return unless /(.*?\.pl)\.PL$/;
201    push @scripts, "$File::Find::dir/$1";
202}, '.');
203
204Apache::TestMM::filter_args();
205Apache::TestMM::generate_script("t/TEST");
206Apache::TestSmokePerl->generate_script;
207Apache::TestReportPerl->generate_script;
208
209my %opts = (
210    NAME => 'libapreq2',
211    DIR => [qw(xs)],
212    clean => { FILES => "xs t/logs t/TEST @scripts" },
213    realclean => { FILES => "xsbuilder/tables" },
214);
215
216ModPerl::MM::WriteMakefile(%opts);
217
218# That's the whole script - below is just a bunch of local overrides
219##################################################
220sub get_functions {
221    my $self = shift;
222    $self->{XS}->{"APR::Request::Error"} ||= [];
223    $self->SUPER::get_functions;
224}
225
226
227sub test_docs {
228    my ($pods, $tests) = @_;
229    require Config;
230    my $bin = $Config::Config{bin};
231    my $pod2test = catfile $bin, "pod2test";
232    $pod2test = Apache::TestConfig::which('pod2test')
233        unless -e $pod2test;
234
235    return "" unless $pod2test and -e $pod2test;
236
237    return join "", map <<EOT, 0..$#$pods;
238$$tests[$_]: $$pods[$_]
239	\$(FULLPERLRUN) $pod2test $$pods[$_] $$tests[$_]
240
241EOT
242}
243
244sub MY::postamble {
245    my @docs = (<xsbuilder/APR/Request/*/*.pod>, <xsbuilder/APR/Request/*.pod>);
246    my @tests = @docs;
247    s/pod$/t/ for @tests;
248    s/^xsbuilder/xs/ for @tests;
249
250    my $string = "";
251    my $test_docs = test_docs(\@docs, \@tests);
252
253    if ($test_docs) {
254        $string .= $test_docs;
255        $string .= <<EOT;
256doc_test : @tests
257	\$(FULLPERLRUN) "-Mblib" "-MTest::Harness" "-e" "runtests(\@ARGV)" @tests
258
259test :: doc_test
260
261EOT
262    } else {
263        $string .= <<EOT;
264test ::
265	\$(NOECHO) \$(ECHO) pod2test was not found, skipping inlined tests
266
267EOT
268    }
269
270    return $string;
271}
272
273
274sub parsesource_objects {[My::ParseSource->new]}
275sub new_typemap {My::TypeMap->new(shift)}
276sub h_filename_prefix {'apreq_xs_'}
277sub my_xs_prefix {'apreq_xs_'}
278sub xs_include_dir { $xs_dir }
279
280sub mod_xs {
281    my($self, $module, $complete) = @_;
282    my $dirname = $self->class_dirname($module);
283    my @parts = split '::', $module;
284    my $mod_xs = "$dirname/$parts[-1].xs";
285
286    for ($self -> xs_include_dir, @{ $self->{glue_dirs} }) {
287        my $file = "$_/$mod_xs";
288		$mod_xs = $file if $complete;
289        return $mod_xs if -e $file;
290    }
291
292    undef;
293}
294
295sub mod_pm {
296    my($self, $module, $complete) = @_;
297    my $dirname = $self->class_dirname($module);
298    my @parts = split '::', $module;
299    my $mod_pm = "$dirname/$parts[-1].pm";
300
301    for ($self -> xs_include_dir, @{ $self->{glue_dirs} }) {
302        my $file = "$_/$mod_pm";
303		$mod_pm = $file if $complete;
304        return $mod_pm if -e $file;
305    }
306
307    undef;
308}
309
310#inline mod_xs directly, so we can put XS directives there
311
312sub write_xs {
313    my($self, $module, $functions) = @_;
314
315    my $fh = $self->open_class_file($module, '.xs');
316    print $fh "$self->{noedit_warning_c}\n";
317
318    my @includes = @{ $self->includes };
319
320    if (my $mod_h = $self->mod_h($module)) {
321        push @includes, $mod_h;
322    }
323
324    for (@includes) {
325        print $fh qq{\#include "$_"\n\n};
326    }
327
328    if (my $mod_xs = $self->mod_xs($module, 1)) {
329        open my $file, $mod_xs or die "can't open $mod_xs: $!";
330        print $fh $_ while <$file>;
331        print $fh "\n\n";
332    }
333
334    my $last_prefix = "";
335    my $fmap = $self -> typemap -> {function_map} ;
336    my $myprefix = $self -> my_xs_prefix ;
337
338    for my $func (@$functions) {
339        my $class = $func->{class};
340        if ($class)
341            {
342            my $prefix = $func->{prefix};
343            $last_prefix = $prefix if $prefix;
344
345            if ($func->{name} =~ /^$myprefix/o) {
346                #e.g. mpxs_Apache__RequestRec_
347                my $class_prefix = $fmap -> class_c_prefix($class);
348                if ($func->{name} =~ /$class_prefix/) {
349                    $prefix = $fmap -> class_xs_prefix($class);
350                }
351            }
352
353            $prefix = $prefix ? "  PREFIX = $prefix" : "";
354            print $fh "MODULE = $module    PACKAGE = $class $prefix\n\n";
355            }
356
357        print $fh $func->{code};
358    }
359
360    if (my $destructor = $self->typemap->destructor($last_prefix)) {
361        my $arg = $destructor->{argspec}[0];
362
363        print $fh <<EOF;
364void
365$destructor->{name}($arg)
366    $destructor->{class} $arg
367
368EOF
369    }
370
371    print $fh "PROTOTYPES: disabled\n\n";
372    print $fh "BOOT:\n";
373    print $fh $self->boot($module);
374    print $fh "    items = items; /* -Wall */\n\n";
375
376    if (my $newxs = $self->{newXS}->{$module}) {
377        for my $xs (@$newxs) {
378            print $fh qq{   cv = newXS("$xs->[0]", $xs->[1], __FILE__);\n};
379            print $fh qq{   GvSHARED_on(CvGV(cv));\n} if ExtUtils::XSBuilder::WrapXS::GvSHARED();
380        }
381    }
382
383    close $fh;
384}
385
386
387
388sub mod_pod {
389    my($self, $module, $complete) = @_;
390    my $dirname = $self->class_dirname($module);
391    my @parts = split '::', $module;
392    my $mod_pod = "$dirname/$parts[-1].pod";
393    for ($self -> xs_incsrc_dir, @{ $self->{glue_dirs} }) {
394        my $file = "$_/$mod_pod";
395        $mod_pod = $file if $complete;
396        print "mod_pod $mod_pod $file $complete\n" ;
397        return $mod_pod if -e $file;
398    }
399    undef;
400}
401
402sub write_docs {
403    my ($self, $module, $functions) = @_;
404    my $podfile = $self->mod_pod($module, 1) or return;
405    my $fh = $self->open_class_file($module, '.pod');
406    open my $pod, "<", $podfile or die $!;
407    while (<$pod>) {
408        print $fh $_;
409    }
410}
411sub pm_text {
412    my($self, $module, $isa, $code) = @_;
413
414    my $text = <<"EOF";
415$self->{noedit_warning_hash}
416
417package $module;
418require DynaLoader ;
419
420use strict;
421use warnings FATAL => 'all';
422
423use vars qw{\$VERSION \@ISA} ;
424$isa
425push \@ISA, 'DynaLoader' ;
426\$VERSION = '$version';
427bootstrap $module \$VERSION ;
428
429$code
430
4311;
432__END__
433EOF
434
435        return $text;
436}
437sub makefilepl_text {
438    my($self, $class, $deps,$typemap) = @_;
439
440    my @parts = split (/::/, $class) ;
441    my $mmargspath = '../' x @parts ;
442    $mmargspath .= 'mmargs.pl' ;
443
444    my $txt = qq{
445$self->{noedit_warning_hash}
446use ModPerl::MM;
447
448local \$MMARGS ;
449
450if (-f '$mmargspath')
451    {
452    do '$mmargspath' ;
453    die \$\@ if (\$\@) ;
454    }
455
456\$MMARGS ||= {} ;
457
458
459ModPerl::MM::WriteMakefile(
460    'NAME'      => '$class',
461    'VERSION'   => '$version',
462    'TYPEMAPS'  => [qw(@$mp2_typemaps $typemap)],
463    'INC'       => "-I$base_dir/glue/perl/xs -I$inc_dir -I$xs_dir $apache_includes -I\\\$(LOCALBASE)/include/apache24/modules/perl",
464    'LIBS'      => "$apreq_libs $apr_libs -L\\\$(LOCALBASE)/lib",
465} ;
466$txt .= "'depend'  => $deps,\n" if ($deps) ;
467$txt .= qq{
468    \%\$MMARGS,
469);
470
471} ;
472
473}
474
475# For now, just copy the typemap file in xsbuilder til we
476# can remove ExtUtils::XSBuilder.
477
478sub write_typemap
479{
480    my $self = shift;
481
482    my $typemap = $self->typemap;
483    my $map = $typemap->get;
484    my %seen;
485
486    my $fh = $self->open_class_file('', 'typemap');
487    print $fh "$self->{noedit_warning_hash}\n";
488    open my $tfh, "$xs_dir/typemap" or die $!;
489    print $fh $_ while <$tfh>;
490}
491
492
493package My::TypeMap;
494use base 'ExtUtils::XSBuilder::TypeMap';
495
496sub null_type {
497    my($self, $type) = @_;
498    my $t = $self->get->{$type};
499    my $class = $t -> {class} ;
500
501    if ($class =~ /APREQ_COOKIE_VERSION/) {
502        return 'APREQ_COOKIE_VERSION_DEFAULT';
503    }
504    else {
505        return $self->SUPER::null_type($type);
506    }
507}
508
509# XXX this needs serious work
510sub typemap_code
511{
512    {
513           T_SUBCLASS  => {
514                          INPUT => <<'EOT',
515    if (SvROK($arg) || !sv_derived_from($arg, \"$Package\"))
516        Perl_croak(aTHX_ \"Usage: argument is not a subclass of $Package\");
517    $var = SvPV_nolen($arg)
518EOT
519                           },
520
521        T_APREQ_COOKIE  => {
522                            INPUT  => '$var = apreq_xs_sv2cookie(aTHX_ $arg)',
523                            perl2c => 'apreq_xs_sv2cookie(aTHX_ sv)',
524                            OUTPUT => '$arg = apreq_xs_cookie2sv(aTHX_ $var, class, parent);',
525                            c2perl => 'apreq_xs_cookie2sv(aTHX_ ptr, class, parent)',
526                           },
527
528        T_APREQ_PARAM   => {
529                            INPUT  => '$var = apreq_xs_sv2param(aTHX_ $arg)',
530                            perl2c => 'apreq_xs_sv2param(aTHX_ sv)',
531                            OUTPUT => '$arg = apreq_xs_param2sv(aTHX_ $var, class, parent);',
532                            c2perl => 'apreq_xs_param2sv(aTHX_ ptr, class, parent)',
533                           },
534
535         T_APREQ_HANDLE => {
536                            INPUT  => '$var = apreq_xs_sv2handle(aTHX_ $arg)',
537                            perl2c => 'apreq_xs_sv2handle(aTHX_ sv)',
538                            c2perl => 'apreq_xs_handle2sv(aTHX_ ptr, class, parent)',
539                            OUTPUT => '$arg = apreq_xs_handle2sv(aTHX_ $var, class, parent);',
540                           },
541
542     T_APREQ_HANDLE_CGI => {
543                            INPUT  => '$var = apreq_xs_sv2handle(aTHX_ $arg)',
544                            OUTPUT => '$arg = apreq_xs_handle2sv(aTHX_ $var, class, SvRV(ST(1)));'
545                           },
546
547 T_APREQ_HANDLE_APACHE2 => {
548                            INPUT  => '$var = apreq_xs_sv2handle(aTHX_ $arg)',
549                            OUTPUT => <<'EOT',
550    $arg = apreq_xs_handle2sv(aTHX_ $var, class, SvRV(ST(1)));
551    SvMAGIC(SvRV($arg))->mg_ptr = (void *)r;
552EOT
553                           },
554
555          T_APREQ_ERROR => {
556                             INPUT => '$var = (HV *)SvRV($arg)',
557                            OUTPUT => '$arg = sv_bless(newRV_noinc((SV*)$var), gv_stashpvn(\"${ntype}\", sizeof(\"${ntype}\") - 1, FALSE);'
558                           },
559
560              T_HASHOBJ => {
561                            INPUT => <<'EOT', # '$var = modperl_hash_tied_object(aTHX_ \"${ntype}\", $arg)'
562    if (sv_derived_from($arg, \"${ntype}\")) {
563        if (SVt_PVHV == SvTYPE(SvRV($arg))) {
564            SV *hv = SvRV($arg);
565            MAGIC *mg;
566            if (SvMAGICAL(hv)) {
567                if ((mg = mg_find(hv, PERL_MAGIC_tied))) {
568                    $var = (void *)MgObjIV(mg);
569                }
570                else {
571                    Perl_warn(aTHX_ \"Not a tied hash: (magic=%c)\", mg);
572                    $var = NULL;
573                }
574            }
575            else {
576                Perl_warn(aTHX_ \"SV is not tied\");
577                $var = NULL;
578            }
579        }
580        else {
581            $var = (void *)SvObjIV($arg);
582        }
583    }
584    else {
585        Perl_croak(aTHX_
586                   \"argument is not a blessed reference \"
587                   \"(expecting an %s derived object)\", \"${ntype}\");
588    }
589EOT
590
591                 OUTPUT => <<'EOT', # '$arg = modperl_hash_tie(aTHX_ \"${ntype}\", $arg, $var);'
592  {
593    SV *hv = (SV*)newHV();
594    SV *rsv = $arg;
595    sv_setref_pv(rsv, \"${ntype}\", $var);
596    sv_magic(hv, rsv, PERL_MAGIC_tied, Nullch, 0);
597    $arg = SvREFCNT_inc(sv_bless(sv_2mortal(newRV_noinc(hv)),
598                                 gv_stashpv(\"${ntype}\", TRUE)));
599  }
600EOT
601
602                           },
603    }
604}
605