1package ExtUtils::XSBuilder::WrapXS; 2 3use strict; 4use warnings FATAL => 'all'; 5 6use constant GvSHARED => 0; #$^V gt v5.7.0; 7 8use File::Spec ; 9use ExtUtils::XSBuilder::TypeMap (); 10use ExtUtils::XSBuilder::MapUtil qw(function_table structure_table callback_table); 11use ExtUtils::XSBuilder::PODTemplate ; 12use File::Path qw(rmtree mkpath); 13use Cwd qw(fastcwd); 14use Data::Dumper; 15 16use Carp qw(confess) ; 17 18our $VERSION = '0.03'; 19 20my %warnings; 21my $verbose = 0 ; 22 23=pod 24 25=head1 NAME 26 27ExtUtils::XSBuilder::WrapXS - create perl XS wrappers for C functions 28 29=head2 DESCRIPTION 30 31For more information, see L<ExtUtils::XSBuilder> 32 33=cut 34 35# ============================================================================ 36 37sub new { 38 my $class = shift; 39 40 my $self = bless { 41 }, $class; 42 43 $self -> {glue_dirs} = [$self -> xs_glue_dirs()] ; 44 $self -> {typemap} = $self -> new_typemap ; 45 $self -> {parsesource} = $self -> new_parsesource ; 46 $self -> {xs_includes} = $self -> xs_includes ; 47 $self -> {callbackno} = 1 ; 48 49 for (qw(c hash)) { 50 my $w = "noedit_warning_$_"; 51 my $method = $w ; 52 $self->{$w} = $self->$method(); 53 } 54 55 $self->typemap->get; 56 $self; 57} 58 59# ============================================================================ 60 61sub classname { 62 my $self = shift || __PACKAGE__; 63 ref($self) || $self; 64} 65 66# ============================================================================ 67 68sub calls_trace { 69 my $frame = 1; 70 my $trace = ''; 71 72 while (1) { 73 my($package, $filename, $line) = caller($frame); 74 last unless $filename; 75 $trace .= "$frame. $filename:$line\n"; 76 $frame++; 77 } 78 79 return $trace; 80} 81 82# ============================================================================ 83 84sub noedit_warning_c { 85 my $class = classname(shift); 86 my $warning = \$warnings{C}->{$class}; 87 return $$warning if $$warning; 88 my $v = join '/', $class, $class->VERSION; 89 my $trace = calls_trace(); 90 $trace =~ s/^/ * /mg; 91 $$warning = <<EOF; 92 93/* 94 * *********** WARNING ************** 95 * This file generated by $v 96 * Any changes made here will be lost 97 * *********************************** 98$trace */ 99 100EOF 101} 102 103# ============================================================================ 104 105#this is named hash after the `#' character 106#rather than named perl, since #comments are used 107#non-Perl files, e.g. Makefile, typemap, etc. 108sub noedit_warning_hash { 109 my $class = classname(shift); 110 my $warning = \$warnings{hash}->{$class}; 111 return $$warning if $$warning; 112 ($$warning = noedit_warning_c($class)) =~ s/^/\# /mg; 113 $$warning; 114} 115 116 117# ============================================================================ 118=pod 119 120=head2 new_parsesource (o) 121 122Returns an array ref of new ParseSource objects for all source files that 123should be used to generate XS files 124 125=cut 126 127sub new_parsesource { [ ExtUtils::XSBuilder::ParseSource->new ] } 128 129 130# ============================================================================ 131=pod 132 133=head2 new_typemap (o) 134 135Returns a new typemap object 136 137=cut 138 139sub new_typemap { ExtUtils::XSBuilder::TypeMap->new (shift) } 140 141# ============================================================================ 142=pod 143 144=head2 new_podtemplate (o) 145 146Returns a new podtemplate object 147 148=cut 149 150sub new_podtemplate { ExtUtils::XSBuilder::PODTemplate->new } 151 152# ============================================================================ 153=pod 154 155=head2 xs_includes (o) 156 157Returns a list of XS include files. 158 159Default: use all include files that C<ParseSource::find_includes> returns, but 160strip path info 161 162=cut 163 164sub xs_includes 165 { 166 my $self = shift ; 167 my $parsesource = $self -> parsesource_objects ; 168 169 my @includes ; 170 my @paths ; 171 foreach my $src (@$parsesource) { 172 push @includes, @{ $src -> find_includes } ; 173 push @paths, @{ $src -> include_paths } ; 174 } 175 176 foreach (@paths) 177 { 178 s#(\\|/)$## ; 179 s#\\#/# ; 180 } 181 foreach (@includes) 182 { 183 s#\\#/# ; 184 } 185 186 187 # strip include paths 188 foreach my $file (@includes) 189 { 190 foreach my $path (@paths) 191 { 192 if ($file =~ /^\Q$path\E(\/|\\)(.*?)$/i) 193 { 194 $file = $2 ; 195 last ; 196 } 197 } 198 } 199 200 201 my %includes = map { $_ => 1 } @includes ; 202 my $fixup1 = $self -> h_filename_prefix . 'preperl.h' ; 203 my $fixup2 = $self -> h_filename_prefix . 'postperl.h' ; 204 205 206 207 return [ 208 keys %includes, 209 -f $self -> xs_include_dir . '/'. $fixup1?$fixup1:(), 210 'EXTERN.h', 'perl.h', 'XSUB.h', 211 -f $self -> xs_include_dir . '/'. $fixup2?$fixup2:(), 212 $self -> h_filename_prefix . 'sv_convert.h', 213 $self -> h_filename_prefix . 'typedefs.h', 214 ] ; 215 } 216 217 218 219# ============================================================================ 220=pod 221 222=head2 xs_glue_dirs (o) 223 224Returns a list of additional XS glue directories to seach for maps in. 225 226=cut 227 228 229sub xs_glue_dirs { 230 () ; 231} 232 233 234# ============================================================================ 235=pod 236 237=head2 xs_base_dir (o) 238 239Returns a directory which serves as a base for other directories. 240 241Default: C<'.'> 242 243=cut 244 245 246sub xs_base_dir { '.' } ; 247 248 249 250# ============================================================================ 251=pod 252 253=head2 xs_map_dir (o) 254 255Returns the directory to search for map files in 256 257Default: C<<xs_base_dir>/xsbuilder/maps> 258 259=cut 260 261 262sub xs_map_dir { File::Spec -> catdir ($_[0] -> xs_base_dir, 'xsbuilder', 'maps') } ; 263 264# ============================================================================ 265=pod 266 267=head2 xs_incsrc_dir (o) 268 269Returns the directory to search for files to include into the source. For 270example, C<<xs_incsrc_dir>/Apache/DAV/Resource/Resource_pm> will be included into 271the C<Apache::DAV::Resource> module. 272 273Default: C<<xs_base_dir>/xsbuilder> 274 275 276=cut 277 278 279sub xs_incsrc_dir { File::Spec -> catdir ($_[0] -> xs_base_dir, 'xsbuilder') ; } ; 280 281# ============================================================================ 282=pod 283 284=head2 xs_include_dir (o) 285 286Returns a directory to search for include files for pm and XS 287 288Default: C<<xs_base_dir>/xsinclude> 289 290=cut 291 292 293sub xs_include_dir { File::Spec -> catdir ($_[0] -> xs_base_dir, 'xsinclude') ; } ; 294 295# ============================================================================ 296=pod 297 298=head2 xs_target_dir (o) 299 300Returns the directory to write generated XS and header files in 301 302Default: C<<xs_base_dir>/xs> 303 304=cut 305 306 307sub xs_target_dir { File::Spec -> catdir ($_[0] -> xs_base_dir, 'xs') ; } 308 309 310# ============================================================================ 311 312sub typemap { shift->{typemap} } 313 314# ============================================================================ 315 316sub includes { shift->{xs_includes} || [] } 317 318# ============================================================================ 319 320sub parsesource_objects { shift->{parsesource} } 321 322# ============================================================================ 323 324sub function_list { 325 my $self = shift; 326 my(@list) = @{ function_table($self) }; 327 328 while (my($name, $val) = each %{ $self->typemap->function_map }) { 329 #entries that do not exist in C::Scan generated tables 330 next unless $name =~ /^DEFINE_/; 331 push @list, $val; 332 } 333 334 return \@list; 335} 336 337# ============================================================================ 338 339sub callback_list { 340 my $self = shift; 341 my(@list) = @{ callback_table($self) }; 342 343 while (my($name, $val) = each %{ $self->typemap->callback_map }) { 344 #entries that do not exist in C::Scan generated tables 345 next unless $name =~ /^DEFINE_/; 346 push @list, $val; 347 } 348 349 return \@list; 350} 351 352# ============================================================================ 353 354sub get_callback_function { 355 my ($self, $func, $struct, $elt) = @_ ; 356 357 my $myprefix = $self -> my_xs_prefix ; 358 my $n ; 359 $elt -> {callbackno} = $n = $self -> {callbackno}++ ; 360 my $structelt = $elt -> {name} ; 361 my $class = $struct -> {class} ; 362 my $cclass = $self -> cname($class) ; 363 364 my($name, $args, $retargs, $return_type, $orig_args, $userdataarg) = 365 @{ $func } { qw(perl_name args retargs return_type orig_args userdataarg) }; 366 367 $struct -> {staticcnt} ||= 4 ; 368 my $staticcnt = $struct -> {staticcnt} ; 369 #print "get_callback_function: ", Data::Dumper -> Dump([$func]), "\n" ; 370 371 my $code = "\n/* --- $class -> $structelt --- */\n\n" ; 372 my $cbname = "${myprefix}cb_${cclass}__$structelt" ; 373 my %retargs = map { $_->{name} => $_ } @$retargs ; 374 my %args = map { $_->{name} => $_ } @$args ; 375 my @args = map { my $name = /^(?:\*|&)(.*?)$/?$1:$_ ; ($args{$name}{rtype} || $retargs{$name}{rtype}) . (/^&/?" * $name":" $name") } @$orig_args ; 376 $return_type = $self -> cname($return_type) ; 377 my $return_class = $self -> typemap -> map_class ($return_type) || $return_type; 378 if ($return_class =~ / /) 379 { 380 print "ERROR: return class '$return_class' contains spaces" ; 381 } 382 383 my $desttype = 'CV' ; 384 if ($structelt) 385 { 386 $desttype = 'SV' ; 387 } 388 389 my $numret = $return_type eq 'void'?0:1 ; 390 $numret += @$retargs ; 391 my $callflags = $numret == 0?'G_VOID':$numret == 1?'G_SCALAR':'G_ARRAY' ; 392 393 $code .= qq[ 394 395static $return_type $cbname (] . join (',', "$desttype * __cbdest", @args) . qq[) 396 { 397] ; 398 $code .= " $return_type __retval ;\n" if ($return_type && $return_type ne 'void') ; 399 $code .= " SV * __retsv ;\n" if ($numret) ; 400 $code .= qq[ 401 int __cnt ; 402 403 dSP ; 404 ENTER ; 405 SAVETMPS ; 406 PUSHMARK(SP) ; 407]; 408 409 if ($structelt) 410 { 411 $code .= " PUSHs(__cbdest) ;\n" ; 412 } 413 414 foreach (@$orig_args) { 415 my $type = /^(?:\*|\&)(.*?)$/?$1:$_ ; 416 my $name = /^\*(.*?)$/?"&$1":$_ ; 417 next if ($retargs{$type}{class}) ; 418 if (!$args{$type}{class} && !$args{$type}{type}) 419 { 420 print "WARNING: unknown type for argument '$name' in struct member '$structelt'\n" ; 421 print Dumper ($args) ; 422 next ; 423 } 424 my $class = $args{$type}{class} || $args{$type}{type} ; 425 if ($class =~/\s/) 426 { 427 print "WARNING: type '$class' for argument '$name' in struct member '$structelt' contains spaces\n" ; 428 print Dumper ($args) ; 429 next ; 430 } 431 432 $code .= ' PUSHs(' . $self -> convert_2obj ($class, $name) . ") ;\n" ; 433 } 434 435 $code .= qq[ 436 PUTBACK ; 437] ; 438 439 if ($structelt) 440 { 441 $code .= " __cnt = perl_call_method(\"cb_$structelt\", $callflags) ;\n" ; 442 } 443 else 444 { 445 $code .= " __cnt = perl_call_sv(__cbdest, $callflags) ;\n" ; 446 } 447 448 $code .= qq[ 449 450 if (__cnt != $numret) 451 croak (\"$cbname expected $numret return values\") ; 452] if ($numret > 0) ; 453 454 $code .= qq[ 455 SPAGAIN ; 456] ; 457 458 if ($return_type && $return_type ne 'void') 459 { 460 $code .= " __retsv = POPs;\n" ; 461 $code .= ' __retval = ' . $self -> convert_sv2 ($return_type, $return_class, '__retsv') . ";\n" 462 } 463 foreach (@$retargs) { 464 $code .= " __retsv = POPs;\n" ; 465 $code .= " *$_->{name} = " . $self -> convert_sv2 ($_->{rtype}, $_->{class}, '__retsv') . ";\n" ; 466 } 467 468 $code .= qq[ 469 PUTBACK ; 470 FREETMPS ; 471 LEAVE ; 472 473 474] ; 475 $code .= " return __retval ;\n" if ($return_type && $return_type ne 'void') ; 476 $code .= qq[ 477 } 478 479] ; 480 481 if (!$userdataarg) { 482 $staticcnt ||= 4 ; 483 484 for (my $i = 0 ; $i < $staticcnt; $i++) { 485 $code .= qq[ 486 487static $return_type ${cbname}_obj$i (] . join (',', @args) . qq[) 488 { 489 ] . ($return_type eq 'void'?'':'return') . qq[ ${cbname} (] . 490 join (',', "${myprefix}${cclass}_obj[$i]", map { /^(?:\*|\&)?(.*?)$/ } @$orig_args) . qq[) ; 491 } 492 493] ; 494 495 496 } 497 $code .= "typedef $return_type (*t${cbname}_func)(" . join (',', @args) . qq") ;\n" ; 498 $code .= "static t${cbname}_func ${myprefix}${cbname}_func [$staticcnt] = {\n " . 499 join (",\n ", map { "${cbname}_obj$_" } (0..$staticcnt-1)) . "\n } ;\n\n\n" ; 500 } 501 502 unshift @{ $self->{XS}->{ $func->{module} } }, { 503 code => $code, 504 class => '', 505 name => $name, 506 }; 507 508} 509 510 511 512# ============================================================================ 513 514 515 516sub get_function { 517 my ($self, $func) = @_ ; 518 519 my $myprefix = $self -> my_xs_prefix ; 520 521 my($name, $module, $class, $args, $retargs) = 522 @{ $func } { qw(perl_name module class args retargs) }; 523 524 my %retargs = map { $_->{name} => $_ } @$retargs ; 525 526 print "get_function: ", Data::Dumper -> Dump([$func]), "\n" if ($verbose); 527 #eg ap_fputs() 528 if ($name =~ s/^DEFINE_//) { 529 $func->{name} =~ s/^DEFINE_//; 530 531 if (needs_prefix($func->{name})) { 532 #e.g. DEFINE_add_output_filter 533 $func->{name} = make_prefix($func->{name}, $class); 534 } 535 } 536 537 my $xs_parms = join ', ', 538 map { defined $_->{default} ? 539 "$_->{name}=$_->{default}" : $_->{name} } @$args; 540 541 my $parms ; 542 if ($func -> {dispatch_argspec}) 543 { 544 $parms = $func -> {dispatch_argspec} ; 545 } 546 else 547 { 548 ($parms = join (',', $xs_parms, 549 map { "\&$_->{name}" } @$retargs)) =~ 550 s/=[^,]+//g; #strip defaults 551 } 552 553 my $proto = join "\n", 554 (map " $_->{type} $_->{name}", @$args) ; 555 556 my $return_type = 557 $name =~ /^DESTROY$/ ? 'void' : $func->{return_type}; 558 559 my $retdecl = @$retargs?(join "\n", 560 (map { my $type = $self -> cname($_->{class}) ; $type =~ s/\*$//; ' ' . $type . " $_->{name};"} @$retargs), 561 #' ' . $self -> cname($return_type) . ' RETVAL', 562 ''):''; 563 564 my($dispatch, $orig_args) = 565 @{ $func } {qw(dispatch orig_args)}; 566 567 if ($dispatch =~ /^$myprefix/io) { 568 $name =~ s/^$myprefix//; 569 $name =~ s/^$func->{prefix}//; 570 push @{ $self->{newXS}->{ $module } }, 571 ["$class\::$name", $dispatch]; 572 return; 573 } 574 575 my $passthru = @$args && $args->[0]->{name} eq '...'; 576 if ($passthru) { 577 $parms = '...'; 578 $proto = ''; 579 } 580 581 my $attrs = $self->attrs($name); 582 583 my $code = <<EOF; 584$return_type 585$name($xs_parms) 586EOF 587 $code .= "$proto\n" if ($proto) ; 588 $code .= "$attrs\n" if ($attrs) ; 589 $code .= "PREINIT:\n$retdecl" if ($retdecl) ; 590 591 if ($dispatch || $orig_args) { 592 my $thx = ""; 593 594 if ($dispatch) { 595 $thx = 'aTHX_ ' if $dispatch =~ /^$myprefix/i; 596 if ($orig_args && !$func -> {dispatch_argspec}) { 597 $parms = join ', ', map { $retargs{$_}?"&$_":$_} @$orig_args; 598 } 599 } 600 else { 601 ### ??? gr ### if ($orig_args and @$orig_args == @$args) { 602 if ($orig_args && @$orig_args) { 603 #args were reordered 604 $parms = join ', ', map { $retargs{$_}?"&$_":$_} @$orig_args; 605 } 606 607 $dispatch = $func->{name}; 608 } 609 610 if ($passthru) { 611 $thx ||= 'aTHX_ '; 612 $parms = 'items, MARK+1, SP'; 613 } 614 615 my $retval = $return_type eq 'void' ? 616 ["", ""] : ["RETVAL = ", "OUTPUT:\n RETVAL\n"]; 617 618 my $retnum = $retdecl?scalar(@$retargs) + ($return_type eq 'void' ?0:1):0 ; 619 $code .= $retdecl?"PPCODE:":"CODE:" ; 620 $code .= "\n $retval->[0]$dispatch($thx$parms);\n" ; 621 if ($retdecl) { 622 my $retclass = $self -> typemap -> map_class ($return_type) || $return_type ; 623 if ($retclass =~ / /) 624 { 625 print "ERROR: return class '$retclass' contains spaces" ; 626 } 627 $code .= " XSprePUSH;\n" ; 628 $code .= " EXTEND(SP, $retnum) ;\n" ; 629 $code .= ' PUSHs(' . $self -> convert_2obj ($retclass, 'RETVAL') . ") ;\n" ; 630 foreach (@$retargs) { 631 if ($_->{class} =~ / /) 632 { 633 print "ERROR: $_->{class} contains spaces; retargs = ", Dumper ($_) ; 634 } 635 $code .= ' PUSHs(' . $self -> convert_2obj ($_->{class}, $_->{name}) . ") ;\n" ; 636 } 637 } 638 else { 639 $code .= "$retval->[1]\n" ; 640 } 641 } 642 643 $code .= "\n" ; 644 645 $func->{code} = $code; 646 push @{ $self->{XS}->{ $module } }, $func; 647} 648 649# ============================================================================ 650 651 652sub get_functions { 653 my $self = shift; 654 655 my $typemap = $self->typemap; 656 my %seen ; 657 for my $entry (@{ $self->function_list() }) { 658 #print "get_func ", Dumper ($entry) ; 659 my $func = $typemap->map_function($entry); 660 #print "FAILED to map $entry->{name}\n" unless $func; 661 next unless $func; 662 print "WARNING: Duplicate function: $entry->{name}\n" if ($seen{$entry->{name}}++) ; 663 $self -> get_function ($func) ; 664 } 665} 666 667 668# ============================================================================ 669 670sub get_value { 671 my $e = shift; 672 my $val = 'val'; 673 674 if ($e->{class} eq 'PV') { 675 if (my $pool = $e->{pool}) { 676 $pool .= '(obj)'; 677 $val = "((ST(1) == &PL_sv_undef) ? NULL : 678 apr_pstrndup($pool, val, val_len))" 679 } 680 } 681 682 return $val; 683} 684# ============================================================================ 685 686sub get_structure_callback_init { 687 my ($self, $class, $struct) = @_ ; 688 689 my $cclass = $self -> cname($class) ; 690 691 my $myprefix = $self -> my_xs_prefix ; 692 my $staticcnt = $struct -> {staticcnt} ; 693 694 my $cnv = $self -> convert_sv2 ($cclass, $class, 'obj') ; 695 my $code = qq[ 696 697void 698init_callbacks (obj, val=NULL) 699 SV * obj 700 SV * val 701PREINIT: 702 int n = -1 ; 703 int i ; 704 $cclass cobj = $cnv ; 705 SV * ref ; 706 SV * perl_obj ; 707CODE: 708 if (items > 1) 709 obj = val ; 710 711 perl_obj = SvRV(obj) ; 712 ref = newRV_noinc(perl_obj) ; 713 714 for (i=0;i < $staticcnt;i++) 715 { 716 if ($myprefix${cclass}_obj[i] == ref) 717 { 718 n = i ; 719 break ; 720 } 721 } 722 723 if (n < 0) 724 for (i=0;i < $staticcnt;i++) 725 { 726 if ($myprefix${cclass}_obj[i] == NULL) 727 { 728 n = i ; 729 break ; 730 } 731 } 732 733 if (n < 0) 734 croak ("Limit for concurrent object callbacks reached for $class. Limit is $staticcnt") ; 735 736 $myprefix${cclass}_obj[n] = ref ; 737] ; 738 739 740 foreach my $e (@{ $struct->{elts} }) { 741 if ($e -> {callback}) { 742 my $cbname = "${myprefix}cb_${cclass}__$e->{name}" ; 743 $code .= " cobj -> $e->{name} = ${myprefix}${cbname}_func[n] ;\n" ; 744 } 745 } 746 $code .= qq[ 747 748] ; 749 750 my $ccode = "static SV * ${myprefix}${cclass}_obj[$staticcnt] ;\n\n" ; 751 752 753 push @{ $self->{XS}->{ $struct->{module} } }, { 754 code => $code, 755 class => $class, 756 name => 'init_callbacks', 757 }; 758 759 unshift @{ $self->{XS}->{ $struct->{module} } }, { 760 code => $ccode, 761 class => '', 762 name => 'init_callbacks', 763 }; 764 765} 766 767# ============================================================================ 768 769sub get_structure_new { 770 my ($self, $class, $struct) = @_ ; 771 772 my $cclass = $self -> cname($class) ; 773 my $cnvprefix = $self -> my_cnv_prefix ; 774 my $alloc = $struct -> {alloc} || 'malloc(sizeof(*cobj))' ; 775 my $code = qq[ 776 777SV * 778new (class,initializer=NULL) 779 char * class 780 SV * initializer 781PREINIT: 782 SV * svobj ; 783 $cclass cobj ; 784 SV * tmpsv ; 785CODE: 786 ${cnvprefix}${cclass}_create_obj(cobj,svobj,RETVAL,$alloc) ; 787 788 if (initializer) { 789 if (!SvROK(initializer) || !(tmpsv = SvRV(initializer))) 790 croak ("initializer for ${class}::new is not a reference") ; 791 792 if (SvTYPE(tmpsv) == SVt_PVHV || SvTYPE(tmpsv) == SVt_PVMG) 793 ${cclass}_new_init (aTHX_ cobj, tmpsv, 0) ; 794 else if (SvTYPE(tmpsv) == SVt_PVAV) { 795 int i ; 796 SvGROW(svobj, sizeof (*cobj) * av_len((AV *)tmpsv)) ; 797 for (i = 0; i <= av_len((AV *)tmpsv); i++) { 798 SV * * itemrv = av_fetch((AV *)tmpsv, i, 0) ; 799 SV * item ; 800 if (!itemrv || !*itemrv || !SvROK(*itemrv) || !(item = SvRV(*itemrv))) 801 croak ("array element of initializer for ${class}::new is not a reference") ; 802 ${cclass}_new_init (aTHX_ &cobj[i], item, 1) ; 803 } 804 } 805 else { 806 croak ("initializer for ${class}::new is not a hash/array/object reference") ; 807 } 808 } 809OUTPUT: 810 RETVAL 811 812] ; 813 814 815 my $c_code = qq[ 816 817void ${cclass}_new_init (pTHX_ $cclass obj, SV * item, int overwrite) { 818 819 SV * * tmpsv ; 820 821 if (SvTYPE(item) == SVt_PVMG) 822 memcpy (obj, (void *)SvIVX(item), sizeof (*obj)) ; 823 else if (SvTYPE(item) == SVt_PVHV) { 824] ; 825 foreach my $e (@{ $struct->{elts} }) { 826 if ($e -> {name} =~ /^(.*?)\[(.*?)\]$/) { 827 my $strncpy = $2 ; 828 my $name = $1 ; 829 my $perl_name ; 830 ($perl_name = $e -> {perl_name}) =~ s/\[.*?\]$// ; 831 $c_code .= " if ((tmpsv = hv_fetch((HV *)item, \"$perl_name\", sizeof(\"$perl_name\") - 1, 0)) || overwrite) {\n" ; 832 $c_code .= " STRLEN l = 0;\n" ; 833 $c_code .= " if (tmpsv) {\n" ; 834 $c_code .= " char * s = SvPV(*tmpsv,l) ;\n" ; 835 $c_code .= " if (l > ($strncpy)-1) l = ($strncpy) - 1 ;\n" ; 836 $c_code .= " strncpy(obj->$name, s, l) ;\n" ; 837 $c_code .= " }\n" ; 838 $c_code .= " obj->$name\[l] = '\\0';\n" ; 839 $c_code .= " }\n" ; 840 } elsif (($e -> {class} !~ /::/) || ($e -> {rtype} =~ /\*$/)) { 841 $c_code .= " if ((tmpsv = hv_fetch((HV *)item, \"$e->{perl_name}\", sizeof(\"$e->{perl_name}\") - 1, 0)) || overwrite) {\n" ; 842 843 if ($e -> {malloc}) { 844 my $type = $e->{rtype} ; 845 my $dest = "obj -> $e->{name}" ; 846 my $src = 'tmpobj' ; 847 my $expr = eval ('"' . $e -> {malloc} . '"') ; 848 print $@ if ($@) ; 849 $c_code .= " $type tmpobj = (" . $self -> convert_sv2 ($e->{rtype}, $e->{class}, '(tmpsv && *tmpsv?*tmpsv:&PL_sv_undef)') . ");\n" ; 850 $c_code .= " if (tmpobj)\n" ; 851 $c_code .= " $expr;\n" ; 852 $c_code .= " else\n" ; 853 $c_code .= " $dest = NULL ;\n" ; 854 } 855 else { 856 $c_code .= ' ' . "obj -> $e->{name} = " . $self -> convert_sv2 ($e->{rtype}, $e->{class}, '(tmpsv && *tmpsv?*tmpsv:&PL_sv_undef)') . " ;\n" ; 857 } 858 $c_code .= " }\n" ; 859 } 860 } 861 $c_code .= qq[ ; } 862 863 else 864 croak ("initializer for ${class}::new is not a hash or object reference") ; 865 866} ; 867 868 869] ; 870 871 872 push @{ $self->{XS}->{ $struct->{module} } }, { 873 code => $code, 874 class => $class, 875 name => 'new', 876 }; 877 878 unshift @{ $self->{XS}->{ $struct->{module} } }, { 879 code => $c_code, 880 class => '', 881 name => 'new', 882 }; 883 884} 885 886 887# ============================================================================ 888 889sub get_structure_destroy { 890 my ($self, $class, $struct) = @_ ; 891 892 my $cclass = $self -> cname($class) ; 893 my $cnvprefix = $self -> my_cnv_prefix ; 894 my $code = qq[ 895 896void 897DESTROY (obj) 898 $class obj 899CODE: 900 ${cclass}_destroy (aTHX_ obj) ; 901 902] ; 903 904 my $numfree = 0 ; 905 my $c_code = qq[ 906 907void ${cclass}_destroy (pTHX_ $cclass obj) { 908]; 909 910 foreach my $e (@{ $struct->{elts} }) { 911 if (($e -> {class} !~ /::/) || ($e -> {rtype} =~ /\*$/)) { 912 if ($e -> {free}) { 913 my $src = "obj -> $e->{name}" ; 914 my $type = $e->{rtype} ; 915 my $expr = eval ('"' . $e -> {free} . '"') ; 916 print $@ if ($@) ; 917 $c_code .= " if (obj -> $e->{name})\n" ; 918 $c_code .= ' ' . $expr . ";\n" ; 919 $numfree++ ; 920 } 921 } 922 } 923 $c_code .= "\n};\n\n" ; 924 925 if ($numfree) { 926 push @{ $self->{XS}->{ $struct->{module} } }, { 927 code => $code, 928 class => $class, 929 name => 'destroy', 930 }; 931 932 unshift @{ $self->{XS}->{ $struct->{module} } }, { 933 code => $c_code, 934 class => '', 935 name => 'destroy', 936 }; 937 } 938 939} 940 941# ============================================================================ 942 943sub get_structures { 944 my $self = shift; 945 my $typemap = $self->typemap; 946 my $has_callbacks = 0 ; 947 948 for my $entry (@{ structure_table($self) }) { 949 print 'struct ', $entry->{type} || '???', "...\n" ; 950 951 my $struct = $typemap->map_structure($entry); 952 print Data::Dumper -> Dump ([$entry, $struct], ['Table Entry', 'Mapfile Entry']) if ($verbose) ; 953 if (!$struct) 954 { 955 print "WARNING: Struture '$entry->{type}' not found in map file\n" ; 956 next ; 957 } 958 959 my $class = $struct->{class}; 960 $has_callbacks = 0 ; 961 962 for my $e (@{ $struct->{elts} }) { 963 my($name, $default, $type, $perl_name ) = 964 @{$e}{qw(name default type perl_name)}; 965 966 print " $name...\n" ; 967 968 if ($e -> {callback}) { 969 #print "callback < ", Dumper ($e) , "\n" ; 970 $self -> get_function ($e -> {func}) ; 971 $self -> get_callback_function ($e -> {func}, $struct, $e) ; 972 $has_callbacks++ ; 973 } 974 else { 975 (my $cast = $type) =~ s/:/_/g; 976 my $val = get_value($e); 977 978 my $type_in = $type; 979 my $preinit = "/*nada*/"; 980 my $address = '' ; 981 my $rdonly = 0 ; 982 my $strncpy ; 983 if ($e->{class} eq 'PV' and $val ne 'val') { 984 $type_in =~ s/char/char_len/; 985 $preinit = "STRLEN val_len;"; 986 } elsif (($e->{class} =~ /::/) && ($e -> {rtype} !~ /\*\s*$/)) { 987 # an inlined struct is read only 988 $rdonly = 1 ; 989 $address = '&' ; 990 } elsif ($name =~ /^(.*?)\[(.*?)\]$/) { 991 $strncpy = $2 ; 992 $name = $1 ; 993 $perl_name =~ s/\[.*?\]$// ; 994 $type = 'char *' ; 995 $type_in = 'char *' ; 996 $cast = 'char *' ; 997 } 998 999 my $attrs = $self->attrs($name); 1000 1001 my $code = <<EOF; 1002$type 1003$perl_name(obj, val=$default) 1004 $class obj 1005 $type_in val 1006 PREINIT: 1007 $preinit 1008$attrs 1009 CODE: 1010 RETVAL = ($cast) $address obj->$name; 1011EOF 1012 if ($rdonly) { 1013 $code .= <<EOF 1014 if (items > 1) { 1015 croak (\"$name is read only\") ; 1016 } 1017EOF 1018 } 1019 else { 1020 $code .= "\n if (items > 1) {\n" ; 1021 if ($e -> {malloc}) { 1022 my $dest = "obj->$name" ; 1023 my $src = $val ; 1024 my $type = $cast ; 1025 my $expr = eval ('"' . $e -> {malloc} . '"') ; 1026 print $@ if ($@) ; 1027 $code .= ' ' . $expr . ";\n" ; 1028 } 1029 elsif ($strncpy) { 1030 $code .= " strncpy(obj->$name, ($cast) $val, ($strncpy) - 1) ;\n" ; 1031 $code .= " obj->$name\[($strncpy)-1] = '\\0';\n" ; 1032 } 1033 else { 1034 $code .= " obj->$name = ($cast) $val;\n" ; 1035 } 1036 $code .= " }\n" ; 1037 } 1038 1039 $code .= <<EOF; 1040 OUTPUT: 1041 RETVAL 1042 1043EOF 1044 push @{ $self->{XS}->{ $struct->{module} } }, { 1045 code => $code, 1046 class => $class, 1047 name => $name, 1048 perl_name => $e -> {perl_name}, 1049 comment => $e -> {comment}, 1050 struct_member => $e, 1051 }; 1052 } 1053 } 1054 $self -> get_structure_new($class, $struct) if ($struct->{has_new}) ; 1055 $self -> get_structure_destroy($class, $struct) if ($struct->{has_new}) ; 1056 $self -> get_structure_callback_init ($class, $struct) if ($has_callbacks); 1057 1058 } 1059} 1060 1061# ============================================================================ 1062 1063sub prepare { 1064 my $self = shift; 1065 $self->{DIR} = $self -> xs_target_dir; 1066 $self->{XS_DIR} = $self -> xs_target_dir ; 1067 1068 if (-e $self->{DIR}) { 1069 rmtree([$self->{DIR}], 1, 1); 1070 } 1071 1072 mkpath [$self->{DIR}], 1, 0755; 1073} 1074 1075# ============================================================================ 1076 1077sub class_dirname { 1078 my($self, $class) = @_; 1079# my($base, $sub) = split '::', $class; 1080# return "$self->{DIR}/$base" unless $sub; #Apache | APR 1081# return $sub if $sub eq $self->{DIR}; #WrapXS 1082# return "$base/$sub"; 1083 1084 $class =~ s/::/\//g ; 1085 return $class ; 1086} 1087 1088# ============================================================================ 1089 1090sub class_dir { 1091 my($self, $class) = @_; 1092 1093 my $dirname = $self->class_dirname($class); 1094 #my $dir = ($dirname =~ m:/: and $dirname !~ m:^$self->{DIR}:) ? 1095 # join('/', $self->{DIR}, $dirname) : $dirname; 1096 my $dir = join('/', $self->{DIR}, $dirname) ; 1097 1098 mkpath [$dir], 1, 0755 unless -d $dir; 1099 1100 $dir; 1101} 1102 1103# ============================================================================ 1104 1105sub class_file { 1106 my($self, $class, $file) = @_; 1107 join '/', $self->class_dir($class), $file; 1108} 1109 1110# ============================================================================ 1111 1112sub cname { 1113 my($self, $class) = @_; 1114 confess ('ERROR: class is undefined in cname') if (!defined ($class)) ; 1115 $class =~ s/::$// ; 1116 $class =~ s/:/_/g; 1117 $class; 1118} 1119 1120 1121 1122# ============================================================================ 1123 1124sub convert_2obj { 1125 my($self, $class, $name) = @_; 1126 1127 $self -> my_cnv_prefix . $self -> cname($class) . "_2obj($name)" ; 1128} 1129 1130 1131# ============================================================================ 1132 1133sub convert_sv2 { 1134 my($self, $rtype, $class, $name) = @_; 1135 1136 $class =~ s/^const\s+// ; 1137 $class =~ s/char\s*\*/PV/ ; 1138 $class =~ s/SV\s*\*/SV/ ; 1139 1140 return "($rtype)" . $self -> my_cnv_prefix . 'sv2_' . $self -> cname($class) . "($name)" ; 1141} 1142 1143 1144# ============================================================================ 1145 1146sub open_class_file { 1147 my($self, $class, $file) = @_; 1148 1149 if ($file =~ /^\./) { 1150 my $sub = (split '::', $class)[-1]; 1151 $file = $sub . $file; 1152 } 1153 1154 my $name = $self->class_file($class, $file); 1155 1156 open my $fh, '>', $name or die "open $name: $!"; 1157 print "writing...$name\n"; 1158 1159 return $fh; 1160} 1161 1162 1163# ============================================================================ 1164=pod 1165 1166=head2 makefilepl_text (o) 1167 1168Returns text for Makefile.PL 1169 1170=cut 1171 1172sub makefilepl_text { 1173 my($self, $class, $deps,$typemap) = @_; 1174 1175 my @parts = split (/::/, $class) ; 1176 my $mmargspath = '../' x @parts ; 1177 $mmargspath .= 'mmargs.pl' ; 1178 1179 my $txt = qq{ 1180$self->{noedit_warning_hash} 1181 1182use ExtUtils::MakeMaker (); 1183 1184local \$MMARGS ; 1185 1186if (-f '$mmargspath') 1187 { 1188 do '$mmargspath' ; 1189 die \$\@ if (\$\@) ; 1190 } 1191 1192\$MMARGS ||= {} ; 1193 1194 1195ExtUtils::MakeMaker::WriteMakefile( 1196 'NAME' => '$class', 1197 'VERSION' => '0.01', 1198 'TYPEMAPS' => ['$typemap'], 1199} ; 1200$txt .= "'depend' => $deps,\n" if ($deps) ; 1201$txt .= qq{ 1202 \%\$MMARGS, 1203); 1204 1205} ; 1206 1207} 1208 1209# ============================================================================ 1210 1211sub write_makefilepl { 1212 my($self, $class) = @_; 1213 1214 $self -> {makefilepls}{$class} = 1 ; 1215 1216 my $fh = $self->open_class_file($class, 'Makefile.PL'); 1217 1218 my $includes = $self->includes; 1219 my @parts = split '::', $class ; 1220 my $xs = @parts?$parts[-1] . '.c':'' ; 1221 my $deps = {$xs => ""}; 1222 1223 if (my $mod_h = $self->mod_h($class, 1)) { 1224 my $abs = File::Spec -> rel2abs ($mod_h) ; 1225 my $rel = File::Spec -> abs2rel ($abs, $self -> class_dir ($class)) ; 1226 $deps->{$xs} .= " $rel"; 1227 } 1228 1229 local $Data::Dumper::Terse = 1; 1230 $deps = Dumper $deps; 1231 $deps = undef if (!$class) ; 1232 1233 $class ||= 'WrapXS' ; 1234 print $fh $self -> makefilepl_text ($class, $deps, ('../' x @parts) . 'typemap') ; 1235 1236 close $fh; 1237} 1238 1239# ============================================================================ 1240 1241sub write_missing_makefilepls { 1242 my($self, $class) = @_; 1243 1244 my %classes = ('' => 1) ; 1245 foreach (keys %{$self -> {makefilepls}}) 1246 { 1247 my @parts = split (/::/, $_) ; 1248 my $i ; 1249 for ($i = 0; $i < @parts; $i++) 1250 { 1251 $classes{join('::', @parts[0..$i])} = 1 ; 1252 } 1253 } 1254 1255 foreach my $class (keys %classes) 1256 { 1257 next if ($self -> {makefilepls}{$class}) ; 1258 1259 $self -> write_makefilepl ($class) ; 1260 } 1261} 1262 1263# ============================================================================ 1264 1265sub mod_h { 1266 my($self, $module, $complete) = @_; 1267 1268 my $dirname = $self->class_dirname($module); 1269 my $cname = $self->cname($module); 1270 my $mod_h = "$dirname/$cname.h"; 1271 1272 for ($self -> xs_include_dir, @{ $self->{glue_dirs} }) { 1273 my $file = "$_/$mod_h"; 1274 $mod_h = $file if $complete; 1275 return $mod_h if -e $file; 1276 } 1277 1278 undef; 1279} 1280 1281# ============================================================================ 1282 1283sub mod_pm { 1284 my($self, $module, $complete) = @_; 1285 1286 my $dirname = $self->class_dirname($module); 1287 my @parts = split '::', $module; 1288 my $mod_pm = "$dirname/$parts[-1]_pm"; 1289 1290 for ($self -> xs_incsrc_dir, @{ $self->{glue_dirs} }) { 1291 my $file = "$_/$mod_pm"; 1292 $mod_pm = $file if $complete; 1293 print "mod_pm $mod_pm $file $complete\n" ; 1294 return $mod_pm if -e $file; 1295 } 1296 1297 undef; 1298} 1299 1300 1301# ============================================================================ 1302=pod 1303 1304=head2 h_filename_prefix (o) 1305 1306Defines a prefix for generated header files 1307 1308Default: C<'xs_'> 1309 1310=cut 1311 1312sub h_filename_prefix { 'xs_' } 1313 1314# ============================================================================ 1315=pod 1316 1317=head2 my_xs_prefix (o) 1318 1319Defines a prefix used for all XS functions 1320 1321Default: C<'xs_'> 1322 1323=cut 1324 1325sub my_xs_prefix { 'xs_' } 1326 1327# ============================================================================ 1328=pod 1329 1330=head2 my_cnv_prefix (o) 1331 1332Defines a prefix used for all conversion functions/macros. 1333 1334Default: C<my_xs_prefix> 1335 1336=cut 1337 1338sub my_cnv_prefix { $_[0] -> my_xs_prefix } 1339 1340# ============================================================================ 1341=pod 1342 1343=head2 needs_prefix (o, name) 1344 1345Returns true if the passed name should be prefixed 1346 1347=cut 1348 1349sub needs_prefix { 1350 return 0 if (!$_[1]) ; 1351 my $pf = $_[0] -> my_xs_prefix ; 1352 return $_[1] !~ /^$pf/i; 1353} 1354 1355# ============================================================================ 1356 1357 1358sub isa_str { 1359 my($self, $module) = @_; 1360 my $str = ""; 1361 1362 if (my $isa = $self->typemap->{function_map}->{isa}->{$module}) { 1363 while (my($sub, $base) = each %$isa) { 1364#XXX cannot set isa in the BOOT: section because XSLoader local-ises 1365#ISA during bootstrap 1366# $str .= qq{ av_push(get_av("$sub\::ISA", TRUE), 1367# newSVpv("$base",0));} 1368 $str .= qq{\@$sub\::ISA = '$base';\n} 1369 } 1370 } 1371 1372 $str; 1373} 1374 1375# ============================================================================ 1376 1377sub boot { 1378 my($self, $module) = @_; 1379 my $str = ""; 1380 1381 if (my $boot = $self->typemap->{function_map}->{boot}->{$module}) { 1382 $str = ' ' . $self -> my_xs_prefix . $self->cname($module) . "_BOOT(aTHXo);\n"; 1383 } 1384 1385 $str; 1386} 1387 1388# ============================================================================ 1389 1390my $notshared = join '|', qw(TIEHANDLE); #not sure why yet 1391 1392sub attrs { 1393 my($self, $name) = @_; 1394 my $str = ""; 1395 return $str if $name =~ /$notshared$/o; 1396 $str = " ATTRS: shared\n" if GvSHARED; 1397 $str; 1398} 1399 1400# ============================================================================ 1401 1402sub write_xs { 1403 my($self, $module, $functions) = @_; 1404 1405 my $fh = $self->open_class_file($module, '.xs'); 1406 print $fh "$self->{noedit_warning_c}\n"; 1407 1408 my @includes = @{ $self->includes }; 1409 1410 if (my $mod_h = $self->mod_h($module)) { 1411 push @includes, $mod_h; 1412 } 1413 1414 for (@includes) { 1415 print $fh qq{\#include "$_"\n\n}; 1416 } 1417 1418 my $last_prefix = ""; 1419 my $fmap = $self -> typemap -> {function_map} ; 1420 my $myprefix = $self -> my_xs_prefix ; 1421 1422 for my $func (@$functions) { 1423 my $class = $func->{class}; 1424 if ($class) 1425 { 1426 my $prefix = $func->{prefix}; 1427 $last_prefix = $prefix if $prefix; 1428 1429 if ($func->{name} =~ /^$myprefix/o) { 1430 #e.g. mpxs_Apache__RequestRec_ 1431 my $class_prefix = $fmap -> class_c_prefix($class); 1432 if ($func->{name} =~ /$class_prefix/) { 1433 $prefix = $fmap -> class_xs_prefix($class); 1434 } 1435 } 1436 1437 $prefix = $prefix ? " PREFIX = $prefix" : ""; 1438 print $fh "MODULE = $module PACKAGE = $class $prefix\n\n"; 1439 } 1440 1441 print $fh $func->{code}; 1442 } 1443 1444 if (my $destructor = $self->typemap->destructor($last_prefix)) { 1445 my $arg = $destructor->{argspec}[0]; 1446 1447 print $fh <<EOF; 1448void 1449$destructor->{name}($arg) 1450 $destructor->{class} $arg 1451 1452EOF 1453 } 1454 1455 print $fh "PROTOTYPES: disabled\n\n"; 1456 print $fh "BOOT:\n"; 1457 print $fh $self->boot($module); 1458 print $fh " items = items; /* -Wall */\n\n"; 1459 1460 if (my $newxs = $self->{newXS}->{$module}) { 1461 for my $xs (@$newxs) { 1462 print $fh qq{ cv = newXS("$xs->[0]", $xs->[1], __FILE__);\n}; 1463 print $fh qq{ GvSHARED_on(CvGV(cv));\n} if GvSHARED; 1464 } 1465 } 1466 1467 close $fh; 1468} 1469 1470# ============================================================================ 1471=pod 1472 1473=head2 pm_text (o, module, isa, code) 1474 1475Returns the text of a C<.pm> file, or undef if no C<.pm> file should be 1476written. 1477 1478Default: Create a C<.pm> file which bootstraps the XS code 1479 1480=cut 1481 1482sub pm_text { 1483 my($self, $module, $isa, $code) = @_; 1484 1485 return <<EOF; 1486$self->{noedit_warning_hash} 1487 1488package $module; 1489require DynaLoader ; 1490use strict ; 1491use vars qw{\$VERSION \@ISA} ; 1492$isa 1493push \@ISA, 'DynaLoader' ; 1494\$VERSION = '0.01'; 1495bootstrap $module \$VERSION ; 1496 1497$code 1498 14991; 1500__END__ 1501EOF 1502 1503} 1504 1505# ============================================================================ 1506 1507sub write_pm { 1508 my($self, $module) = @_; 1509 1510 1511 my $isa = $self->isa_str($module); 1512 1513 my $code = ""; 1514 if (my $mod_pm = $self->mod_pm($module, 1)) { 1515 open my $fh, '<', $mod_pm; 1516 local $/; 1517 $code = <$fh>; 1518 close $fh; 1519 } 1520 1521 my $base = (split '::', $module)[0]; 1522 my $loader = join '::', $base, 'XSLoader'; 1523 1524 my $text = $self -> pm_text ($module, $isa, $code) ; 1525 return if (!$text) ; 1526 1527 my $fh = $self->open_class_file($module, '.pm'); 1528 1529 print $fh $text ; 1530 1531} 1532 1533# ============================================================================ 1534 1535 1536sub write_typemap { 1537 my $self = shift; 1538 my $typemap = $self->typemap; 1539 my $map = $typemap->get; 1540 my %seen; 1541 1542 my $fh = $self->open_class_file('', 'typemap'); 1543 print $fh "$self->{noedit_warning_hash}\n"; 1544 1545 while (my($type, $t) = each %$map) { 1546 my $class = $t -> {class} ; 1547 $class ||= $type; 1548 next if $seen{$type}++ || $typemap->special($class); 1549 1550 my $typemap = $t -> {typemapid} ; 1551 if ($class =~ /::/) { 1552 next if $seen{$class}++ ; 1553 $class =~ s/::$// ; 1554 print $fh "$class\t$typemap\n"; 1555 } 1556 else { 1557 print $fh "$type\t$typemap\n"; 1558 } 1559 } 1560 1561 my $cnvprefix = $self -> my_cnv_prefix ; 1562 my $typemap_code = $typemap -> typemap_code ($cnvprefix); 1563 1564 1565 foreach my $dir ('INPUT', 'OUTPUT') { 1566 print $fh "\n$dir\n" ; 1567 while (my($type, $code) = each %{$typemap_code}) { 1568 print $fh "$type\n$code->{$dir}\n\n" if ($code->{$dir}) ; 1569 } 1570 } 1571 1572 close $fh; 1573} 1574 1575# ============================================================================ 1576 1577sub write_typemap_h_file { 1578 my($self, $method) = @_; 1579 1580 $method = $method . '_code'; 1581 my($h, $code) = $self->typemap->$method(); 1582 my $file = join '/', $self->{XS_DIR}, $h; 1583 1584 open my $fh, '>', $file or die "open $file: $!"; 1585 print $fh "$self->{noedit_warning_c}\n"; 1586 print $fh $code; 1587 close $fh; 1588} 1589 1590# ============================================================================ 1591 1592sub _pod_gen_siglet { 1593 1594 my $class = shift || '' ; 1595 1596 return '\%' if $class eq 'HV'; 1597 return '\@' if $class eq 'AV'; 1598 return '$'; 1599} 1600 1601# ============================================================================ 1602# Determine if the name is that of a function or an object 1603 1604sub _pod_is_function { 1605 1606 my $class = shift || ''; 1607 1608#print "_pod_is_function($class)\n"; 1609 1610 my %func_class = ( 1611 SV => 1, 1612 IV => 1, 1613 NV => 1, 1614 PV => 1, 1615 UV => 1, 1616 PTR => 1, 1617 ); 1618 1619 exists $func_class{$class}; 1620} 1621 1622# ============================================================================ 1623 1624sub generate_pod { 1625 1626 my $self = shift ; 1627 my $fh = shift; 1628 my $pdd = shift; 1629 my $templ = $self -> new_podtemplate ; 1630 1631 my $since = $templ -> since_default ; 1632 print $fh $templ -> gen_pod_head ($pdd->{module}) ; 1633 1634 my $detail = $pdd->{functions_detailed}; 1635 1636 unless ( ref($detail) eq 'ARRAY') { 1637 warn "No functions listed in pdd structure for $pdd->{module}"; 1638 return; 1639 } 1640 1641 1642 foreach my $f (@$detail) { 1643 1644 # Generate the function or method name 1645 1646 my $method = $f->{perl_name}; 1647 $method = $1 if ($f->{prefix} && ($method =~ /^$f->{prefix}(.*?)$/)) ; 1648 $method = $1 if ($f->{class_xs_prefix} && ($method =~ /^(?:DEFINE_)?$f->{class_xs_prefix}(.*?)$/)) ; 1649 1650 if (!$method) { 1651 warn "Cannot determinate method name for '$f->{name}'" ; 1652 next ; 1653 } 1654 my $comment = $f->{comment_parsed}; 1655 my $commenttext = ($comment->{func_desc} || '') . "\n\n" . ($comment->{doxygen_remark} || '') ; 1656 my $member = $f -> {struct_member}; 1657 if ($member) 1658 { 1659 print $fh $templ -> gen_pod_struct_member ($f->{class}, '$obj', $f->{struct_member}->{class}, $f->{perl_name}, $commenttext, $since) ; 1660 } 1661 else 1662 { 1663 my $args = $f->{args}; 1664 if ($args && @$args) 1665 { 1666 my @param_nm = map { $_ -> {name} } @$args ; # Parameter names 1667 my $obj_nm; 1668 my $obj_sym; 1669 my $offset = 0; 1670 1671 my $first_param = $f->{args}[0]; 1672 unless (_pod_is_function($first_param->{class})) { 1673 $obj_nm = $param_nm[0]; # Object Name 1674 $obj_sym = &_pod_gen_siglet($first_param->{class}). $obj_nm; 1675 $offset++; 1676 } 1677 1678 1679 my $retclass ; 1680 my $retcomment = $comment -> {doxygen_return} || '' ; 1681 1682 if ($f -> {return_type} && $f -> {return_type} ne 'void') { 1683 my $rettype = $self -> typemap->get->{$f -> {return_type}} ; 1684 $retclass = $rettype?$rettype->{class}:$f -> {return_type}; 1685 } 1686 1687 1688 1689 my @param; 1690 my $i = 0 ; 1691 for my $param_nm (@param_nm) { 1692 my $arg = $args->[$i++]; 1693 push @param, { class => $arg->{class}, name => &_pod_gen_siglet($arg->{class}) . $param_nm, 1694 comment => ($comment->{doxygen_param_desc}{$param_nm} || '') } ; 1695 } 1696 1697 print $fh $templ -> gen_pod_func ($obj_sym, $obj_sym, $method, \@param, $retclass, $retcomment, $commenttext, $since) ; 1698 } 1699 } 1700 } 1701} 1702 1703 1704 1705# ============================================================================ 1706 1707# pdd = PERL Data Dumper 1708sub write_docs { 1709 my($self, $module, $functions) = @_; 1710 1711 my $fh = $self->open_class_file($module, '.pdd'); 1712 print $fh "$self->{noedit_warning_hash}\n"; 1713 1714 # Includes 1715 my @includes = @{ $self->includes }; 1716 1717 if (my $mod_h = $self->mod_h($module)) { 1718 push @includes, $mod_h; 1719 } 1720 1721 my $last_prefix = ""; 1722 my $fmap = $self->typemap->{function_map} ; 1723 my $myprefix = $self->my_xs_prefix ; 1724 1725 # Finding doxygen- and other data inside the comments 1726 1727 # This code only knows the syntax for @ingroup, @param, @remark, 1728 # @return and @warning. At the moment all other doxygen commands 1729 # are treated as multiple-occurance, no-parameter commands. 1730 1731 # Note: Nor does @deffunc exist in the doxygen specification, 1732 # neither does @remark (but @remarks), @tip and @see. So we treat 1733 # @remark like @remarks, but we don't do any speacial treating for 1734 # @deffunc. Ideas or suggestions anyone? 1735 1736 # --Axel Beckert 1737 1738 foreach my $details (@$functions) { 1739 #print "Comment: ", $details->{name} || '?', ': ', $details->{comment} || '-', "\n" ; 1740 #print "----> ", Dumper ($details) ;# if (!$details->{comment}) ; 1741 1742 if (defined $details->{comment} and 1743 my $comment = $details->{comment}) { 1744 $details->{comment_parsed} = {}; 1745 1746 # Source file 1747 if ($comment =~ s/^\s*(\S*\.c)\s+\*\n//s) { 1748 $details->{comment_parsed}{source_file} = $1; 1749 } 1750 1751 # Initialize several fields 1752 $details->{comment_parsed}{func_desc} = ""; 1753 my $doxygen = 0; # flag indicating that we already have 1754 # seen doxygen fields in this comment 1755 my $type = 0; # name of doxygen field 1756 my $pre = 0; # if we should recognize leading 1757 # spaces. Example see apr_table_overlap 1758 # Setting some regexps 1759 my $ordinary_line = qr/^\s*?\*(\s*(.*?))\s*$/; 1760 my $pre_begin = qr(<PRE>)i; 1761 my $pre_end = qr(</PRE>)i; 1762 1763 # Parse the rest of the comment line by line, because 1764 # doxygen fields can appear more than once 1765 foreach my $line (split /\n/, $comment) { 1766 1767 # Yesss! This looks like doxygen data. 1768 if ($line =~ /^\s*\*\s+[\\@](\w+)\s+(.*)\s*$/) { 1769 $type = $doxygen = $1; 1770 my $info = $2; 1771 1772 # setting the recognizing of leading spaces 1773 $pre = ($info =~ $pre_begin ? 1 : $pre); 1774 $pre = ($info =~ $pre_end ? 0 : $pre); 1775 1776 # Already had a doxygen element of this type for this func. 1777 if (defined $details->{comment_parsed}{"doxygen_$type"}) { 1778 push(@{ $details->{comment_parsed}{"doxygen_$type"} }, 1779 $info); 1780 } 1781 # Hey, hadn't seen this doxygen type in this function yet! 1782 else { 1783 $details->{comment_parsed}{"doxygen_$type"} = [ $info ]; 1784 } 1785 } 1786 # Further line belonging to doxygen field of the last line 1787 elsif ($doxygen) { 1788 # An empty line ends a doxygen paragraph 1789 if ($line =~ /^\s*$/) { 1790 $doxygen = 0; 1791 next; 1792 } 1793 1794 # Those two situations should never appear. But we 1795 # better double check those things. 1796 croak("There already was a doxygen comment, but it didn't set an type.\nStrange things happen") 1797 unless defined $details->{comment_parsed}{"doxygen_$type"}; 1798 croak("This ($line) maybe an syntactic incorrect doxygen line.\nStrange things happen") 1799 unless $line =~ $ordinary_line; 1800 my $info = $2; 1801 $info = $1 if $pre; 1802 1803 # setting the recognizing of leading spaces 1804 $pre = ($info =~ $pre_begin ? 1 : $pre); 1805 $pre = ($info =~ $pre_end ? 0 : $pre); 1806 $info =~ s(^\s+</PRE>)(</PRE>)i; 1807 1808 # Ok, get me the last line of documentation. 1809 my $lastline = 1810 pop @{ $details->{comment_parsed}{"doxygen_$type"} }; 1811 1812 # Concatenate that line and the actual line with a newline 1813 $info = "$lastline\n$info"; 1814 1815 # Strip empty lines at the end and beginning 1816 # unless there was a <PRE> before. 1817 unless ($pre) { 1818 $info =~ s/[\n\s]+$//s; 1819 $info =~ s/^[\n\s]+//s; 1820 } 1821 1822 # Push the back into the array 1823 push(@{ $details->{comment_parsed}{"doxygen_$type"} }, 1824 $info); 1825 } 1826 # Booooh! Just an ordinary comment 1827 elsif ($line =~ $ordinary_line) { 1828 my $info = $2; 1829 $info = $1 if $pre; 1830 1831 # setting the recognizing of leading spaces 1832 $pre = ($info =~ $pre_begin ? 1 : $pre); 1833 $pre = ($info =~ $pre_end ? 0 : $pre); 1834 $info =~ s(^\s+(</PRE>))($1)i; 1835 1836 # Only add if not an empty line at the beginning 1837 $details->{comment_parsed}{func_desc} .= "$info\n" 1838 unless ($info =~ /^\s*$/ and 1839 $details->{comment_parsed}{func_desc} eq ""); 1840 } else { 1841 if (defined $details->{comment_parsed}{unidentified}) { 1842 push(@{ $details->{comment_parsed}{unidentified} }, 1843 $line); 1844 } else { 1845 $details->{comment_parsed}{unidentified} = [ $line ]; 1846 } 1847 } 1848 } 1849 1850 # Unnecessary linebreaks at the end of the function description 1851 $details->{comment_parsed}{func_desc} =~ s/[\n\s]+$//s 1852 if defined $details->{comment_parsed}{func_desc}; 1853 1854 if (defined $details->{comment_parsed}{doxygen_param}) { 1855 # Remove the description from the doxygen_param and 1856 # move into an hash. A sole hash doesn't work, because 1857 # it usually screws up the parameter order 1858 1859 my %param; my @param; 1860 foreach (@{ $details->{comment_parsed}{doxygen_param} }) { 1861 my ($var, $desc) = split(" ",$_,2); 1862 $param{$var} = $desc; 1863 push(@param, $var); 1864 } 1865 $details->{comment_parsed}{doxygen_param} = [ @param ]; 1866 $details->{comment_parsed}{doxygen_param_desc} = { %param }; 1867 } 1868 1869 if (defined $details->{comment_parsed}{doxygen_defgroup}) { 1870 # Change doxygen_defgroup from array to hash 1871 1872 my %defgroup; 1873 foreach (@{ $details->{comment_parsed}{doxygen_defgroup} }) { 1874 my ($var, $desc) = split(" ",$_,2); 1875 $defgroup{$var} = $desc; 1876 } 1877 $details->{comment_parsed}{doxygen_defgroup} = { %defgroup }; 1878 } 1879 1880 if (defined $details->{comment_parsed}{doxygen_ingroup}) { 1881 # There should be a list of all parameters 1882 1883 my @ingroup = (); 1884 foreach (@{ $details->{comment_parsed}{doxygen_ingroup} }) { 1885 push(@ingroup, split()); 1886 } 1887 $details->{comment_parsed}{doxygen_ingroup} = [ @ingroup ]; 1888 } 1889 1890 foreach (qw(return warning remark)) { 1891 if (defined $details->{comment_parsed}{"doxygen_$_"}) { 1892 # Multiple adjacent @$_ should be concatenated, so 1893 # we can make an scalar out of it. Although we 1894 # actually still disregard the case, that there 1895 # are several non-adjacent @$_s. 1896 $details->{comment_parsed}{"doxygen_$_"} = 1897 join("\n", 1898 @{ $details->{comment_parsed}{"doxygen_$_"} }); 1899 } 1900 } 1901 1902 # Dump the output for debugging purposes 1903# print STDERR "### $details->{perl_name}:\n". 1904# Dumper $details->{comment_parsed}; 1905# print STDERR "### Original Comment:\n". 1906# Dumper $details->{comment}; 1907 1908 } 1909 1910 # Some more per function information, used in the XS files 1911 my $class = $details->{class}; 1912 if ($class) { 1913 my $prefix = $details->{prefix}; 1914 $last_prefix = $prefix if $prefix; 1915 1916 if ($details->{name} =~ /^$myprefix/o) { 1917 #e.g. mpxs_Apache__RequestRec_ 1918 my $class_prefix = $fmap -> class_c_prefix($class); 1919 if ($details->{name} =~ /$class_prefix/) { 1920 $details->{class_xs_prefix} = 1921 $fmap->class_xs_prefix($class); 1922 } 1923 $details->{class_c_prefix} = $class_prefix; 1924 } 1925 } 1926 } 1927 1928 1929 # Some more information, used in the XS files 1930 my $destructor = $self->typemap->destructor($last_prefix); 1931 my $boot = $self->boot($module); 1932 if ($boot) { 1933 chomp($boot); 1934 $boot =~ s/(\s+$|^\s+)//; 1935 } 1936 my $newxs = $self->{newXS}->{$module}; 1937 1938 # Finally do the PDD Dump 1939 my $pdd = { 1940 module => $module, 1941 functions => [ map $$_{perl_name}, @$functions ], 1942 functions_detailed => [ @$functions ], 1943 includes => [ @includes ], 1944 my_xs_prefix => $myprefix, 1945 destructor => $destructor, 1946 boot => $boot, 1947 newXS => $newxs 1948 }; 1949 1950 print $fh Dumper $pdd; 1951 close $fh; 1952 1953 $fh = $self->open_class_file($module, '.pod'); 1954 $self -> generate_pod($fh, $pdd); 1955 close $fh; 1956} 1957 1958# ============================================================================ 1959 1960sub generate { 1961 my $self = shift; 1962 1963 $self->prepare; 1964 1965 # now done by write_missing_makefilepls 1966 #for (qw(ModPerl::WrapXS Apache APR)) { 1967 # $self->write_makefilepl($_); 1968 #} 1969 1970 $self->write_typemap; 1971 1972 for (qw(typedefs sv_convert)) { 1973 $self->write_typemap_h_file($_); 1974 } 1975 1976 $self->get_functions; 1977 $self->get_structures; 1978 1979 while (my($module, $functions) = each %{ $self->{XS} }) { 1980# my($root, $sub) = split '::', $module; 1981# if (-e "$self->{XS_DIR}/$root/$sub/$sub.xs") { 1982# $module = join '::', $root, "Wrap$sub"; 1983# } 1984 if (!$module) 1985 { 1986 print "WARNING: empty module\n" ; 1987 next ; 1988 } 1989 print "mod $module\n" ; 1990 $self->write_makefilepl($module); 1991 $self->write_xs($module, $functions); 1992 $self->write_pm($module); 1993 $self->write_docs($module, $functions); 1994 } 1995 1996 $self -> write_missing_makefilepls ; 1997} 1998 1999# ============================================================================ 2000 2001sub stats { 2002 my $self = shift; 2003 2004 $self->get_functions; 2005 $self->get_structures; 2006 2007 my %stats; 2008 2009 while (my($module, $functions) = each %{ $self->{XS} }) { 2010 $stats{$module} += @$functions; 2011 if (my $newxs = $self->{newXS}->{$module}) { 2012 $stats{$module} += @$newxs; 2013 } 2014 } 2015 2016 return \%stats; 2017} 2018 2019# ============================================================================ 2020=pod 2021 2022=head2 mapline_elem (o, elem) 2023 2024Called for each structure element that is written to the map file by 2025checkmaps. Allows the user to change the element name, for example 2026adding a different perl name. 2027 2028Default: returns the element unmodified 2029 2030=cut 2031 2032sub mapline_elem { return $_[1] } ; 2033 2034# ============================================================================ 2035=pod 2036 2037=head2 mapline_func (o) 2038 2039Called for each function that is written to the map file by checkmaps. Allows 2040the user to change the function name, for example adding a different perl 2041name. 2042 2043Default: returns the element unmodified 2044 2045=cut 2046 2047sub mapline_func { return $_[1] } ; 2048 2049# ============================================================================ 2050 2051sub checkmaps { 2052 my $self = shift; 2053 my $prefix = shift; 2054 2055 $self = $self -> new if (!ref $self) ; 2056 2057 my $result = $self -> {typemap} -> checkmaps ; 2058 $self -> {typemap} -> writemaps ($result, $prefix) if ($prefix) ; 2059 2060 return $result ; 2061} 2062 2063# ============================================================================ 2064 2065sub run { 2066 my $class = shift ; 2067 2068 my $xs = $class -> new; 2069 2070 $xs->generate; 2071} 2072 2073 20741; 2075__END__ 2076