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