diff -Nru libextutils-xsbuilder-perl-0.28/debian/changelog libextutils-xsbuilder-perl-0.28/debian/changelog --- libextutils-xsbuilder-perl-0.28/debian/changelog 2010-05-09 19:12:41.000000000 +0100 +++ libextutils-xsbuilder-perl-0.28/debian/changelog 2010-02-08 18:02:25.000000000 +0000 @@ -1,3 +1,32 @@ +libextutils-xsbuilder-perl (0.28-2) unstable; urgency=low + + [ Jonathan Yu ] + * Bringing this package under the pkg-perl group (Closes: #543610) + * Updated d/watch with CPAN search site + * Standards-Version 3.8.3 + + Remove version dependency on perl + + Add Vcs-* and Homepage fields + + [ Ryan Niebur ] + * Update jawnsy's email address + + [ gregor herrmann ] + * debian/control: Added: ${misc:Depends} to Depends: field. + + [ Ansgar Burchardt ] + * Refresh rules for debhelper 7. + * Convert debian/copyright to proposed machine-readable format. + * debian/rules: Make build-dep on perl unversioned and move it to B-D-Indep. + * Bump Standards-Version to 3.8.4. + * Correct spelling error pointed out by lintian. + + new patch: spelling.patch + * Remove files in debian/rules instead of patching Makefile.PL. + * Move upstream changes to a patch. + + new patch: use-C-type.patch + * Add myself to Uploaders. + + -- Ansgar Burchardt Mon, 08 Feb 2010 00:09:09 +0900 + libextutils-xsbuilder-perl (0.28-1) unstable; urgency=low * New upstream version. diff -Nru libextutils-xsbuilder-perl-0.28/debian/compat libextutils-xsbuilder-perl-0.28/debian/compat --- libextutils-xsbuilder-perl-0.28/debian/compat 2010-05-09 19:12:41.000000000 +0100 +++ libextutils-xsbuilder-perl-0.28/debian/compat 2010-01-30 12:24:44.000000000 +0000 @@ -1 +1 @@ -5 +7 diff -Nru libextutils-xsbuilder-perl-0.28/debian/control libextutils-xsbuilder-perl-0.28/debian/control --- libextutils-xsbuilder-perl-0.28/debian/control 2010-05-09 19:12:41.000000000 +0100 +++ libextutils-xsbuilder-perl-0.28/debian/control 2010-02-08 18:02:25.000000000 +0000 @@ -1,13 +1,19 @@ Source: libextutils-xsbuilder-perl Section: perl Priority: optional -Build-Depends: debhelper (>= 3.0.5), perl (>= 5.6.0-17) -Maintainer: Angus Lees -Standards-Version: 3.7.3 +Build-Depends: debhelper (>= 7.0.50~) +Build-Depends-Indep: perl +Maintainer: Debian Perl Group +Uploaders: Jonathan Yu , + Ansgar Burchardt +Standards-Version: 3.8.4 +Homepage: http://search.cpan.org/dist/ExtUtils-XSBuilder/ +Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/libextutils-xsbuilder-perl/ +Vcs-Browser: http://svn.debian.org/viewsvn/pkg-perl/trunk/libextutils-xsbuilder-perl/ Package: libextutils-xsbuilder-perl Architecture: all -Depends: libparse-recdescent-perl, libtie-ixhash-perl, ${perl:Depends} +Depends: ${misc:Depends}, libparse-recdescent-perl, libtie-ixhash-perl, ${perl:Depends} Description: Automatic XS glue code generation ExtUtils::XSBuilder is a set of modules to parse C header files and create XS glue code and documentation from it. diff -Nru libextutils-xsbuilder-perl-0.28/debian/copyright libextutils-xsbuilder-perl-0.28/debian/copyright --- libextutils-xsbuilder-perl-0.28/debian/copyright 2010-05-09 19:12:41.000000000 +0100 +++ libextutils-xsbuilder-perl-0.28/debian/copyright 2010-01-30 12:24:44.000000000 +0000 @@ -1,16 +1,30 @@ -This package was put together by Angus Lees using -source downloaded from ftp://ftp.dev.ecos.de/pub/perl/xsbuilder/ +Format-Specification: http://svn.debian.org/wsvn/dep/web/deps/dep5.mdwn?op=file&rev=135 +Maintainer: Gerald Richter +Source: http://search.cpan.org/dist/ExtUtils-XSBuilder/ +Name: ExtUtils-XSBuilder -The upstream author is G.Richter (richter@dev.ecos.de). +Copyright: + © 2000-2001, Doug MacEachern + © 2001-2004, Gerald Richter / ecos gmbh (www.ecos.de) +License-Alias: Perl +License: Artistic | GPL-1+ -Copyright (c) 2000-2001 Doug MacEachern -Copyright (c) 2001-2002 Gerald Richter / ecos gmbh (www.ecos.de) +Files: debian/* +Copyright: + © 2002-2008, Angus Lees + © 2010, Ansgar Burchardt +License: Artistic | GPL-1+ -You may distribute under the terms of either the GNU General Public -License or the Artistic License, as specified in the Perl README file. -(On a Debian system, the text of these licenses may be found in -/usr/share/common-licenses/) +License: Artistic + This program is free software; you can redistribute it and/or modify + it under the terms of the Artistic License, which comes with Perl. + On Debian GNU/Linux systems, the complete text of the Artistic License + can be found in `/usr/share/common-licenses/Artistic' -THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED -WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF -MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. +License: GPL-1+ + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + On Debian GNU/Linux systems, the complete text of the GNU General + Public License can be found in `/usr/share/common-licenses/GPL' diff -Nru libextutils-xsbuilder-perl-0.28/debian/libextutils-xsbuilder-perl.docs libextutils-xsbuilder-perl-0.28/debian/libextutils-xsbuilder-perl.docs --- libextutils-xsbuilder-perl-0.28/debian/libextutils-xsbuilder-perl.docs 1970-01-01 01:00:00.000000000 +0100 +++ libextutils-xsbuilder-perl-0.28/debian/libextutils-xsbuilder-perl.docs 2010-01-30 12:24:44.000000000 +0000 @@ -0,0 +1 @@ +xsbuilder.osc2002.pod diff -Nru libextutils-xsbuilder-perl-0.28/debian/patches/series libextutils-xsbuilder-perl-0.28/debian/patches/series --- libextutils-xsbuilder-perl-0.28/debian/patches/series 1970-01-01 01:00:00.000000000 +0100 +++ libextutils-xsbuilder-perl-0.28/debian/patches/series 2010-02-08 18:02:25.000000000 +0000 @@ -0,0 +1,2 @@ +use-C-type.patch +spelling.patch diff -Nru libextutils-xsbuilder-perl-0.28/debian/patches/spelling.patch libextutils-xsbuilder-perl-0.28/debian/patches/spelling.patch --- libextutils-xsbuilder-perl-0.28/debian/patches/spelling.patch 1970-01-01 01:00:00.000000000 +0100 +++ libextutils-xsbuilder-perl-0.28/debian/patches/spelling.patch 2010-02-04 21:24:52.000000000 +0000 @@ -0,0 +1,15 @@ +From: Ansgar Burchardt +Subject: Correct spelling errors +Bug: https://rt.cpan.org/Ticket/Display.html?id=54313 + +--- libextutils-xsbuilder-perl.orig/XSBuilder.pod ++++ libextutils-xsbuilder-perl/XSBuilder.pod +@@ -62,7 +62,7 @@ + + =head2 Create map files + +-XSBuilder will not automaticly create XS functions for all C functions and ++XSBuilder will not automatically create XS functions for all C functions and + structures. You must provide hints in order for the XS files to be created + properly. The map files are the mechanism to provide these hints. By default, + the map files are found under C. There are four map types, C, diff -Nru libextutils-xsbuilder-perl-0.28/debian/patches/use-C-type.patch libextutils-xsbuilder-perl-0.28/debian/patches/use-C-type.patch --- libextutils-xsbuilder-perl-0.28/debian/patches/use-C-type.patch 1970-01-01 01:00:00.000000000 +0100 +++ libextutils-xsbuilder-perl-0.28/debian/patches/use-C-type.patch 2010-02-08 18:02:25.000000000 +0000 @@ -0,0 +1,19 @@ +From: Angus Lees +Date: Mon, 10 Mar 2003 22:47:03 +1100 +Forwarded: https://rt.cpan.org/Public/Bug/Display.html?id=54387 +Subject: use C type instead of mapped perl type for return declarations + +Patch WrapXS::get_function to use C type instead of mapped perl type for +return declarations. +--- libextutils-xsbuilder-perl.orig/XSBuilder/WrapXS.pm ++++ libextutils-xsbuilder-perl/XSBuilder/WrapXS.pm +@@ -557,7 +557,8 @@ + $name =~ /^DESTROY$/ ? 'void' : $func->{return_type}; + + my $retdecl = @$retargs?(join "\n", +- (map { my $type = $self -> cname($_->{class}) ; $type =~ s/\*$//; ' ' . $type . " $_->{name};"} @$retargs), ++ # TypeMap->map_args has already stripped a * from retargs ++ (map { my $type = $_->{rtype} ; $type =~ s/^const\s+//; ' ' . $type . " $_->{name};"} @$retargs), + #' ' . $self -> cname($return_type) . ' RETVAL', + ''):''; + diff -Nru libextutils-xsbuilder-perl-0.28/debian/rules libextutils-xsbuilder-perl-0.28/debian/rules --- libextutils-xsbuilder-perl-0.28/debian/rules 2010-05-09 19:12:41.000000000 +0100 +++ libextutils-xsbuilder-perl-0.28/debian/rules 2010-02-08 18:02:25.000000000 +0000 @@ -1,85 +1,15 @@ #!/usr/bin/make -f -#-*- makefile -*- -# Made with the aid of dh_make, by Craig Small -# Sample debian/rules that uses debhelper. GNU copyright 1997 by Joey Hess. -# Some lines taken from debmake, by Christoph Lameter. -# Uncomment this to turn on verbose mode. -#export DH_VERBOSE=1 +PACKAGE := $(shell dh_listpackages) +TMP := $(CURDIR)/debian/$(PACKAGE) -PACKAGE=$(shell dh_listpackages) +%: + dh $@ -ifndef PERL -PERL = /usr/bin/perl -endif - -ifndef DESTDIR -DESTDIR=.. -endif -TMP=$(CURDIR)/debian/$(PACKAGE) - -build: build-stamp -build-stamp: - dh_testdir - - $(PERL) Makefile.PL INSTALLDIRS=vendor - $(MAKE) - -# fix upstream permissions - find blib -type f -perm +111 -exec chmod a-x {} \; - - touch build-stamp - -clean: - dh_testdir - dh_testroot - rm -f build-stamp - - test ! -f Makefile || $(MAKE) realclean - - dh_clean - -install: - dh_testdir - dh_testroot - dh_clean -k - dh_installdirs - - $(MAKE) install PREFIX=$(TMP)/usr - - -# Build architecture-dependent files here. -binary-arch: build install -# We have nothing to do by default. - -# Build architecture-independent files here. -binary-indep: build install -# dh_testversion - dh_testdir - dh_testroot - dh_installdocs README xsbuilder.osc2002.pod - dh_installexamples - dh_installmenu -# dh_installemacsen -# dh_installinit - dh_installcron - dh_installman -# dh_undocumented - dh_installchangelogs Changes - dh_link -# dh_strip - dh_compress - dh_fixperms -# dh_makeshlibs - dh_installdeb - dh_perl - dh_shlibdeps - dh_gencontrol - dh_md5sums - dh_builddeb --destdir=$(DESTDIR) - -source diff: - @echo >&2 'source and diff are obsolete - use dpkg-source -b'; false - -binary: binary-indep binary-arch -.PHONY: build clean binary-indep binary-arch binary +override_dh_auto_install: + dh_auto_install + chmod -x $(TMP)/usr/share/perl5/ExtUtils/XSBuilder.pod + $(RM) $(TMP)/usr/share/man/man3/ExtUtils::XSBuilder::C::grammar.3pm + $(RM) $(TMP)/usr/share/man/man3/ExtUtils::XSBuilder::PODTemplate.3pm + $(RM) $(TMP)/usr/share/man/man3/ExtUtils::xsbuilder.osc2002.3pm + $(RM) $(TMP)/usr/share/perl5/ExtUtils/xsbuilder.osc2002.pod diff -Nru libextutils-xsbuilder-perl-0.28/debian/source/format libextutils-xsbuilder-perl-0.28/debian/source/format --- libextutils-xsbuilder-perl-0.28/debian/source/format 1970-01-01 01:00:00.000000000 +0100 +++ libextutils-xsbuilder-perl-0.28/debian/source/format 2010-05-09 19:12:41.000000000 +0100 @@ -0,0 +1 @@ +3.0 (quilt) diff -Nru libextutils-xsbuilder-perl-0.28/debian/watch libextutils-xsbuilder-perl-0.28/debian/watch --- libextutils-xsbuilder-perl-0.28/debian/watch 2010-05-09 19:12:41.000000000 +0100 +++ libextutils-xsbuilder-perl-0.28/debian/watch 2009-08-26 16:04:52.000000000 +0100 @@ -1,2 +1,5 @@ -version=2 -ftp://ftp.dev.ecos.de/pub/perl/xsbuilder/ExtUtils-XSBuilder-(.*)\.tar\.gz debian +# format version number, currently 3; this line is compulsory! +version=3 +# URL to the package page followed by a regex to search +http://search.cpan.org/dist/ExtUtils-XSBuilder/ .*/ExtUtils-XSBuilder-v?(\d[\d.-]+)\.(?:tar(?:\.gz|\.bz2)?|tgz|zip)$ + diff -Nru libextutils-xsbuilder-perl-0.28/Makefile.PL libextutils-xsbuilder-perl-0.28/Makefile.PL --- libextutils-xsbuilder-perl-0.28/Makefile.PL 2010-05-09 19:12:41.000000000 +0100 +++ libextutils-xsbuilder-perl-0.28/Makefile.PL 2002-12-20 12:32:14.000000000 +0000 @@ -10,19 +10,3 @@ ); - -# Debian hacks -package MY; - -sub libscan { - $_[1] !~ /xsbuilder\.osc2002/ and shift->SUPER::libscan(@_); -} - -sub post_initialize { - my $self = shift; - - # The pod in this file isn't a manpage.. - delete $self->{MAN3PODS}{'XSBuilder/PODTemplate.pm'}; - - return $self->SUPER::post_initialize(@_); -} diff -Nru libextutils-xsbuilder-perl-0.28/XSBuilder/WrapXS.pm libextutils-xsbuilder-perl-0.28/XSBuilder/WrapXS.pm --- libextutils-xsbuilder-perl-0.28/XSBuilder/WrapXS.pm 2010-05-09 19:12:41.000000000 +0100 +++ libextutils-xsbuilder-perl-0.28/XSBuilder/WrapXS.pm 2005-08-31 05:59:00.000000000 +0100 @@ -1,2076 +1,2075 @@ -package ExtUtils::XSBuilder::WrapXS; - -use strict; -use warnings FATAL => 'all'; - -use constant GvSHARED => 0; #$^V gt v5.7.0; - -use File::Spec ; -use ExtUtils::XSBuilder::TypeMap (); -use ExtUtils::XSBuilder::MapUtil qw(function_table structure_table callback_table); -use ExtUtils::XSBuilder::PODTemplate ; -use File::Path qw(rmtree mkpath); -use Cwd qw(fastcwd); -use Data::Dumper; - -use Carp qw(confess) ; - -our $VERSION = '0.03'; - -my %warnings; -my $verbose = 0 ; - -=pod - -=head1 NAME - -ExtUtils::XSBuilder::WrapXS - create perl XS wrappers for C functions - -=head2 DESCRIPTION - -For more information, see L - -=cut - -# ============================================================================ - -sub new { - my $class = shift; - - my $self = bless { - }, $class; - - $self -> {glue_dirs} = [$self -> xs_glue_dirs()] ; - $self -> {typemap} = $self -> new_typemap ; - $self -> {parsesource} = $self -> new_parsesource ; - $self -> {xs_includes} = $self -> xs_includes ; - $self -> {callbackno} = 1 ; - - for (qw(c hash)) { - my $w = "noedit_warning_$_"; - my $method = $w ; - $self->{$w} = $self->$method(); - } - - $self->typemap->get; - $self; -} - -# ============================================================================ - -sub classname { - my $self = shift || __PACKAGE__; - ref($self) || $self; -} - -# ============================================================================ - -sub calls_trace { - my $frame = 1; - my $trace = ''; - - while (1) { - my($package, $filename, $line) = caller($frame); - last unless $filename; - $trace .= "$frame. $filename:$line\n"; - $frame++; - } - - return $trace; -} - -# ============================================================================ - -sub noedit_warning_c { - my $class = classname(shift); - my $warning = \$warnings{C}->{$class}; - return $$warning if $$warning; - my $v = join '/', $class, $class->VERSION; - my $trace = calls_trace(); - $trace =~ s/^/ * /mg; - $$warning = <{$class}; - return $$warning if $$warning; - ($$warning = noedit_warning_c($class)) =~ s/^/\# /mg; - $$warning; -} - - -# ============================================================================ -=pod - -=head2 new_parsesource (o) - -Returns an array ref of new ParseSource objects for all source files that -should be used to generate XS files - -=cut - -sub new_parsesource { [ ExtUtils::XSBuilder::ParseSource->new ] } - - -# ============================================================================ -=pod - -=head2 new_typemap (o) - -Returns a new typemap object - -=cut - -sub new_typemap { ExtUtils::XSBuilder::TypeMap->new (shift) } - -# ============================================================================ -=pod - -=head2 new_podtemplate (o) - -Returns a new podtemplate object - -=cut - -sub new_podtemplate { ExtUtils::XSBuilder::PODTemplate->new } - -# ============================================================================ -=pod - -=head2 xs_includes (o) - -Returns a list of XS include files. - -Default: use all include files that C returns, but -strip path info - -=cut - -sub xs_includes - { - my $self = shift ; - my $parsesource = $self -> parsesource_objects ; - - my @includes ; - my @paths ; - foreach my $src (@$parsesource) { - push @includes, @{ $src -> find_includes } ; - push @paths, @{ $src -> include_paths } ; - } - - foreach (@paths) - { - s#(\\|/)$## ; - s#\\#/# ; - } - foreach (@includes) - { - s#\\#/# ; - } - - - # strip include paths - foreach my $file (@includes) - { - foreach my $path (@paths) - { - if ($file =~ /^\Q$path\E(\/|\\)(.*?)$/i) - { - $file = $2 ; - last ; - } - } - } - - - my %includes = map { $_ => 1 } @includes ; - my $fixup1 = $self -> h_filename_prefix . 'preperl.h' ; - my $fixup2 = $self -> h_filename_prefix . 'postperl.h' ; - - - - return [ - keys %includes, - -f $self -> xs_include_dir . '/'. $fixup1?$fixup1:(), - 'EXTERN.h', 'perl.h', 'XSUB.h', - -f $self -> xs_include_dir . '/'. $fixup2?$fixup2:(), - $self -> h_filename_prefix . 'sv_convert.h', - $self -> h_filename_prefix . 'typedefs.h', - ] ; - } - - - -# ============================================================================ -=pod - -=head2 xs_glue_dirs (o) - -Returns a list of additional XS glue directories to seach for maps in. - -=cut - - -sub xs_glue_dirs { - () ; -} - - -# ============================================================================ -=pod - -=head2 xs_base_dir (o) - -Returns a directory which serves as a base for other directories. - -Default: C<'.'> - -=cut - - -sub xs_base_dir { '.' } ; - - - -# ============================================================================ -=pod - -=head2 xs_map_dir (o) - -Returns the directory to search for map files in - -Default: C</xsbuilder/maps> - -=cut - - -sub xs_map_dir { File::Spec -> catdir ($_[0] -> xs_base_dir, 'xsbuilder', 'maps') } ; - -# ============================================================================ -=pod - -=head2 xs_incsrc_dir (o) - -Returns the directory to search for files to include into the source. For -example, C</Apache/DAV/Resource/Resource_pm> will be included into -the C module. - -Default: C</xsbuilder> - - -=cut - - -sub xs_incsrc_dir { File::Spec -> catdir ($_[0] -> xs_base_dir, 'xsbuilder') ; } ; - -# ============================================================================ -=pod - -=head2 xs_include_dir (o) - -Returns a directory to search for include files for pm and XS - -Default: C</xsinclude> - -=cut - - -sub xs_include_dir { File::Spec -> catdir ($_[0] -> xs_base_dir, 'xsinclude') ; } ; - -# ============================================================================ -=pod - -=head2 xs_target_dir (o) - -Returns the directory to write generated XS and header files in - -Default: C</xs> - -=cut - - -sub xs_target_dir { File::Spec -> catdir ($_[0] -> xs_base_dir, 'xs') ; } - - -# ============================================================================ - -sub typemap { shift->{typemap} } - -# ============================================================================ - -sub includes { shift->{xs_includes} || [] } - -# ============================================================================ - -sub parsesource_objects { shift->{parsesource} } - -# ============================================================================ - -sub function_list { - my $self = shift; - my(@list) = @{ function_table($self) }; - - while (my($name, $val) = each %{ $self->typemap->function_map }) { - #entries that do not exist in C::Scan generated tables - next unless $name =~ /^DEFINE_/; - push @list, $val; - } - - return \@list; -} - -# ============================================================================ - -sub callback_list { - my $self = shift; - my(@list) = @{ callback_table($self) }; - - while (my($name, $val) = each %{ $self->typemap->callback_map }) { - #entries that do not exist in C::Scan generated tables - next unless $name =~ /^DEFINE_/; - push @list, $val; - } - - return \@list; -} - -# ============================================================================ - -sub get_callback_function { - my ($self, $func, $struct, $elt) = @_ ; - - my $myprefix = $self -> my_xs_prefix ; - my $n ; - $elt -> {callbackno} = $n = $self -> {callbackno}++ ; - my $structelt = $elt -> {name} ; - my $class = $struct -> {class} ; - my $cclass = $self -> cname($class) ; - - my($name, $args, $retargs, $return_type, $orig_args, $userdataarg) = - @{ $func } { qw(perl_name args retargs return_type orig_args userdataarg) }; - - $struct -> {staticcnt} ||= 4 ; - my $staticcnt = $struct -> {staticcnt} ; - #print "get_callback_function: ", Data::Dumper -> Dump([$func]), "\n" ; - - my $code = "\n/* --- $class -> $structelt --- */\n\n" ; - my $cbname = "${myprefix}cb_${cclass}__$structelt" ; - my %retargs = map { $_->{name} => $_ } @$retargs ; - my %args = map { $_->{name} => $_ } @$args ; - my @args = map { my $name = /^(?:\*|&)(.*?)$/?$1:$_ ; ($args{$name}{rtype} || $retargs{$name}{rtype}) . (/^&/?" * $name":" $name") } @$orig_args ; - $return_type = $self -> cname($return_type) ; - my $return_class = $self -> typemap -> map_class ($return_type) || $return_type; - if ($return_class =~ / /) - { - print "ERROR: return class '$return_class' contains spaces" ; - } - - my $desttype = 'CV' ; - if ($structelt) - { - $desttype = 'SV' ; - } - - my $numret = $return_type eq 'void'?0:1 ; - $numret += @$retargs ; - my $callflags = $numret == 0?'G_VOID':$numret == 1?'G_SCALAR':'G_ARRAY' ; - - $code .= qq[ - -static $return_type $cbname (] . join (',', "$desttype * __cbdest", @args) . qq[) - { -] ; - $code .= " $return_type __retval ;\n" if ($return_type && $return_type ne 'void') ; - $code .= " SV * __retsv ;\n" if ($numret) ; - $code .= qq[ - int __cnt ; - - dSP ; - ENTER ; - SAVETMPS ; - PUSHMARK(SP) ; -]; - - if ($structelt) - { - $code .= " PUSHs(__cbdest) ;\n" ; - } - - foreach (@$orig_args) { - my $type = /^(?:\*|\&)(.*?)$/?$1:$_ ; - my $name = /^\*(.*?)$/?"&$1":$_ ; - next if ($retargs{$type}{class}) ; - if (!$args{$type}{class} && !$args{$type}{type}) - { - print "WARNING: unknown type for argument '$name' in struct member '$structelt'\n" ; - print Dumper ($args) ; - next ; - } - my $class = $args{$type}{class} || $args{$type}{type} ; - if ($class =~/\s/) - { - print "WARNING: type '$class' for argument '$name' in struct member '$structelt' contains spaces\n" ; - print Dumper ($args) ; - next ; - } - - $code .= ' PUSHs(' . $self -> convert_2obj ($class, $name) . ") ;\n" ; - } - - $code .= qq[ - PUTBACK ; -] ; - - if ($structelt) - { - $code .= " __cnt = perl_call_method(\"cb_$structelt\", $callflags) ;\n" ; - } - else - { - $code .= " __cnt = perl_call_sv(__cbdest, $callflags) ;\n" ; - } - - $code .= qq[ - - if (__cnt != $numret) - croak (\"$cbname expected $numret return values\") ; -] if ($numret > 0) ; - - $code .= qq[ - SPAGAIN ; -] ; - - if ($return_type && $return_type ne 'void') - { - $code .= " __retsv = POPs;\n" ; - $code .= ' __retval = ' . $self -> convert_sv2 ($return_type, $return_class, '__retsv') . ";\n" - } - foreach (@$retargs) { - $code .= " __retsv = POPs;\n" ; - $code .= " *$_->{name} = " . $self -> convert_sv2 ($_->{rtype}, $_->{class}, '__retsv') . ";\n" ; - } - - $code .= qq[ - PUTBACK ; - FREETMPS ; - LEAVE ; - - -] ; - $code .= " return __retval ;\n" if ($return_type && $return_type ne 'void') ; - $code .= qq[ - } - -] ; - - if (!$userdataarg) { - $staticcnt ||= 4 ; - - for (my $i = 0 ; $i < $staticcnt; $i++) { - $code .= qq[ - -static $return_type ${cbname}_obj$i (] . join (',', @args) . qq[) - { - ] . ($return_type eq 'void'?'':'return') . qq[ ${cbname} (] . - join (',', "${myprefix}${cclass}_obj[$i]", map { /^(?:\*|\&)?(.*?)$/ } @$orig_args) . qq[) ; - } - -] ; - - - } - $code .= "typedef $return_type (*t${cbname}_func)(" . join (',', @args) . qq") ;\n" ; - $code .= "static t${cbname}_func ${myprefix}${cbname}_func [$staticcnt] = {\n " . - join (",\n ", map { "${cbname}_obj$_" } (0..$staticcnt-1)) . "\n } ;\n\n\n" ; - } - - unshift @{ $self->{XS}->{ $func->{module} } }, { - code => $code, - class => '', - name => $name, - }; - -} - - - -# ============================================================================ - - - -sub get_function { - my ($self, $func) = @_ ; - - my $myprefix = $self -> my_xs_prefix ; - - my($name, $module, $class, $args, $retargs) = - @{ $func } { qw(perl_name module class args retargs) }; - - my %retargs = map { $_->{name} => $_ } @$retargs ; - - print "get_function: ", Data::Dumper -> Dump([$func]), "\n" if ($verbose); - #eg ap_fputs() - if ($name =~ s/^DEFINE_//) { - $func->{name} =~ s/^DEFINE_//; - - if (needs_prefix($func->{name})) { - #e.g. DEFINE_add_output_filter - $func->{name} = make_prefix($func->{name}, $class); - } - } - - my $xs_parms = join ', ', - map { defined $_->{default} ? - "$_->{name}=$_->{default}" : $_->{name} } @$args; - - my $parms ; - if ($func -> {dispatch_argspec}) - { - $parms = $func -> {dispatch_argspec} ; - } - else - { - ($parms = join (',', $xs_parms, - map { "\&$_->{name}" } @$retargs)) =~ - s/=[^,]+//g; #strip defaults - } - - my $proto = join "\n", - (map " $_->{type} $_->{name}", @$args) ; - - my $return_type = - $name =~ /^DESTROY$/ ? 'void' : $func->{return_type}; - - my $retdecl = @$retargs?(join "\n", - # TypeMap->map_args has already stripped a * from retargs - (map { my $type = $_->{rtype} ; $type =~ s/^const\s+//; ' ' . $type . " $_->{name};"} @$retargs), - #' ' . $self -> cname($return_type) . ' RETVAL', - ''):''; - - my($dispatch, $orig_args) = - @{ $func } {qw(dispatch orig_args)}; - - if ($dispatch =~ /^$myprefix/io) { - $name =~ s/^$myprefix//; - $name =~ s/^$func->{prefix}//; - push @{ $self->{newXS}->{ $module } }, - ["$class\::$name", $dispatch]; - return; - } - - my $passthru = @$args && $args->[0]->{name} eq '...'; - if ($passthru) { - $parms = '...'; - $proto = ''; - } - - my $attrs = $self->attrs($name); - - my $code = < {dispatch_argspec}) { - $parms = join ', ', map { $retargs{$_}?"&$_":$_} @$orig_args; - } - } - else { - ### ??? gr ### if ($orig_args and @$orig_args == @$args) { - if ($orig_args && @$orig_args) { - #args were reordered - $parms = join ', ', map { $retargs{$_}?"&$_":$_} @$orig_args; - } - - $dispatch = $func->{name}; - } - - if ($passthru) { - $thx ||= 'aTHX_ '; - $parms = 'items, MARK+1, SP'; - } - - my $retval = $return_type eq 'void' ? - ["", ""] : ["RETVAL = ", "OUTPUT:\n RETVAL\n"]; - - my $retnum = $retdecl?scalar(@$retargs) + ($return_type eq 'void' ?0:1):0 ; - $code .= $retdecl?"PPCODE:":"CODE:" ; - $code .= "\n $retval->[0]$dispatch($thx$parms);\n" ; - if ($retdecl) { - my $retclass = $self -> typemap -> map_class ($return_type) || $return_type ; - if ($retclass =~ / /) - { - print "ERROR: return class '$retclass' contains spaces" ; - } - $code .= " XSprePUSH;\n" ; - $code .= " EXTEND(SP, $retnum) ;\n" ; - $code .= ' PUSHs(' . $self -> convert_2obj ($retclass, 'RETVAL') . ") ;\n" ; - foreach (@$retargs) { - if ($_->{class} =~ / /) - { - print "ERROR: $_->{class} contains spaces; retargs = ", Dumper ($_) ; - } - $code .= ' PUSHs(' . $self -> convert_2obj ($_->{class}, $_->{name}) . ") ;\n" ; - } - } - else { - $code .= "$retval->[1]\n" ; - } - } - - $code .= "\n" ; - - $func->{code} = $code; - push @{ $self->{XS}->{ $module } }, $func; -} - -# ============================================================================ - - -sub get_functions { - my $self = shift; - - my $typemap = $self->typemap; - my %seen ; - for my $entry (@{ $self->function_list() }) { - #print "get_func ", Dumper ($entry) ; - my $func = $typemap->map_function($entry); - #print "FAILED to map $entry->{name}\n" unless $func; - next unless $func; - print "WARNING: Duplicate function: $entry->{name}\n" if ($seen{$entry->{name}}++) ; - $self -> get_function ($func) ; - } -} - - -# ============================================================================ - -sub get_value { - my $e = shift; - my $val = 'val'; - - if ($e->{class} eq 'PV') { - if (my $pool = $e->{pool}) { - $pool .= '(obj)'; - $val = "((ST(1) == &PL_sv_undef) ? NULL : - apr_pstrndup($pool, val, val_len))" - } - } - - return $val; -} -# ============================================================================ - -sub get_structure_callback_init { - my ($self, $class, $struct) = @_ ; - - my $cclass = $self -> cname($class) ; - - my $myprefix = $self -> my_xs_prefix ; - my $staticcnt = $struct -> {staticcnt} ; - - my $cnv = $self -> convert_sv2 ($cclass, $class, 'obj') ; - my $code = qq[ - -void -init_callbacks (obj, val=NULL) - SV * obj - SV * val -PREINIT: - int n = -1 ; - int i ; - $cclass cobj = $cnv ; - SV * ref ; - SV * perl_obj ; -CODE: - if (items > 1) - obj = val ; - - perl_obj = SvRV(obj) ; - ref = newRV_noinc(perl_obj) ; - - for (i=0;i < $staticcnt;i++) - { - if ($myprefix${cclass}_obj[i] == ref) - { - n = i ; - break ; - } - } - - if (n < 0) - for (i=0;i < $staticcnt;i++) - { - if ($myprefix${cclass}_obj[i] == NULL) - { - n = i ; - break ; - } - } - - if (n < 0) - croak ("Limit for concurrent object callbacks reached for $class. Limit is $staticcnt") ; - - $myprefix${cclass}_obj[n] = ref ; -] ; - - - foreach my $e (@{ $struct->{elts} }) { - if ($e -> {callback}) { - my $cbname = "${myprefix}cb_${cclass}__$e->{name}" ; - $code .= " cobj -> $e->{name} = ${myprefix}${cbname}_func[n] ;\n" ; - } - } - $code .= qq[ - -] ; - - my $ccode = "static SV * ${myprefix}${cclass}_obj[$staticcnt] ;\n\n" ; - - - push @{ $self->{XS}->{ $struct->{module} } }, { - code => $code, - class => $class, - name => 'init_callbacks', - }; - - unshift @{ $self->{XS}->{ $struct->{module} } }, { - code => $ccode, - class => '', - name => 'init_callbacks', - }; - -} - -# ============================================================================ - -sub get_structure_new { - my ($self, $class, $struct) = @_ ; - - my $cclass = $self -> cname($class) ; - my $cnvprefix = $self -> my_cnv_prefix ; - my $alloc = $struct -> {alloc} || 'malloc(sizeof(*cobj))' ; - my $code = qq[ - -SV * -new (class,initializer=NULL) - char * class - SV * initializer -PREINIT: - SV * svobj ; - $cclass cobj ; - SV * tmpsv ; -CODE: - ${cnvprefix}${cclass}_create_obj(cobj,svobj,RETVAL,$alloc) ; - - if (initializer) { - if (!SvROK(initializer) || !(tmpsv = SvRV(initializer))) - croak ("initializer for ${class}::new is not a reference") ; - - if (SvTYPE(tmpsv) == SVt_PVHV || SvTYPE(tmpsv) == SVt_PVMG) - ${cclass}_new_init (aTHX_ cobj, tmpsv, 0) ; - else if (SvTYPE(tmpsv) == SVt_PVAV) { - int i ; - SvGROW(svobj, sizeof (*cobj) * av_len((AV *)tmpsv)) ; - for (i = 0; i <= av_len((AV *)tmpsv); i++) { - SV * * itemrv = av_fetch((AV *)tmpsv, i, 0) ; - SV * item ; - if (!itemrv || !*itemrv || !SvROK(*itemrv) || !(item = SvRV(*itemrv))) - croak ("array element of initializer for ${class}::new is not a reference") ; - ${cclass}_new_init (aTHX_ &cobj[i], item, 1) ; - } - } - else { - croak ("initializer for ${class}::new is not a hash/array/object reference") ; - } - } -OUTPUT: - RETVAL - -] ; - - - my $c_code = qq[ - -void ${cclass}_new_init (pTHX_ $cclass obj, SV * item, int overwrite) { - - SV * * tmpsv ; - - if (SvTYPE(item) == SVt_PVMG) - memcpy (obj, (void *)SvIVX(item), sizeof (*obj)) ; - else if (SvTYPE(item) == SVt_PVHV) { -] ; - foreach my $e (@{ $struct->{elts} }) { - if ($e -> {name} =~ /^(.*?)\[(.*?)\]$/) { - my $strncpy = $2 ; - my $name = $1 ; - my $perl_name ; - ($perl_name = $e -> {perl_name}) =~ s/\[.*?\]$// ; - $c_code .= " if ((tmpsv = hv_fetch((HV *)item, \"$perl_name\", sizeof(\"$perl_name\") - 1, 0)) || overwrite) {\n" ; - $c_code .= " STRLEN l = 0;\n" ; - $c_code .= " if (tmpsv) {\n" ; - $c_code .= " char * s = SvPV(*tmpsv,l) ;\n" ; - $c_code .= " if (l > ($strncpy)-1) l = ($strncpy) - 1 ;\n" ; - $c_code .= " strncpy(obj->$name, s, l) ;\n" ; - $c_code .= " }\n" ; - $c_code .= " obj->$name\[l] = '\\0';\n" ; - $c_code .= " }\n" ; - } elsif (($e -> {class} !~ /::/) || ($e -> {rtype} =~ /\*$/)) { - $c_code .= " if ((tmpsv = hv_fetch((HV *)item, \"$e->{perl_name}\", sizeof(\"$e->{perl_name}\") - 1, 0)) || overwrite) {\n" ; - - if ($e -> {malloc}) { - my $type = $e->{rtype} ; - my $dest = "obj -> $e->{name}" ; - my $src = 'tmpobj' ; - my $expr = eval ('"' . $e -> {malloc} . '"') ; - print $@ if ($@) ; - $c_code .= " $type tmpobj = (" . $self -> convert_sv2 ($e->{rtype}, $e->{class}, '(tmpsv && *tmpsv?*tmpsv:&PL_sv_undef)') . ");\n" ; - $c_code .= " if (tmpobj)\n" ; - $c_code .= " $expr;\n" ; - $c_code .= " else\n" ; - $c_code .= " $dest = NULL ;\n" ; - } - else { - $c_code .= ' ' . "obj -> $e->{name} = " . $self -> convert_sv2 ($e->{rtype}, $e->{class}, '(tmpsv && *tmpsv?*tmpsv:&PL_sv_undef)') . " ;\n" ; - } - $c_code .= " }\n" ; - } - } - $c_code .= qq[ ; } - - else - croak ("initializer for ${class}::new is not a hash or object reference") ; - -} ; - - -] ; - - - push @{ $self->{XS}->{ $struct->{module} } }, { - code => $code, - class => $class, - name => 'new', - }; - - unshift @{ $self->{XS}->{ $struct->{module} } }, { - code => $c_code, - class => '', - name => 'new', - }; - -} - - -# ============================================================================ - -sub get_structure_destroy { - my ($self, $class, $struct) = @_ ; - - my $cclass = $self -> cname($class) ; - my $cnvprefix = $self -> my_cnv_prefix ; - my $code = qq[ - -void -DESTROY (obj) - $class obj -CODE: - ${cclass}_destroy (aTHX_ obj) ; - -] ; - - my $numfree = 0 ; - my $c_code = qq[ - -void ${cclass}_destroy (pTHX_ $cclass obj) { -]; - - foreach my $e (@{ $struct->{elts} }) { - if (($e -> {class} !~ /::/) || ($e -> {rtype} =~ /\*$/)) { - if ($e -> {free}) { - my $src = "obj -> $e->{name}" ; - my $type = $e->{rtype} ; - my $expr = eval ('"' . $e -> {free} . '"') ; - print $@ if ($@) ; - $c_code .= " if (obj -> $e->{name})\n" ; - $c_code .= ' ' . $expr . ";\n" ; - $numfree++ ; - } - } - } - $c_code .= "\n};\n\n" ; - - if ($numfree) { - push @{ $self->{XS}->{ $struct->{module} } }, { - code => $code, - class => $class, - name => 'destroy', - }; - - unshift @{ $self->{XS}->{ $struct->{module} } }, { - code => $c_code, - class => '', - name => 'destroy', - }; - } - -} - -# ============================================================================ - -sub get_structures { - my $self = shift; - my $typemap = $self->typemap; - my $has_callbacks = 0 ; - - for my $entry (@{ structure_table($self) }) { - print 'struct ', $entry->{type} || '???', "...\n" ; - - my $struct = $typemap->map_structure($entry); - print Data::Dumper -> Dump ([$entry, $struct], ['Table Entry', 'Mapfile Entry']) if ($verbose) ; - if (!$struct) - { - print "WARNING: Struture '$entry->{type}' not found in map file\n" ; - next ; - } - - my $class = $struct->{class}; - $has_callbacks = 0 ; - - for my $e (@{ $struct->{elts} }) { - my($name, $default, $type, $perl_name ) = - @{$e}{qw(name default type perl_name)}; - - print " $name...\n" ; - - if ($e -> {callback}) { - #print "callback < ", Dumper ($e) , "\n" ; - $self -> get_function ($e -> {func}) ; - $self -> get_callback_function ($e -> {func}, $struct, $e) ; - $has_callbacks++ ; - } - else { - (my $cast = $type) =~ s/:/_/g; - my $val = get_value($e); - - my $type_in = $type; - my $preinit = "/*nada*/"; - my $address = '' ; - my $rdonly = 0 ; - my $strncpy ; - if ($e->{class} eq 'PV' and $val ne 'val') { - $type_in =~ s/char/char_len/; - $preinit = "STRLEN val_len;"; - } elsif (($e->{class} =~ /::/) && ($e -> {rtype} !~ /\*\s*$/)) { - # an inlined struct is read only - $rdonly = 1 ; - $address = '&' ; - } elsif ($name =~ /^(.*?)\[(.*?)\]$/) { - $strncpy = $2 ; - $name = $1 ; - $perl_name =~ s/\[.*?\]$// ; - $type = 'char *' ; - $type_in = 'char *' ; - $cast = 'char *' ; - } - - my $attrs = $self->attrs($name); - - my $code = <$name; -EOF - if ($rdonly) { - $code .= < 1) { - croak (\"$name is read only\") ; - } -EOF - } - else { - $code .= "\n if (items > 1) {\n" ; - if ($e -> {malloc}) { - my $dest = "obj->$name" ; - my $src = $val ; - my $type = $cast ; - my $expr = eval ('"' . $e -> {malloc} . '"') ; - print $@ if ($@) ; - $code .= ' ' . $expr . ";\n" ; - } - elsif ($strncpy) { - $code .= " strncpy(obj->$name, ($cast) $val, ($strncpy) - 1) ;\n" ; - $code .= " obj->$name\[($strncpy)-1] = '\\0';\n" ; - } - else { - $code .= " obj->$name = ($cast) $val;\n" ; - } - $code .= " }\n" ; - } - - $code .= <{XS}->{ $struct->{module} } }, { - code => $code, - class => $class, - name => $name, - perl_name => $e -> {perl_name}, - comment => $e -> {comment}, - struct_member => $e, - }; - } - } - $self -> get_structure_new($class, $struct) if ($struct->{has_new}) ; - $self -> get_structure_destroy($class, $struct) if ($struct->{has_new}) ; - $self -> get_structure_callback_init ($class, $struct) if ($has_callbacks); - - } -} - -# ============================================================================ - -sub prepare { - my $self = shift; - $self->{DIR} = $self -> xs_target_dir; - $self->{XS_DIR} = $self -> xs_target_dir ; - - if (-e $self->{DIR}) { - rmtree([$self->{DIR}], 1, 1); - } - - mkpath [$self->{DIR}], 1, 0755; -} - -# ============================================================================ - -sub class_dirname { - my($self, $class) = @_; -# my($base, $sub) = split '::', $class; -# return "$self->{DIR}/$base" unless $sub; #Apache | APR -# return $sub if $sub eq $self->{DIR}; #WrapXS -# return "$base/$sub"; - - $class =~ s/::/\//g ; - return $class ; -} - -# ============================================================================ - -sub class_dir { - my($self, $class) = @_; - - my $dirname = $self->class_dirname($class); - #my $dir = ($dirname =~ m:/: and $dirname !~ m:^$self->{DIR}:) ? - # join('/', $self->{DIR}, $dirname) : $dirname; - my $dir = join('/', $self->{DIR}, $dirname) ; - - mkpath [$dir], 1, 0755 unless -d $dir; - - $dir; -} - -# ============================================================================ - -sub class_file { - my($self, $class, $file) = @_; - join '/', $self->class_dir($class), $file; -} - -# ============================================================================ - -sub cname { - my($self, $class) = @_; - confess ('ERROR: class is undefined in cname') if (!defined ($class)) ; - $class =~ s/::$// ; - $class =~ s/:/_/g; - $class; -} - - - -# ============================================================================ - -sub convert_2obj { - my($self, $class, $name) = @_; - - $self -> my_cnv_prefix . $self -> cname($class) . "_2obj($name)" ; -} - - -# ============================================================================ - -sub convert_sv2 { - my($self, $rtype, $class, $name) = @_; - - $class =~ s/^const\s+// ; - $class =~ s/char\s*\*/PV/ ; - $class =~ s/SV\s*\*/SV/ ; - - return "($rtype)" . $self -> my_cnv_prefix . 'sv2_' . $self -> cname($class) . "($name)" ; -} - - -# ============================================================================ - -sub open_class_file { - my($self, $class, $file) = @_; - - if ($file =~ /^\./) { - my $sub = (split '::', $class)[-1]; - $file = $sub . $file; - } - - my $name = $self->class_file($class, $file); - - open my $fh, '>', $name or die "open $name: $!"; - print "writing...$name\n"; - - return $fh; -} - - -# ============================================================================ -=pod - -=head2 makefilepl_text (o) - -Returns text for Makefile.PL - -=cut - -sub makefilepl_text { - my($self, $class, $deps,$typemap) = @_; - - my @parts = split (/::/, $class) ; - my $mmargspath = '../' x @parts ; - $mmargspath .= 'mmargs.pl' ; - - my $txt = qq{ -$self->{noedit_warning_hash} - -use ExtUtils::MakeMaker (); - -local \$MMARGS ; - -if (-f '$mmargspath') - { - do '$mmargspath' ; - die \$\@ if (\$\@) ; - } - -\$MMARGS ||= {} ; - - -ExtUtils::MakeMaker::WriteMakefile( - 'NAME' => '$class', - 'VERSION' => '0.01', - 'TYPEMAPS' => ['$typemap'], -} ; -$txt .= "'depend' => $deps,\n" if ($deps) ; -$txt .= qq{ - \%\$MMARGS, -); - -} ; - -} - -# ============================================================================ - -sub write_makefilepl { - my($self, $class) = @_; - - $self -> {makefilepls}{$class} = 1 ; - - my $fh = $self->open_class_file($class, 'Makefile.PL'); - - my $includes = $self->includes; - my @parts = split '::', $class ; - my $xs = @parts?$parts[-1] . '.c':'' ; - my $deps = {$xs => ""}; - - if (my $mod_h = $self->mod_h($class, 1)) { - my $abs = File::Spec -> rel2abs ($mod_h) ; - my $rel = File::Spec -> abs2rel ($abs, $self -> class_dir ($class)) ; - $deps->{$xs} .= " $rel"; - } - - local $Data::Dumper::Terse = 1; - $deps = Dumper $deps; - $deps = undef if (!$class) ; - - $class ||= 'WrapXS' ; - print $fh $self -> makefilepl_text ($class, $deps, ('../' x @parts) . 'typemap') ; - - close $fh; -} - -# ============================================================================ - -sub write_missing_makefilepls { - my($self, $class) = @_; - - my %classes = ('' => 1) ; - foreach (keys %{$self -> {makefilepls}}) - { - my @parts = split (/::/, $_) ; - my $i ; - for ($i = 0; $i < @parts; $i++) - { - $classes{join('::', @parts[0..$i])} = 1 ; - } - } - - foreach my $class (keys %classes) - { - next if ($self -> {makefilepls}{$class}) ; - - $self -> write_makefilepl ($class) ; - } -} - -# ============================================================================ - -sub mod_h { - my($self, $module, $complete) = @_; - - my $dirname = $self->class_dirname($module); - my $cname = $self->cname($module); - my $mod_h = "$dirname/$cname.h"; - - for ($self -> xs_include_dir, @{ $self->{glue_dirs} }) { - my $file = "$_/$mod_h"; - $mod_h = $file if $complete; - return $mod_h if -e $file; - } - - undef; -} - -# ============================================================================ - -sub mod_pm { - my($self, $module, $complete) = @_; - - my $dirname = $self->class_dirname($module); - my @parts = split '::', $module; - my $mod_pm = "$dirname/$parts[-1]_pm"; - - for ($self -> xs_incsrc_dir, @{ $self->{glue_dirs} }) { - my $file = "$_/$mod_pm"; - $mod_pm = $file if $complete; - print "mod_pm $mod_pm $file $complete\n" ; - return $mod_pm if -e $file; - } - - undef; -} - - -# ============================================================================ -=pod - -=head2 h_filename_prefix (o) - -Defines a prefix for generated header files - -Default: C<'xs_'> - -=cut - -sub h_filename_prefix { 'xs_' } - -# ============================================================================ -=pod - -=head2 my_xs_prefix (o) - -Defines a prefix used for all XS functions - -Default: C<'xs_'> - -=cut - -sub my_xs_prefix { 'xs_' } - -# ============================================================================ -=pod - -=head2 my_cnv_prefix (o) - -Defines a prefix used for all conversion functions/macros. - -Default: C - -=cut - -sub my_cnv_prefix { $_[0] -> my_xs_prefix } - -# ============================================================================ -=pod - -=head2 needs_prefix (o, name) - -Returns true if the passed name should be prefixed - -=cut - -sub needs_prefix { - return 0 if (!$_[1]) ; - my $pf = $_[0] -> my_xs_prefix ; - return $_[1] !~ /^$pf/i; -} - -# ============================================================================ - - -sub isa_str { - my($self, $module) = @_; - my $str = ""; - - if (my $isa = $self->typemap->{function_map}->{isa}->{$module}) { - while (my($sub, $base) = each %$isa) { -#XXX cannot set isa in the BOOT: section because XSLoader local-ises -#ISA during bootstrap -# $str .= qq{ av_push(get_av("$sub\::ISA", TRUE), -# newSVpv("$base",0));} - $str .= qq{\@$sub\::ISA = '$base';\n} - } - } - - $str; -} - -# ============================================================================ - -sub boot { - my($self, $module) = @_; - my $str = ""; - - if (my $boot = $self->typemap->{function_map}->{boot}->{$module}) { - $str = ' ' . $self -> my_xs_prefix . $self->cname($module) . "_BOOT(aTHXo);\n"; - } - - $str; -} - -# ============================================================================ - -my $notshared = join '|', qw(TIEHANDLE); #not sure why yet - -sub attrs { - my($self, $name) = @_; - my $str = ""; - return $str if $name =~ /$notshared$/o; - $str = " ATTRS: shared\n" if GvSHARED; - $str; -} - -# ============================================================================ - -sub write_xs { - my($self, $module, $functions) = @_; - - my $fh = $self->open_class_file($module, '.xs'); - print $fh "$self->{noedit_warning_c}\n"; - - my @includes = @{ $self->includes }; - - if (my $mod_h = $self->mod_h($module)) { - push @includes, $mod_h; - } - - for (@includes) { - print $fh qq{\#include "$_"\n\n}; - } - - my $last_prefix = ""; - my $fmap = $self -> typemap -> {function_map} ; - my $myprefix = $self -> my_xs_prefix ; - - for my $func (@$functions) { - my $class = $func->{class}; - if ($class) - { - my $prefix = $func->{prefix}; - $last_prefix = $prefix if $prefix; - - if ($func->{name} =~ /^$myprefix/o) { - #e.g. mpxs_Apache__RequestRec_ - my $class_prefix = $fmap -> class_c_prefix($class); - if ($func->{name} =~ /$class_prefix/) { - $prefix = $fmap -> class_xs_prefix($class); - } - } - - $prefix = $prefix ? " PREFIX = $prefix" : ""; - print $fh "MODULE = $module PACKAGE = $class $prefix\n\n"; - } - - print $fh $func->{code}; - } - - if (my $destructor = $self->typemap->destructor($last_prefix)) { - my $arg = $destructor->{argspec}[0]; - - print $fh <{name}($arg) - $destructor->{class} $arg - -EOF - } - - print $fh "PROTOTYPES: disabled\n\n"; - print $fh "BOOT:\n"; - print $fh $self->boot($module); - print $fh " items = items; /* -Wall */\n\n"; - - if (my $newxs = $self->{newXS}->{$module}) { - for my $xs (@$newxs) { - print $fh qq{ cv = newXS("$xs->[0]", $xs->[1], __FILE__);\n}; - print $fh qq{ GvSHARED_on(CvGV(cv));\n} if GvSHARED; - } - } - - close $fh; -} - -# ============================================================================ -=pod - -=head2 pm_text (o, module, isa, code) - -Returns the text of a C<.pm> file, or undef if no C<.pm> file should be -written. - -Default: Create a C<.pm> file which bootstraps the XS code - -=cut - -sub pm_text { - my($self, $module, $isa, $code) = @_; - - return <{noedit_warning_hash} - -package $module; -require DynaLoader ; -use strict ; -use vars qw{\$VERSION \@ISA} ; -$isa -push \@ISA, 'DynaLoader' ; -\$VERSION = '0.01'; -bootstrap $module \$VERSION ; - -$code - -1; -__END__ -EOF - -} - -# ============================================================================ - -sub write_pm { - my($self, $module) = @_; - - - my $isa = $self->isa_str($module); - - my $code = ""; - if (my $mod_pm = $self->mod_pm($module, 1)) { - open my $fh, '<', $mod_pm; - local $/; - $code = <$fh>; - close $fh; - } - - my $base = (split '::', $module)[0]; - my $loader = join '::', $base, 'XSLoader'; - - my $text = $self -> pm_text ($module, $isa, $code) ; - return if (!$text) ; - - my $fh = $self->open_class_file($module, '.pm'); - - print $fh $text ; - -} - -# ============================================================================ - - -sub write_typemap { - my $self = shift; - my $typemap = $self->typemap; - my $map = $typemap->get; - my %seen; - - my $fh = $self->open_class_file('', 'typemap'); - print $fh "$self->{noedit_warning_hash}\n"; - - while (my($type, $t) = each %$map) { - my $class = $t -> {class} ; - $class ||= $type; - next if $seen{$type}++ || $typemap->special($class); - - my $typemap = $t -> {typemapid} ; - if ($class =~ /::/) { - next if $seen{$class}++ ; - $class =~ s/::$// ; - print $fh "$class\t$typemap\n"; - } - else { - print $fh "$type\t$typemap\n"; - } - } - - my $cnvprefix = $self -> my_cnv_prefix ; - my $typemap_code = $typemap -> typemap_code ($cnvprefix); - - - foreach my $dir ('INPUT', 'OUTPUT') { - print $fh "\n$dir\n" ; - while (my($type, $code) = each %{$typemap_code}) { - print $fh "$type\n$code->{$dir}\n\n" if ($code->{$dir}) ; - } - } - - close $fh; -} - -# ============================================================================ - -sub write_typemap_h_file { - my($self, $method) = @_; - - $method = $method . '_code'; - my($h, $code) = $self->typemap->$method(); - my $file = join '/', $self->{XS_DIR}, $h; - - open my $fh, '>', $file or die "open $file: $!"; - print $fh "$self->{noedit_warning_c}\n"; - print $fh $code; - close $fh; -} - -# ============================================================================ - -sub _pod_gen_siglet { - - my $class = shift || '' ; - - return '\%' if $class eq 'HV'; - return '\@' if $class eq 'AV'; - return '$'; -} - -# ============================================================================ -# Determine if the name is that of a function or an object - -sub _pod_is_function { - - my $class = shift || ''; - -#print "_pod_is_function($class)\n"; - - my %func_class = ( - SV => 1, - IV => 1, - NV => 1, - PV => 1, - UV => 1, - PTR => 1, - ); - - exists $func_class{$class}; -} - -# ============================================================================ - -sub generate_pod { - - my $self = shift ; - my $fh = shift; - my $pdd = shift; - my $templ = $self -> new_podtemplate ; - - my $since = $templ -> since_default ; - print $fh $templ -> gen_pod_head ($pdd->{module}) ; - - my $detail = $pdd->{functions_detailed}; - - unless ( ref($detail) eq 'ARRAY') { - warn "No functions listed in pdd structure for $pdd->{module}"; - return; - } - - - foreach my $f (@$detail) { - - # Generate the function or method name - - my $method = $f->{perl_name}; - $method = $1 if ($f->{prefix} && ($method =~ /^$f->{prefix}(.*?)$/)) ; - $method = $1 if ($f->{class_xs_prefix} && ($method =~ /^(?:DEFINE_)?$f->{class_xs_prefix}(.*?)$/)) ; - - if (!$method) { - warn "Cannot determinate method name for '$f->{name}'" ; - next ; - } - my $comment = $f->{comment_parsed}; - my $commenttext = ($comment->{func_desc} || '') . "\n\n" . ($comment->{doxygen_remark} || '') ; - my $member = $f -> {struct_member}; - if ($member) - { - print $fh $templ -> gen_pod_struct_member ($f->{class}, '$obj', $f->{struct_member}->{class}, $f->{perl_name}, $commenttext, $since) ; - } - else - { - my $args = $f->{args}; - if ($args && @$args) - { - my @param_nm = map { $_ -> {name} } @$args ; # Parameter names - my $obj_nm; - my $obj_sym; - my $offset = 0; - - my $first_param = $f->{args}[0]; - unless (_pod_is_function($first_param->{class})) { - $obj_nm = $param_nm[0]; # Object Name - $obj_sym = &_pod_gen_siglet($first_param->{class}). $obj_nm; - $offset++; - } - - - my $retclass ; - my $retcomment = $comment -> {doxygen_return} || '' ; - - if ($f -> {return_type} && $f -> {return_type} ne 'void') { - my $rettype = $self -> typemap->get->{$f -> {return_type}} ; - $retclass = $rettype?$rettype->{class}:$f -> {return_type}; - } - - - - my @param; - my $i = 0 ; - for my $param_nm (@param_nm) { - my $arg = $args->[$i++]; - push @param, { class => $arg->{class}, name => &_pod_gen_siglet($arg->{class}) . $param_nm, - comment => ($comment->{doxygen_param_desc}{$param_nm} || '') } ; - } - - print $fh $templ -> gen_pod_func ($obj_sym, $obj_sym, $method, \@param, $retclass, $retcomment, $commenttext, $since) ; - } - } - } -} - - - -# ============================================================================ - -# pdd = PERL Data Dumper -sub write_docs { - my($self, $module, $functions) = @_; - - my $fh = $self->open_class_file($module, '.pdd'); - print $fh "$self->{noedit_warning_hash}\n"; - - # Includes - my @includes = @{ $self->includes }; - - if (my $mod_h = $self->mod_h($module)) { - push @includes, $mod_h; - } - - my $last_prefix = ""; - my $fmap = $self->typemap->{function_map} ; - my $myprefix = $self->my_xs_prefix ; - - # Finding doxygen- and other data inside the comments - - # This code only knows the syntax for @ingroup, @param, @remark, - # @return and @warning. At the moment all other doxygen commands - # are treated as multiple-occurance, no-parameter commands. - - # Note: Nor does @deffunc exist in the doxygen specification, - # neither does @remark (but @remarks), @tip and @see. So we treat - # @remark like @remarks, but we don't do any speacial treating for - # @deffunc. Ideas or suggestions anyone? - - # --Axel Beckert - - foreach my $details (@$functions) { - #print "Comment: ", $details->{name} || '?', ': ', $details->{comment} || '-', "\n" ; - #print "----> ", Dumper ($details) ;# if (!$details->{comment}) ; - - if (defined $details->{comment} and - my $comment = $details->{comment}) { - $details->{comment_parsed} = {}; - - # Source file - if ($comment =~ s/^\s*(\S*\.c)\s+\*\n//s) { - $details->{comment_parsed}{source_file} = $1; - } - - # Initialize several fields - $details->{comment_parsed}{func_desc} = ""; - my $doxygen = 0; # flag indicating that we already have - # seen doxygen fields in this comment - my $type = 0; # name of doxygen field - my $pre = 0; # if we should recognize leading - # spaces. Example see apr_table_overlap - # Setting some regexps - my $ordinary_line = qr/^\s*?\*(\s*(.*?))\s*$/; - my $pre_begin = qr(
)i;
-	    my $pre_end = qr(
)i; - - # Parse the rest of the comment line by line, because - # doxygen fields can appear more than once - foreach my $line (split /\n/, $comment) { - - # Yesss! This looks like doxygen data. - if ($line =~ /^\s*\*\s+[\\@](\w+)\s+(.*)\s*$/) { - $type = $doxygen = $1; - my $info = $2; - - # setting the recognizing of leading spaces - $pre = ($info =~ $pre_begin ? 1 : $pre); - $pre = ($info =~ $pre_end ? 0 : $pre); - - # Already had a doxygen element of this type for this func. - if (defined $details->{comment_parsed}{"doxygen_$type"}) { - push(@{ $details->{comment_parsed}{"doxygen_$type"} }, - $info); - } - # Hey, hadn't seen this doxygen type in this function yet! - else { - $details->{comment_parsed}{"doxygen_$type"} = [ $info ]; - } - } - # Further line belonging to doxygen field of the last line - elsif ($doxygen) { - # An empty line ends a doxygen paragraph - if ($line =~ /^\s*$/) { - $doxygen = 0; - next; - } - - # Those two situations should never appear. But we - # better double check those things. - croak("There already was a doxygen comment, but it didn't set an type.\nStrange things happen") - unless defined $details->{comment_parsed}{"doxygen_$type"}; - croak("This ($line) maybe an syntactic incorrect doxygen line.\nStrange things happen") - unless $line =~ $ordinary_line; - my $info = $2; - $info = $1 if $pre; - - # setting the recognizing of leading spaces - $pre = ($info =~ $pre_begin ? 1 : $pre); - $pre = ($info =~ $pre_end ? 0 : $pre); - $info =~ s(^\s+)()i; - - # Ok, get me the last line of documentation. - my $lastline = - pop @{ $details->{comment_parsed}{"doxygen_$type"} }; - - # Concatenate that line and the actual line with a newline - $info = "$lastline\n$info"; - - # Strip empty lines at the end and beginning - # unless there was a 
 before.
-		    unless ($pre) {
-			$info =~ s/[\n\s]+$//s;
-			$info =~ s/^[\n\s]+//s;
-		    }
-
-		    # Push the back into the array 
-		    push(@{ $details->{comment_parsed}{"doxygen_$type"} }, 
-			 $info);
-		}
-		# Booooh! Just an ordinary comment
-		elsif ($line =~ $ordinary_line) {
-		    my $info = $2;
-		    $info = $1 if $pre;
-
-		    # setting the recognizing of leading spaces
-		    $pre = ($info =~ $pre_begin ? 1 : $pre);
-		    $pre = ($info =~ $pre_end ? 0 : $pre);
-		    $info =~ s(^\s+(
))($1)i; - - # Only add if not an empty line at the beginning - $details->{comment_parsed}{func_desc} .= "$info\n" - unless ($info =~ /^\s*$/ and - $details->{comment_parsed}{func_desc} eq ""); - } else { - if (defined $details->{comment_parsed}{unidentified}) { - push(@{ $details->{comment_parsed}{unidentified} }, - $line); - } else { - $details->{comment_parsed}{unidentified} = [ $line ]; - } - } - } - - # Unnecessary linebreaks at the end of the function description - $details->{comment_parsed}{func_desc} =~ s/[\n\s]+$//s - if defined $details->{comment_parsed}{func_desc}; - - if (defined $details->{comment_parsed}{doxygen_param}) { - # Remove the description from the doxygen_param and - # move into an hash. A sole hash doesn't work, because - # it usually screws up the parameter order - - my %param; my @param; - foreach (@{ $details->{comment_parsed}{doxygen_param} }) { - my ($var, $desc) = split(" ",$_,2); - $param{$var} = $desc; - push(@param, $var); - } - $details->{comment_parsed}{doxygen_param} = [ @param ]; - $details->{comment_parsed}{doxygen_param_desc} = { %param }; - } - - if (defined $details->{comment_parsed}{doxygen_defgroup}) { - # Change doxygen_defgroup from array to hash - - my %defgroup; - foreach (@{ $details->{comment_parsed}{doxygen_defgroup} }) { - my ($var, $desc) = split(" ",$_,2); - $defgroup{$var} = $desc; - } - $details->{comment_parsed}{doxygen_defgroup} = { %defgroup }; - } - - if (defined $details->{comment_parsed}{doxygen_ingroup}) { - # There should be a list of all parameters - - my @ingroup = (); - foreach (@{ $details->{comment_parsed}{doxygen_ingroup} }) { - push(@ingroup, split()); - } - $details->{comment_parsed}{doxygen_ingroup} = [ @ingroup ]; - } - - foreach (qw(return warning remark)) { - if (defined $details->{comment_parsed}{"doxygen_$_"}) { - # Multiple adjacent @$_ should be concatenated, so - # we can make an scalar out of it. Although we - # actually still disregard the case, that there - # are several non-adjacent @$_s. - $details->{comment_parsed}{"doxygen_$_"} = - join("\n", - @{ $details->{comment_parsed}{"doxygen_$_"} }); - } - } - - # Dump the output for debugging purposes -# print STDERR "### $details->{perl_name}:\n". -# Dumper $details->{comment_parsed}; -# print STDERR "### Original Comment:\n". -# Dumper $details->{comment}; - - } - - # Some more per function information, used in the XS files - my $class = $details->{class}; - if ($class) { - my $prefix = $details->{prefix}; - $last_prefix = $prefix if $prefix; - - if ($details->{name} =~ /^$myprefix/o) { - #e.g. mpxs_Apache__RequestRec_ - my $class_prefix = $fmap -> class_c_prefix($class); - if ($details->{name} =~ /$class_prefix/) { - $details->{class_xs_prefix} = - $fmap->class_xs_prefix($class); - } - $details->{class_c_prefix} = $class_prefix; - } - } - } - - - # Some more information, used in the XS files - my $destructor = $self->typemap->destructor($last_prefix); - my $boot = $self->boot($module); - if ($boot) { - chomp($boot); - $boot =~ s/(\s+$|^\s+)//; - } - my $newxs = $self->{newXS}->{$module}; - - # Finally do the PDD Dump - my $pdd = { - module => $module, - functions => [ map $$_{perl_name}, @$functions ], - functions_detailed => [ @$functions ], - includes => [ @includes ], - my_xs_prefix => $myprefix, - destructor => $destructor, - boot => $boot, - newXS => $newxs - }; - - print $fh Dumper $pdd; - close $fh; - - $fh = $self->open_class_file($module, '.pod'); - $self -> generate_pod($fh, $pdd); - close $fh; -} - -# ============================================================================ - -sub generate { - my $self = shift; - - $self->prepare; - - # now done by write_missing_makefilepls - #for (qw(ModPerl::WrapXS Apache APR)) { - # $self->write_makefilepl($_); - #} - - $self->write_typemap; - - for (qw(typedefs sv_convert)) { - $self->write_typemap_h_file($_); - } - - $self->get_functions; - $self->get_structures; - - while (my($module, $functions) = each %{ $self->{XS} }) { -# my($root, $sub) = split '::', $module; -# if (-e "$self->{XS_DIR}/$root/$sub/$sub.xs") { -# $module = join '::', $root, "Wrap$sub"; -# } - if (!$module) - { - print "WARNING: empty module\n" ; - next ; - } - print "mod $module\n" ; - $self->write_makefilepl($module); - $self->write_xs($module, $functions); - $self->write_pm($module); - $self->write_docs($module, $functions); - } - - $self -> write_missing_makefilepls ; -} - -# ============================================================================ - -sub stats { - my $self = shift; - - $self->get_functions; - $self->get_structures; - - my %stats; - - while (my($module, $functions) = each %{ $self->{XS} }) { - $stats{$module} += @$functions; - if (my $newxs = $self->{newXS}->{$module}) { - $stats{$module} += @$newxs; - } - } - - return \%stats; -} - -# ============================================================================ -=pod - -=head2 mapline_elem (o, elem) - -Called for each structure element that is written to the map file by -checkmaps. Allows the user to change the element name, for example -adding a different perl name. - -Default: returns the element unmodified - -=cut - -sub mapline_elem { return $_[1] } ; - -# ============================================================================ -=pod - -=head2 mapline_func (o) - -Called for each function that is written to the map file by checkmaps. Allows -the user to change the function name, for example adding a different perl -name. - -Default: returns the element unmodified - -=cut - -sub mapline_func { return $_[1] } ; - -# ============================================================================ - -sub checkmaps { - my $self = shift; - my $prefix = shift; - - $self = $self -> new if (!ref $self) ; - - my $result = $self -> {typemap} -> checkmaps ; - $self -> {typemap} -> writemaps ($result, $prefix) if ($prefix) ; - - return $result ; -} - -# ============================================================================ - -sub run { - my $class = shift ; - - my $xs = $class -> new; - - $xs->generate; -} - - -1; -__END__ +package ExtUtils::XSBuilder::WrapXS; + +use strict; +use warnings FATAL => 'all'; + +use constant GvSHARED => 0; #$^V gt v5.7.0; + +use File::Spec ; +use ExtUtils::XSBuilder::TypeMap (); +use ExtUtils::XSBuilder::MapUtil qw(function_table structure_table callback_table); +use ExtUtils::XSBuilder::PODTemplate ; +use File::Path qw(rmtree mkpath); +use Cwd qw(fastcwd); +use Data::Dumper; + +use Carp qw(confess) ; + +our $VERSION = '0.03'; + +my %warnings; +my $verbose = 0 ; + +=pod + +=head1 NAME + +ExtUtils::XSBuilder::WrapXS - create perl XS wrappers for C functions + +=head2 DESCRIPTION + +For more information, see L + +=cut + +# ============================================================================ + +sub new { + my $class = shift; + + my $self = bless { + }, $class; + + $self -> {glue_dirs} = [$self -> xs_glue_dirs()] ; + $self -> {typemap} = $self -> new_typemap ; + $self -> {parsesource} = $self -> new_parsesource ; + $self -> {xs_includes} = $self -> xs_includes ; + $self -> {callbackno} = 1 ; + + for (qw(c hash)) { + my $w = "noedit_warning_$_"; + my $method = $w ; + $self->{$w} = $self->$method(); + } + + $self->typemap->get; + $self; +} + +# ============================================================================ + +sub classname { + my $self = shift || __PACKAGE__; + ref($self) || $self; +} + +# ============================================================================ + +sub calls_trace { + my $frame = 1; + my $trace = ''; + + while (1) { + my($package, $filename, $line) = caller($frame); + last unless $filename; + $trace .= "$frame. $filename:$line\n"; + $frame++; + } + + return $trace; +} + +# ============================================================================ + +sub noedit_warning_c { + my $class = classname(shift); + my $warning = \$warnings{C}->{$class}; + return $$warning if $$warning; + my $v = join '/', $class, $class->VERSION; + my $trace = calls_trace(); + $trace =~ s/^/ * /mg; + $$warning = <{$class}; + return $$warning if $$warning; + ($$warning = noedit_warning_c($class)) =~ s/^/\# /mg; + $$warning; +} + + +# ============================================================================ +=pod + +=head2 new_parsesource (o) + +Returns an array ref of new ParseSource objects for all source files that +should be used to generate XS files + +=cut + +sub new_parsesource { [ ExtUtils::XSBuilder::ParseSource->new ] } + + +# ============================================================================ +=pod + +=head2 new_typemap (o) + +Returns a new typemap object + +=cut + +sub new_typemap { ExtUtils::XSBuilder::TypeMap->new (shift) } + +# ============================================================================ +=pod + +=head2 new_podtemplate (o) + +Returns a new podtemplate object + +=cut + +sub new_podtemplate { ExtUtils::XSBuilder::PODTemplate->new } + +# ============================================================================ +=pod + +=head2 xs_includes (o) + +Returns a list of XS include files. + +Default: use all include files that C returns, but +strip path info + +=cut + +sub xs_includes + { + my $self = shift ; + my $parsesource = $self -> parsesource_objects ; + + my @includes ; + my @paths ; + foreach my $src (@$parsesource) { + push @includes, @{ $src -> find_includes } ; + push @paths, @{ $src -> include_paths } ; + } + + foreach (@paths) + { + s#(\\|/)$## ; + s#\\#/# ; + } + foreach (@includes) + { + s#\\#/# ; + } + + + # strip include paths + foreach my $file (@includes) + { + foreach my $path (@paths) + { + if ($file =~ /^\Q$path\E(\/|\\)(.*?)$/i) + { + $file = $2 ; + last ; + } + } + } + + + my %includes = map { $_ => 1 } @includes ; + my $fixup1 = $self -> h_filename_prefix . 'preperl.h' ; + my $fixup2 = $self -> h_filename_prefix . 'postperl.h' ; + + + + return [ + keys %includes, + -f $self -> xs_include_dir . '/'. $fixup1?$fixup1:(), + 'EXTERN.h', 'perl.h', 'XSUB.h', + -f $self -> xs_include_dir . '/'. $fixup2?$fixup2:(), + $self -> h_filename_prefix . 'sv_convert.h', + $self -> h_filename_prefix . 'typedefs.h', + ] ; + } + + + +# ============================================================================ +=pod + +=head2 xs_glue_dirs (o) + +Returns a list of additional XS glue directories to seach for maps in. + +=cut + + +sub xs_glue_dirs { + () ; +} + + +# ============================================================================ +=pod + +=head2 xs_base_dir (o) + +Returns a directory which serves as a base for other directories. + +Default: C<'.'> + +=cut + + +sub xs_base_dir { '.' } ; + + + +# ============================================================================ +=pod + +=head2 xs_map_dir (o) + +Returns the directory to search for map files in + +Default: C</xsbuilder/maps> + +=cut + + +sub xs_map_dir { File::Spec -> catdir ($_[0] -> xs_base_dir, 'xsbuilder', 'maps') } ; + +# ============================================================================ +=pod + +=head2 xs_incsrc_dir (o) + +Returns the directory to search for files to include into the source. For +example, C</Apache/DAV/Resource/Resource_pm> will be included into +the C module. + +Default: C</xsbuilder> + + +=cut + + +sub xs_incsrc_dir { File::Spec -> catdir ($_[0] -> xs_base_dir, 'xsbuilder') ; } ; + +# ============================================================================ +=pod + +=head2 xs_include_dir (o) + +Returns a directory to search for include files for pm and XS + +Default: C</xsinclude> + +=cut + + +sub xs_include_dir { File::Spec -> catdir ($_[0] -> xs_base_dir, 'xsinclude') ; } ; + +# ============================================================================ +=pod + +=head2 xs_target_dir (o) + +Returns the directory to write generated XS and header files in + +Default: C</xs> + +=cut + + +sub xs_target_dir { File::Spec -> catdir ($_[0] -> xs_base_dir, 'xs') ; } + + +# ============================================================================ + +sub typemap { shift->{typemap} } + +# ============================================================================ + +sub includes { shift->{xs_includes} || [] } + +# ============================================================================ + +sub parsesource_objects { shift->{parsesource} } + +# ============================================================================ + +sub function_list { + my $self = shift; + my(@list) = @{ function_table($self) }; + + while (my($name, $val) = each %{ $self->typemap->function_map }) { + #entries that do not exist in C::Scan generated tables + next unless $name =~ /^DEFINE_/; + push @list, $val; + } + + return \@list; +} + +# ============================================================================ + +sub callback_list { + my $self = shift; + my(@list) = @{ callback_table($self) }; + + while (my($name, $val) = each %{ $self->typemap->callback_map }) { + #entries that do not exist in C::Scan generated tables + next unless $name =~ /^DEFINE_/; + push @list, $val; + } + + return \@list; +} + +# ============================================================================ + +sub get_callback_function { + my ($self, $func, $struct, $elt) = @_ ; + + my $myprefix = $self -> my_xs_prefix ; + my $n ; + $elt -> {callbackno} = $n = $self -> {callbackno}++ ; + my $structelt = $elt -> {name} ; + my $class = $struct -> {class} ; + my $cclass = $self -> cname($class) ; + + my($name, $args, $retargs, $return_type, $orig_args, $userdataarg) = + @{ $func } { qw(perl_name args retargs return_type orig_args userdataarg) }; + + $struct -> {staticcnt} ||= 4 ; + my $staticcnt = $struct -> {staticcnt} ; + #print "get_callback_function: ", Data::Dumper -> Dump([$func]), "\n" ; + + my $code = "\n/* --- $class -> $structelt --- */\n\n" ; + my $cbname = "${myprefix}cb_${cclass}__$structelt" ; + my %retargs = map { $_->{name} => $_ } @$retargs ; + my %args = map { $_->{name} => $_ } @$args ; + my @args = map { my $name = /^(?:\*|&)(.*?)$/?$1:$_ ; ($args{$name}{rtype} || $retargs{$name}{rtype}) . (/^&/?" * $name":" $name") } @$orig_args ; + $return_type = $self -> cname($return_type) ; + my $return_class = $self -> typemap -> map_class ($return_type) || $return_type; + if ($return_class =~ / /) + { + print "ERROR: return class '$return_class' contains spaces" ; + } + + my $desttype = 'CV' ; + if ($structelt) + { + $desttype = 'SV' ; + } + + my $numret = $return_type eq 'void'?0:1 ; + $numret += @$retargs ; + my $callflags = $numret == 0?'G_VOID':$numret == 1?'G_SCALAR':'G_ARRAY' ; + + $code .= qq[ + +static $return_type $cbname (] . join (',', "$desttype * __cbdest", @args) . qq[) + { +] ; + $code .= " $return_type __retval ;\n" if ($return_type && $return_type ne 'void') ; + $code .= " SV * __retsv ;\n" if ($numret) ; + $code .= qq[ + int __cnt ; + + dSP ; + ENTER ; + SAVETMPS ; + PUSHMARK(SP) ; +]; + + if ($structelt) + { + $code .= " PUSHs(__cbdest) ;\n" ; + } + + foreach (@$orig_args) { + my $type = /^(?:\*|\&)(.*?)$/?$1:$_ ; + my $name = /^\*(.*?)$/?"&$1":$_ ; + next if ($retargs{$type}{class}) ; + if (!$args{$type}{class} && !$args{$type}{type}) + { + print "WARNING: unknown type for argument '$name' in struct member '$structelt'\n" ; + print Dumper ($args) ; + next ; + } + my $class = $args{$type}{class} || $args{$type}{type} ; + if ($class =~/\s/) + { + print "WARNING: type '$class' for argument '$name' in struct member '$structelt' contains spaces\n" ; + print Dumper ($args) ; + next ; + } + + $code .= ' PUSHs(' . $self -> convert_2obj ($class, $name) . ") ;\n" ; + } + + $code .= qq[ + PUTBACK ; +] ; + + if ($structelt) + { + $code .= " __cnt = perl_call_method(\"cb_$structelt\", $callflags) ;\n" ; + } + else + { + $code .= " __cnt = perl_call_sv(__cbdest, $callflags) ;\n" ; + } + + $code .= qq[ + + if (__cnt != $numret) + croak (\"$cbname expected $numret return values\") ; +] if ($numret > 0) ; + + $code .= qq[ + SPAGAIN ; +] ; + + if ($return_type && $return_type ne 'void') + { + $code .= " __retsv = POPs;\n" ; + $code .= ' __retval = ' . $self -> convert_sv2 ($return_type, $return_class, '__retsv') . ";\n" + } + foreach (@$retargs) { + $code .= " __retsv = POPs;\n" ; + $code .= " *$_->{name} = " . $self -> convert_sv2 ($_->{rtype}, $_->{class}, '__retsv') . ";\n" ; + } + + $code .= qq[ + PUTBACK ; + FREETMPS ; + LEAVE ; + + +] ; + $code .= " return __retval ;\n" if ($return_type && $return_type ne 'void') ; + $code .= qq[ + } + +] ; + + if (!$userdataarg) { + $staticcnt ||= 4 ; + + for (my $i = 0 ; $i < $staticcnt; $i++) { + $code .= qq[ + +static $return_type ${cbname}_obj$i (] . join (',', @args) . qq[) + { + ] . ($return_type eq 'void'?'':'return') . qq[ ${cbname} (] . + join (',', "${myprefix}${cclass}_obj[$i]", map { /^(?:\*|\&)?(.*?)$/ } @$orig_args) . qq[) ; + } + +] ; + + + } + $code .= "typedef $return_type (*t${cbname}_func)(" . join (',', @args) . qq") ;\n" ; + $code .= "static t${cbname}_func ${myprefix}${cbname}_func [$staticcnt] = {\n " . + join (",\n ", map { "${cbname}_obj$_" } (0..$staticcnt-1)) . "\n } ;\n\n\n" ; + } + + unshift @{ $self->{XS}->{ $func->{module} } }, { + code => $code, + class => '', + name => $name, + }; + +} + + + +# ============================================================================ + + + +sub get_function { + my ($self, $func) = @_ ; + + my $myprefix = $self -> my_xs_prefix ; + + my($name, $module, $class, $args, $retargs) = + @{ $func } { qw(perl_name module class args retargs) }; + + my %retargs = map { $_->{name} => $_ } @$retargs ; + + print "get_function: ", Data::Dumper -> Dump([$func]), "\n" if ($verbose); + #eg ap_fputs() + if ($name =~ s/^DEFINE_//) { + $func->{name} =~ s/^DEFINE_//; + + if (needs_prefix($func->{name})) { + #e.g. DEFINE_add_output_filter + $func->{name} = make_prefix($func->{name}, $class); + } + } + + my $xs_parms = join ', ', + map { defined $_->{default} ? + "$_->{name}=$_->{default}" : $_->{name} } @$args; + + my $parms ; + if ($func -> {dispatch_argspec}) + { + $parms = $func -> {dispatch_argspec} ; + } + else + { + ($parms = join (',', $xs_parms, + map { "\&$_->{name}" } @$retargs)) =~ + s/=[^,]+//g; #strip defaults + } + + my $proto = join "\n", + (map " $_->{type} $_->{name}", @$args) ; + + my $return_type = + $name =~ /^DESTROY$/ ? 'void' : $func->{return_type}; + + my $retdecl = @$retargs?(join "\n", + (map { my $type = $self -> cname($_->{class}) ; $type =~ s/\*$//; ' ' . $type . " $_->{name};"} @$retargs), + #' ' . $self -> cname($return_type) . ' RETVAL', + ''):''; + + my($dispatch, $orig_args) = + @{ $func } {qw(dispatch orig_args)}; + + if ($dispatch =~ /^$myprefix/io) { + $name =~ s/^$myprefix//; + $name =~ s/^$func->{prefix}//; + push @{ $self->{newXS}->{ $module } }, + ["$class\::$name", $dispatch]; + return; + } + + my $passthru = @$args && $args->[0]->{name} eq '...'; + if ($passthru) { + $parms = '...'; + $proto = ''; + } + + my $attrs = $self->attrs($name); + + my $code = < {dispatch_argspec}) { + $parms = join ', ', map { $retargs{$_}?"&$_":$_} @$orig_args; + } + } + else { + ### ??? gr ### if ($orig_args and @$orig_args == @$args) { + if ($orig_args && @$orig_args) { + #args were reordered + $parms = join ', ', map { $retargs{$_}?"&$_":$_} @$orig_args; + } + + $dispatch = $func->{name}; + } + + if ($passthru) { + $thx ||= 'aTHX_ '; + $parms = 'items, MARK+1, SP'; + } + + my $retval = $return_type eq 'void' ? + ["", ""] : ["RETVAL = ", "OUTPUT:\n RETVAL\n"]; + + my $retnum = $retdecl?scalar(@$retargs) + ($return_type eq 'void' ?0:1):0 ; + $code .= $retdecl?"PPCODE:":"CODE:" ; + $code .= "\n $retval->[0]$dispatch($thx$parms);\n" ; + if ($retdecl) { + my $retclass = $self -> typemap -> map_class ($return_type) || $return_type ; + if ($retclass =~ / /) + { + print "ERROR: return class '$retclass' contains spaces" ; + } + $code .= " XSprePUSH;\n" ; + $code .= " EXTEND(SP, $retnum) ;\n" ; + $code .= ' PUSHs(' . $self -> convert_2obj ($retclass, 'RETVAL') . ") ;\n" ; + foreach (@$retargs) { + if ($_->{class} =~ / /) + { + print "ERROR: $_->{class} contains spaces; retargs = ", Dumper ($_) ; + } + $code .= ' PUSHs(' . $self -> convert_2obj ($_->{class}, $_->{name}) . ") ;\n" ; + } + } + else { + $code .= "$retval->[1]\n" ; + } + } + + $code .= "\n" ; + + $func->{code} = $code; + push @{ $self->{XS}->{ $module } }, $func; +} + +# ============================================================================ + + +sub get_functions { + my $self = shift; + + my $typemap = $self->typemap; + my %seen ; + for my $entry (@{ $self->function_list() }) { + #print "get_func ", Dumper ($entry) ; + my $func = $typemap->map_function($entry); + #print "FAILED to map $entry->{name}\n" unless $func; + next unless $func; + print "WARNING: Duplicate function: $entry->{name}\n" if ($seen{$entry->{name}}++) ; + $self -> get_function ($func) ; + } +} + + +# ============================================================================ + +sub get_value { + my $e = shift; + my $val = 'val'; + + if ($e->{class} eq 'PV') { + if (my $pool = $e->{pool}) { + $pool .= '(obj)'; + $val = "((ST(1) == &PL_sv_undef) ? NULL : + apr_pstrndup($pool, val, val_len))" + } + } + + return $val; +} +# ============================================================================ + +sub get_structure_callback_init { + my ($self, $class, $struct) = @_ ; + + my $cclass = $self -> cname($class) ; + + my $myprefix = $self -> my_xs_prefix ; + my $staticcnt = $struct -> {staticcnt} ; + + my $cnv = $self -> convert_sv2 ($cclass, $class, 'obj') ; + my $code = qq[ + +void +init_callbacks (obj, val=NULL) + SV * obj + SV * val +PREINIT: + int n = -1 ; + int i ; + $cclass cobj = $cnv ; + SV * ref ; + SV * perl_obj ; +CODE: + if (items > 1) + obj = val ; + + perl_obj = SvRV(obj) ; + ref = newRV_noinc(perl_obj) ; + + for (i=0;i < $staticcnt;i++) + { + if ($myprefix${cclass}_obj[i] == ref) + { + n = i ; + break ; + } + } + + if (n < 0) + for (i=0;i < $staticcnt;i++) + { + if ($myprefix${cclass}_obj[i] == NULL) + { + n = i ; + break ; + } + } + + if (n < 0) + croak ("Limit for concurrent object callbacks reached for $class. Limit is $staticcnt") ; + + $myprefix${cclass}_obj[n] = ref ; +] ; + + + foreach my $e (@{ $struct->{elts} }) { + if ($e -> {callback}) { + my $cbname = "${myprefix}cb_${cclass}__$e->{name}" ; + $code .= " cobj -> $e->{name} = ${myprefix}${cbname}_func[n] ;\n" ; + } + } + $code .= qq[ + +] ; + + my $ccode = "static SV * ${myprefix}${cclass}_obj[$staticcnt] ;\n\n" ; + + + push @{ $self->{XS}->{ $struct->{module} } }, { + code => $code, + class => $class, + name => 'init_callbacks', + }; + + unshift @{ $self->{XS}->{ $struct->{module} } }, { + code => $ccode, + class => '', + name => 'init_callbacks', + }; + +} + +# ============================================================================ + +sub get_structure_new { + my ($self, $class, $struct) = @_ ; + + my $cclass = $self -> cname($class) ; + my $cnvprefix = $self -> my_cnv_prefix ; + my $alloc = $struct -> {alloc} || 'malloc(sizeof(*cobj))' ; + my $code = qq[ + +SV * +new (class,initializer=NULL) + char * class + SV * initializer +PREINIT: + SV * svobj ; + $cclass cobj ; + SV * tmpsv ; +CODE: + ${cnvprefix}${cclass}_create_obj(cobj,svobj,RETVAL,$alloc) ; + + if (initializer) { + if (!SvROK(initializer) || !(tmpsv = SvRV(initializer))) + croak ("initializer for ${class}::new is not a reference") ; + + if (SvTYPE(tmpsv) == SVt_PVHV || SvTYPE(tmpsv) == SVt_PVMG) + ${cclass}_new_init (aTHX_ cobj, tmpsv, 0) ; + else if (SvTYPE(tmpsv) == SVt_PVAV) { + int i ; + SvGROW(svobj, sizeof (*cobj) * av_len((AV *)tmpsv)) ; + for (i = 0; i <= av_len((AV *)tmpsv); i++) { + SV * * itemrv = av_fetch((AV *)tmpsv, i, 0) ; + SV * item ; + if (!itemrv || !*itemrv || !SvROK(*itemrv) || !(item = SvRV(*itemrv))) + croak ("array element of initializer for ${class}::new is not a reference") ; + ${cclass}_new_init (aTHX_ &cobj[i], item, 1) ; + } + } + else { + croak ("initializer for ${class}::new is not a hash/array/object reference") ; + } + } +OUTPUT: + RETVAL + +] ; + + + my $c_code = qq[ + +void ${cclass}_new_init (pTHX_ $cclass obj, SV * item, int overwrite) { + + SV * * tmpsv ; + + if (SvTYPE(item) == SVt_PVMG) + memcpy (obj, (void *)SvIVX(item), sizeof (*obj)) ; + else if (SvTYPE(item) == SVt_PVHV) { +] ; + foreach my $e (@{ $struct->{elts} }) { + if ($e -> {name} =~ /^(.*?)\[(.*?)\]$/) { + my $strncpy = $2 ; + my $name = $1 ; + my $perl_name ; + ($perl_name = $e -> {perl_name}) =~ s/\[.*?\]$// ; + $c_code .= " if ((tmpsv = hv_fetch((HV *)item, \"$perl_name\", sizeof(\"$perl_name\") - 1, 0)) || overwrite) {\n" ; + $c_code .= " STRLEN l = 0;\n" ; + $c_code .= " if (tmpsv) {\n" ; + $c_code .= " char * s = SvPV(*tmpsv,l) ;\n" ; + $c_code .= " if (l > ($strncpy)-1) l = ($strncpy) - 1 ;\n" ; + $c_code .= " strncpy(obj->$name, s, l) ;\n" ; + $c_code .= " }\n" ; + $c_code .= " obj->$name\[l] = '\\0';\n" ; + $c_code .= " }\n" ; + } elsif (($e -> {class} !~ /::/) || ($e -> {rtype} =~ /\*$/)) { + $c_code .= " if ((tmpsv = hv_fetch((HV *)item, \"$e->{perl_name}\", sizeof(\"$e->{perl_name}\") - 1, 0)) || overwrite) {\n" ; + + if ($e -> {malloc}) { + my $type = $e->{rtype} ; + my $dest = "obj -> $e->{name}" ; + my $src = 'tmpobj' ; + my $expr = eval ('"' . $e -> {malloc} . '"') ; + print $@ if ($@) ; + $c_code .= " $type tmpobj = (" . $self -> convert_sv2 ($e->{rtype}, $e->{class}, '(tmpsv && *tmpsv?*tmpsv:&PL_sv_undef)') . ");\n" ; + $c_code .= " if (tmpobj)\n" ; + $c_code .= " $expr;\n" ; + $c_code .= " else\n" ; + $c_code .= " $dest = NULL ;\n" ; + } + else { + $c_code .= ' ' . "obj -> $e->{name} = " . $self -> convert_sv2 ($e->{rtype}, $e->{class}, '(tmpsv && *tmpsv?*tmpsv:&PL_sv_undef)') . " ;\n" ; + } + $c_code .= " }\n" ; + } + } + $c_code .= qq[ ; } + + else + croak ("initializer for ${class}::new is not a hash or object reference") ; + +} ; + + +] ; + + + push @{ $self->{XS}->{ $struct->{module} } }, { + code => $code, + class => $class, + name => 'new', + }; + + unshift @{ $self->{XS}->{ $struct->{module} } }, { + code => $c_code, + class => '', + name => 'new', + }; + +} + + +# ============================================================================ + +sub get_structure_destroy { + my ($self, $class, $struct) = @_ ; + + my $cclass = $self -> cname($class) ; + my $cnvprefix = $self -> my_cnv_prefix ; + my $code = qq[ + +void +DESTROY (obj) + $class obj +CODE: + ${cclass}_destroy (aTHX_ obj) ; + +] ; + + my $numfree = 0 ; + my $c_code = qq[ + +void ${cclass}_destroy (pTHX_ $cclass obj) { +]; + + foreach my $e (@{ $struct->{elts} }) { + if (($e -> {class} !~ /::/) || ($e -> {rtype} =~ /\*$/)) { + if ($e -> {free}) { + my $src = "obj -> $e->{name}" ; + my $type = $e->{rtype} ; + my $expr = eval ('"' . $e -> {free} . '"') ; + print $@ if ($@) ; + $c_code .= " if (obj -> $e->{name})\n" ; + $c_code .= ' ' . $expr . ";\n" ; + $numfree++ ; + } + } + } + $c_code .= "\n};\n\n" ; + + if ($numfree) { + push @{ $self->{XS}->{ $struct->{module} } }, { + code => $code, + class => $class, + name => 'destroy', + }; + + unshift @{ $self->{XS}->{ $struct->{module} } }, { + code => $c_code, + class => '', + name => 'destroy', + }; + } + +} + +# ============================================================================ + +sub get_structures { + my $self = shift; + my $typemap = $self->typemap; + my $has_callbacks = 0 ; + + for my $entry (@{ structure_table($self) }) { + print 'struct ', $entry->{type} || '???', "...\n" ; + + my $struct = $typemap->map_structure($entry); + print Data::Dumper -> Dump ([$entry, $struct], ['Table Entry', 'Mapfile Entry']) if ($verbose) ; + if (!$struct) + { + print "WARNING: Struture '$entry->{type}' not found in map file\n" ; + next ; + } + + my $class = $struct->{class}; + $has_callbacks = 0 ; + + for my $e (@{ $struct->{elts} }) { + my($name, $default, $type, $perl_name ) = + @{$e}{qw(name default type perl_name)}; + + print " $name...\n" ; + + if ($e -> {callback}) { + #print "callback < ", Dumper ($e) , "\n" ; + $self -> get_function ($e -> {func}) ; + $self -> get_callback_function ($e -> {func}, $struct, $e) ; + $has_callbacks++ ; + } + else { + (my $cast = $type) =~ s/:/_/g; + my $val = get_value($e); + + my $type_in = $type; + my $preinit = "/*nada*/"; + my $address = '' ; + my $rdonly = 0 ; + my $strncpy ; + if ($e->{class} eq 'PV' and $val ne 'val') { + $type_in =~ s/char/char_len/; + $preinit = "STRLEN val_len;"; + } elsif (($e->{class} =~ /::/) && ($e -> {rtype} !~ /\*\s*$/)) { + # an inlined struct is read only + $rdonly = 1 ; + $address = '&' ; + } elsif ($name =~ /^(.*?)\[(.*?)\]$/) { + $strncpy = $2 ; + $name = $1 ; + $perl_name =~ s/\[.*?\]$// ; + $type = 'char *' ; + $type_in = 'char *' ; + $cast = 'char *' ; + } + + my $attrs = $self->attrs($name); + + my $code = <$name; +EOF + if ($rdonly) { + $code .= < 1) { + croak (\"$name is read only\") ; + } +EOF + } + else { + $code .= "\n if (items > 1) {\n" ; + if ($e -> {malloc}) { + my $dest = "obj->$name" ; + my $src = $val ; + my $type = $cast ; + my $expr = eval ('"' . $e -> {malloc} . '"') ; + print $@ if ($@) ; + $code .= ' ' . $expr . ";\n" ; + } + elsif ($strncpy) { + $code .= " strncpy(obj->$name, ($cast) $val, ($strncpy) - 1) ;\n" ; + $code .= " obj->$name\[($strncpy)-1] = '\\0';\n" ; + } + else { + $code .= " obj->$name = ($cast) $val;\n" ; + } + $code .= " }\n" ; + } + + $code .= <{XS}->{ $struct->{module} } }, { + code => $code, + class => $class, + name => $name, + perl_name => $e -> {perl_name}, + comment => $e -> {comment}, + struct_member => $e, + }; + } + } + $self -> get_structure_new($class, $struct) if ($struct->{has_new}) ; + $self -> get_structure_destroy($class, $struct) if ($struct->{has_new}) ; + $self -> get_structure_callback_init ($class, $struct) if ($has_callbacks); + + } +} + +# ============================================================================ + +sub prepare { + my $self = shift; + $self->{DIR} = $self -> xs_target_dir; + $self->{XS_DIR} = $self -> xs_target_dir ; + + if (-e $self->{DIR}) { + rmtree([$self->{DIR}], 1, 1); + } + + mkpath [$self->{DIR}], 1, 0755; +} + +# ============================================================================ + +sub class_dirname { + my($self, $class) = @_; +# my($base, $sub) = split '::', $class; +# return "$self->{DIR}/$base" unless $sub; #Apache | APR +# return $sub if $sub eq $self->{DIR}; #WrapXS +# return "$base/$sub"; + + $class =~ s/::/\//g ; + return $class ; +} + +# ============================================================================ + +sub class_dir { + my($self, $class) = @_; + + my $dirname = $self->class_dirname($class); + #my $dir = ($dirname =~ m:/: and $dirname !~ m:^$self->{DIR}:) ? + # join('/', $self->{DIR}, $dirname) : $dirname; + my $dir = join('/', $self->{DIR}, $dirname) ; + + mkpath [$dir], 1, 0755 unless -d $dir; + + $dir; +} + +# ============================================================================ + +sub class_file { + my($self, $class, $file) = @_; + join '/', $self->class_dir($class), $file; +} + +# ============================================================================ + +sub cname { + my($self, $class) = @_; + confess ('ERROR: class is undefined in cname') if (!defined ($class)) ; + $class =~ s/::$// ; + $class =~ s/:/_/g; + $class; +} + + + +# ============================================================================ + +sub convert_2obj { + my($self, $class, $name) = @_; + + $self -> my_cnv_prefix . $self -> cname($class) . "_2obj($name)" ; +} + + +# ============================================================================ + +sub convert_sv2 { + my($self, $rtype, $class, $name) = @_; + + $class =~ s/^const\s+// ; + $class =~ s/char\s*\*/PV/ ; + $class =~ s/SV\s*\*/SV/ ; + + return "($rtype)" . $self -> my_cnv_prefix . 'sv2_' . $self -> cname($class) . "($name)" ; +} + + +# ============================================================================ + +sub open_class_file { + my($self, $class, $file) = @_; + + if ($file =~ /^\./) { + my $sub = (split '::', $class)[-1]; + $file = $sub . $file; + } + + my $name = $self->class_file($class, $file); + + open my $fh, '>', $name or die "open $name: $!"; + print "writing...$name\n"; + + return $fh; +} + + +# ============================================================================ +=pod + +=head2 makefilepl_text (o) + +Returns text for Makefile.PL + +=cut + +sub makefilepl_text { + my($self, $class, $deps,$typemap) = @_; + + my @parts = split (/::/, $class) ; + my $mmargspath = '../' x @parts ; + $mmargspath .= 'mmargs.pl' ; + + my $txt = qq{ +$self->{noedit_warning_hash} + +use ExtUtils::MakeMaker (); + +local \$MMARGS ; + +if (-f '$mmargspath') + { + do '$mmargspath' ; + die \$\@ if (\$\@) ; + } + +\$MMARGS ||= {} ; + + +ExtUtils::MakeMaker::WriteMakefile( + 'NAME' => '$class', + 'VERSION' => '0.01', + 'TYPEMAPS' => ['$typemap'], +} ; +$txt .= "'depend' => $deps,\n" if ($deps) ; +$txt .= qq{ + \%\$MMARGS, +); + +} ; + +} + +# ============================================================================ + +sub write_makefilepl { + my($self, $class) = @_; + + $self -> {makefilepls}{$class} = 1 ; + + my $fh = $self->open_class_file($class, 'Makefile.PL'); + + my $includes = $self->includes; + my @parts = split '::', $class ; + my $xs = @parts?$parts[-1] . '.c':'' ; + my $deps = {$xs => ""}; + + if (my $mod_h = $self->mod_h($class, 1)) { + my $abs = File::Spec -> rel2abs ($mod_h) ; + my $rel = File::Spec -> abs2rel ($abs, $self -> class_dir ($class)) ; + $deps->{$xs} .= " $rel"; + } + + local $Data::Dumper::Terse = 1; + $deps = Dumper $deps; + $deps = undef if (!$class) ; + + $class ||= 'WrapXS' ; + print $fh $self -> makefilepl_text ($class, $deps, ('../' x @parts) . 'typemap') ; + + close $fh; +} + +# ============================================================================ + +sub write_missing_makefilepls { + my($self, $class) = @_; + + my %classes = ('' => 1) ; + foreach (keys %{$self -> {makefilepls}}) + { + my @parts = split (/::/, $_) ; + my $i ; + for ($i = 0; $i < @parts; $i++) + { + $classes{join('::', @parts[0..$i])} = 1 ; + } + } + + foreach my $class (keys %classes) + { + next if ($self -> {makefilepls}{$class}) ; + + $self -> write_makefilepl ($class) ; + } +} + +# ============================================================================ + +sub mod_h { + my($self, $module, $complete) = @_; + + my $dirname = $self->class_dirname($module); + my $cname = $self->cname($module); + my $mod_h = "$dirname/$cname.h"; + + for ($self -> xs_include_dir, @{ $self->{glue_dirs} }) { + my $file = "$_/$mod_h"; + $mod_h = $file if $complete; + return $mod_h if -e $file; + } + + undef; +} + +# ============================================================================ + +sub mod_pm { + my($self, $module, $complete) = @_; + + my $dirname = $self->class_dirname($module); + my @parts = split '::', $module; + my $mod_pm = "$dirname/$parts[-1]_pm"; + + for ($self -> xs_incsrc_dir, @{ $self->{glue_dirs} }) { + my $file = "$_/$mod_pm"; + $mod_pm = $file if $complete; + print "mod_pm $mod_pm $file $complete\n" ; + return $mod_pm if -e $file; + } + + undef; +} + + +# ============================================================================ +=pod + +=head2 h_filename_prefix (o) + +Defines a prefix for generated header files + +Default: C<'xs_'> + +=cut + +sub h_filename_prefix { 'xs_' } + +# ============================================================================ +=pod + +=head2 my_xs_prefix (o) + +Defines a prefix used for all XS functions + +Default: C<'xs_'> + +=cut + +sub my_xs_prefix { 'xs_' } + +# ============================================================================ +=pod + +=head2 my_cnv_prefix (o) + +Defines a prefix used for all conversion functions/macros. + +Default: C + +=cut + +sub my_cnv_prefix { $_[0] -> my_xs_prefix } + +# ============================================================================ +=pod + +=head2 needs_prefix (o, name) + +Returns true if the passed name should be prefixed + +=cut + +sub needs_prefix { + return 0 if (!$_[1]) ; + my $pf = $_[0] -> my_xs_prefix ; + return $_[1] !~ /^$pf/i; +} + +# ============================================================================ + + +sub isa_str { + my($self, $module) = @_; + my $str = ""; + + if (my $isa = $self->typemap->{function_map}->{isa}->{$module}) { + while (my($sub, $base) = each %$isa) { +#XXX cannot set isa in the BOOT: section because XSLoader local-ises +#ISA during bootstrap +# $str .= qq{ av_push(get_av("$sub\::ISA", TRUE), +# newSVpv("$base",0));} + $str .= qq{\@$sub\::ISA = '$base';\n} + } + } + + $str; +} + +# ============================================================================ + +sub boot { + my($self, $module) = @_; + my $str = ""; + + if (my $boot = $self->typemap->{function_map}->{boot}->{$module}) { + $str = ' ' . $self -> my_xs_prefix . $self->cname($module) . "_BOOT(aTHXo);\n"; + } + + $str; +} + +# ============================================================================ + +my $notshared = join '|', qw(TIEHANDLE); #not sure why yet + +sub attrs { + my($self, $name) = @_; + my $str = ""; + return $str if $name =~ /$notshared$/o; + $str = " ATTRS: shared\n" if GvSHARED; + $str; +} + +# ============================================================================ + +sub write_xs { + my($self, $module, $functions) = @_; + + my $fh = $self->open_class_file($module, '.xs'); + print $fh "$self->{noedit_warning_c}\n"; + + my @includes = @{ $self->includes }; + + if (my $mod_h = $self->mod_h($module)) { + push @includes, $mod_h; + } + + for (@includes) { + print $fh qq{\#include "$_"\n\n}; + } + + my $last_prefix = ""; + my $fmap = $self -> typemap -> {function_map} ; + my $myprefix = $self -> my_xs_prefix ; + + for my $func (@$functions) { + my $class = $func->{class}; + if ($class) + { + my $prefix = $func->{prefix}; + $last_prefix = $prefix if $prefix; + + if ($func->{name} =~ /^$myprefix/o) { + #e.g. mpxs_Apache__RequestRec_ + my $class_prefix = $fmap -> class_c_prefix($class); + if ($func->{name} =~ /$class_prefix/) { + $prefix = $fmap -> class_xs_prefix($class); + } + } + + $prefix = $prefix ? " PREFIX = $prefix" : ""; + print $fh "MODULE = $module PACKAGE = $class $prefix\n\n"; + } + + print $fh $func->{code}; + } + + if (my $destructor = $self->typemap->destructor($last_prefix)) { + my $arg = $destructor->{argspec}[0]; + + print $fh <{name}($arg) + $destructor->{class} $arg + +EOF + } + + print $fh "PROTOTYPES: disabled\n\n"; + print $fh "BOOT:\n"; + print $fh $self->boot($module); + print $fh " items = items; /* -Wall */\n\n"; + + if (my $newxs = $self->{newXS}->{$module}) { + for my $xs (@$newxs) { + print $fh qq{ cv = newXS("$xs->[0]", $xs->[1], __FILE__);\n}; + print $fh qq{ GvSHARED_on(CvGV(cv));\n} if GvSHARED; + } + } + + close $fh; +} + +# ============================================================================ +=pod + +=head2 pm_text (o, module, isa, code) + +Returns the text of a C<.pm> file, or undef if no C<.pm> file should be +written. + +Default: Create a C<.pm> file which bootstraps the XS code + +=cut + +sub pm_text { + my($self, $module, $isa, $code) = @_; + + return <{noedit_warning_hash} + +package $module; +require DynaLoader ; +use strict ; +use vars qw{\$VERSION \@ISA} ; +$isa +push \@ISA, 'DynaLoader' ; +\$VERSION = '0.01'; +bootstrap $module \$VERSION ; + +$code + +1; +__END__ +EOF + +} + +# ============================================================================ + +sub write_pm { + my($self, $module) = @_; + + + my $isa = $self->isa_str($module); + + my $code = ""; + if (my $mod_pm = $self->mod_pm($module, 1)) { + open my $fh, '<', $mod_pm; + local $/; + $code = <$fh>; + close $fh; + } + + my $base = (split '::', $module)[0]; + my $loader = join '::', $base, 'XSLoader'; + + my $text = $self -> pm_text ($module, $isa, $code) ; + return if (!$text) ; + + my $fh = $self->open_class_file($module, '.pm'); + + print $fh $text ; + +} + +# ============================================================================ + + +sub write_typemap { + my $self = shift; + my $typemap = $self->typemap; + my $map = $typemap->get; + my %seen; + + my $fh = $self->open_class_file('', 'typemap'); + print $fh "$self->{noedit_warning_hash}\n"; + + while (my($type, $t) = each %$map) { + my $class = $t -> {class} ; + $class ||= $type; + next if $seen{$type}++ || $typemap->special($class); + + my $typemap = $t -> {typemapid} ; + if ($class =~ /::/) { + next if $seen{$class}++ ; + $class =~ s/::$// ; + print $fh "$class\t$typemap\n"; + } + else { + print $fh "$type\t$typemap\n"; + } + } + + my $cnvprefix = $self -> my_cnv_prefix ; + my $typemap_code = $typemap -> typemap_code ($cnvprefix); + + + foreach my $dir ('INPUT', 'OUTPUT') { + print $fh "\n$dir\n" ; + while (my($type, $code) = each %{$typemap_code}) { + print $fh "$type\n$code->{$dir}\n\n" if ($code->{$dir}) ; + } + } + + close $fh; +} + +# ============================================================================ + +sub write_typemap_h_file { + my($self, $method) = @_; + + $method = $method . '_code'; + my($h, $code) = $self->typemap->$method(); + my $file = join '/', $self->{XS_DIR}, $h; + + open my $fh, '>', $file or die "open $file: $!"; + print $fh "$self->{noedit_warning_c}\n"; + print $fh $code; + close $fh; +} + +# ============================================================================ + +sub _pod_gen_siglet { + + my $class = shift || '' ; + + return '\%' if $class eq 'HV'; + return '\@' if $class eq 'AV'; + return '$'; +} + +# ============================================================================ +# Determine if the name is that of a function or an object + +sub _pod_is_function { + + my $class = shift || ''; + +#print "_pod_is_function($class)\n"; + + my %func_class = ( + SV => 1, + IV => 1, + NV => 1, + PV => 1, + UV => 1, + PTR => 1, + ); + + exists $func_class{$class}; +} + +# ============================================================================ + +sub generate_pod { + + my $self = shift ; + my $fh = shift; + my $pdd = shift; + my $templ = $self -> new_podtemplate ; + + my $since = $templ -> since_default ; + print $fh $templ -> gen_pod_head ($pdd->{module}) ; + + my $detail = $pdd->{functions_detailed}; + + unless ( ref($detail) eq 'ARRAY') { + warn "No functions listed in pdd structure for $pdd->{module}"; + return; + } + + + foreach my $f (@$detail) { + + # Generate the function or method name + + my $method = $f->{perl_name}; + $method = $1 if ($f->{prefix} && ($method =~ /^$f->{prefix}(.*?)$/)) ; + $method = $1 if ($f->{class_xs_prefix} && ($method =~ /^(?:DEFINE_)?$f->{class_xs_prefix}(.*?)$/)) ; + + if (!$method) { + warn "Cannot determinate method name for '$f->{name}'" ; + next ; + } + my $comment = $f->{comment_parsed}; + my $commenttext = ($comment->{func_desc} || '') . "\n\n" . ($comment->{doxygen_remark} || '') ; + my $member = $f -> {struct_member}; + if ($member) + { + print $fh $templ -> gen_pod_struct_member ($f->{class}, '$obj', $f->{struct_member}->{class}, $f->{perl_name}, $commenttext, $since) ; + } + else + { + my $args = $f->{args}; + if ($args && @$args) + { + my @param_nm = map { $_ -> {name} } @$args ; # Parameter names + my $obj_nm; + my $obj_sym; + my $offset = 0; + + my $first_param = $f->{args}[0]; + unless (_pod_is_function($first_param->{class})) { + $obj_nm = $param_nm[0]; # Object Name + $obj_sym = &_pod_gen_siglet($first_param->{class}). $obj_nm; + $offset++; + } + + + my $retclass ; + my $retcomment = $comment -> {doxygen_return} || '' ; + + if ($f -> {return_type} && $f -> {return_type} ne 'void') { + my $rettype = $self -> typemap->get->{$f -> {return_type}} ; + $retclass = $rettype?$rettype->{class}:$f -> {return_type}; + } + + + + my @param; + my $i = 0 ; + for my $param_nm (@param_nm) { + my $arg = $args->[$i++]; + push @param, { class => $arg->{class}, name => &_pod_gen_siglet($arg->{class}) . $param_nm, + comment => ($comment->{doxygen_param_desc}{$param_nm} || '') } ; + } + + print $fh $templ -> gen_pod_func ($obj_sym, $obj_sym, $method, \@param, $retclass, $retcomment, $commenttext, $since) ; + } + } + } +} + + + +# ============================================================================ + +# pdd = PERL Data Dumper +sub write_docs { + my($self, $module, $functions) = @_; + + my $fh = $self->open_class_file($module, '.pdd'); + print $fh "$self->{noedit_warning_hash}\n"; + + # Includes + my @includes = @{ $self->includes }; + + if (my $mod_h = $self->mod_h($module)) { + push @includes, $mod_h; + } + + my $last_prefix = ""; + my $fmap = $self->typemap->{function_map} ; + my $myprefix = $self->my_xs_prefix ; + + # Finding doxygen- and other data inside the comments + + # This code only knows the syntax for @ingroup, @param, @remark, + # @return and @warning. At the moment all other doxygen commands + # are treated as multiple-occurance, no-parameter commands. + + # Note: Nor does @deffunc exist in the doxygen specification, + # neither does @remark (but @remarks), @tip and @see. So we treat + # @remark like @remarks, but we don't do any speacial treating for + # @deffunc. Ideas or suggestions anyone? + + # --Axel Beckert + + foreach my $details (@$functions) { + #print "Comment: ", $details->{name} || '?', ': ', $details->{comment} || '-', "\n" ; + #print "----> ", Dumper ($details) ;# if (!$details->{comment}) ; + + if (defined $details->{comment} and + my $comment = $details->{comment}) { + $details->{comment_parsed} = {}; + + # Source file + if ($comment =~ s/^\s*(\S*\.c)\s+\*\n//s) { + $details->{comment_parsed}{source_file} = $1; + } + + # Initialize several fields + $details->{comment_parsed}{func_desc} = ""; + my $doxygen = 0; # flag indicating that we already have + # seen doxygen fields in this comment + my $type = 0; # name of doxygen field + my $pre = 0; # if we should recognize leading + # spaces. Example see apr_table_overlap + # Setting some regexps + my $ordinary_line = qr/^\s*?\*(\s*(.*?))\s*$/; + my $pre_begin = qr(
)i;
+	    my $pre_end = qr(
)i; + + # Parse the rest of the comment line by line, because + # doxygen fields can appear more than once + foreach my $line (split /\n/, $comment) { + + # Yesss! This looks like doxygen data. + if ($line =~ /^\s*\*\s+[\\@](\w+)\s+(.*)\s*$/) { + $type = $doxygen = $1; + my $info = $2; + + # setting the recognizing of leading spaces + $pre = ($info =~ $pre_begin ? 1 : $pre); + $pre = ($info =~ $pre_end ? 0 : $pre); + + # Already had a doxygen element of this type for this func. + if (defined $details->{comment_parsed}{"doxygen_$type"}) { + push(@{ $details->{comment_parsed}{"doxygen_$type"} }, + $info); + } + # Hey, hadn't seen this doxygen type in this function yet! + else { + $details->{comment_parsed}{"doxygen_$type"} = [ $info ]; + } + } + # Further line belonging to doxygen field of the last line + elsif ($doxygen) { + # An empty line ends a doxygen paragraph + if ($line =~ /^\s*$/) { + $doxygen = 0; + next; + } + + # Those two situations should never appear. But we + # better double check those things. + croak("There already was a doxygen comment, but it didn't set an type.\nStrange things happen") + unless defined $details->{comment_parsed}{"doxygen_$type"}; + croak("This ($line) maybe an syntactic incorrect doxygen line.\nStrange things happen") + unless $line =~ $ordinary_line; + my $info = $2; + $info = $1 if $pre; + + # setting the recognizing of leading spaces + $pre = ($info =~ $pre_begin ? 1 : $pre); + $pre = ($info =~ $pre_end ? 0 : $pre); + $info =~ s(^\s+)()i; + + # Ok, get me the last line of documentation. + my $lastline = + pop @{ $details->{comment_parsed}{"doxygen_$type"} }; + + # Concatenate that line and the actual line with a newline + $info = "$lastline\n$info"; + + # Strip empty lines at the end and beginning + # unless there was a 
 before.
+		    unless ($pre) {
+			$info =~ s/[\n\s]+$//s;
+			$info =~ s/^[\n\s]+//s;
+		    }
+
+		    # Push the back into the array 
+		    push(@{ $details->{comment_parsed}{"doxygen_$type"} }, 
+			 $info);
+		}
+		# Booooh! Just an ordinary comment
+		elsif ($line =~ $ordinary_line) {
+		    my $info = $2;
+		    $info = $1 if $pre;
+
+		    # setting the recognizing of leading spaces
+		    $pre = ($info =~ $pre_begin ? 1 : $pre);
+		    $pre = ($info =~ $pre_end ? 0 : $pre);
+		    $info =~ s(^\s+(
))($1)i; + + # Only add if not an empty line at the beginning + $details->{comment_parsed}{func_desc} .= "$info\n" + unless ($info =~ /^\s*$/ and + $details->{comment_parsed}{func_desc} eq ""); + } else { + if (defined $details->{comment_parsed}{unidentified}) { + push(@{ $details->{comment_parsed}{unidentified} }, + $line); + } else { + $details->{comment_parsed}{unidentified} = [ $line ]; + } + } + } + + # Unnecessary linebreaks at the end of the function description + $details->{comment_parsed}{func_desc} =~ s/[\n\s]+$//s + if defined $details->{comment_parsed}{func_desc}; + + if (defined $details->{comment_parsed}{doxygen_param}) { + # Remove the description from the doxygen_param and + # move into an hash. A sole hash doesn't work, because + # it usually screws up the parameter order + + my %param; my @param; + foreach (@{ $details->{comment_parsed}{doxygen_param} }) { + my ($var, $desc) = split(" ",$_,2); + $param{$var} = $desc; + push(@param, $var); + } + $details->{comment_parsed}{doxygen_param} = [ @param ]; + $details->{comment_parsed}{doxygen_param_desc} = { %param }; + } + + if (defined $details->{comment_parsed}{doxygen_defgroup}) { + # Change doxygen_defgroup from array to hash + + my %defgroup; + foreach (@{ $details->{comment_parsed}{doxygen_defgroup} }) { + my ($var, $desc) = split(" ",$_,2); + $defgroup{$var} = $desc; + } + $details->{comment_parsed}{doxygen_defgroup} = { %defgroup }; + } + + if (defined $details->{comment_parsed}{doxygen_ingroup}) { + # There should be a list of all parameters + + my @ingroup = (); + foreach (@{ $details->{comment_parsed}{doxygen_ingroup} }) { + push(@ingroup, split()); + } + $details->{comment_parsed}{doxygen_ingroup} = [ @ingroup ]; + } + + foreach (qw(return warning remark)) { + if (defined $details->{comment_parsed}{"doxygen_$_"}) { + # Multiple adjacent @$_ should be concatenated, so + # we can make an scalar out of it. Although we + # actually still disregard the case, that there + # are several non-adjacent @$_s. + $details->{comment_parsed}{"doxygen_$_"} = + join("\n", + @{ $details->{comment_parsed}{"doxygen_$_"} }); + } + } + + # Dump the output for debugging purposes +# print STDERR "### $details->{perl_name}:\n". +# Dumper $details->{comment_parsed}; +# print STDERR "### Original Comment:\n". +# Dumper $details->{comment}; + + } + + # Some more per function information, used in the XS files + my $class = $details->{class}; + if ($class) { + my $prefix = $details->{prefix}; + $last_prefix = $prefix if $prefix; + + if ($details->{name} =~ /^$myprefix/o) { + #e.g. mpxs_Apache__RequestRec_ + my $class_prefix = $fmap -> class_c_prefix($class); + if ($details->{name} =~ /$class_prefix/) { + $details->{class_xs_prefix} = + $fmap->class_xs_prefix($class); + } + $details->{class_c_prefix} = $class_prefix; + } + } + } + + + # Some more information, used in the XS files + my $destructor = $self->typemap->destructor($last_prefix); + my $boot = $self->boot($module); + if ($boot) { + chomp($boot); + $boot =~ s/(\s+$|^\s+)//; + } + my $newxs = $self->{newXS}->{$module}; + + # Finally do the PDD Dump + my $pdd = { + module => $module, + functions => [ map $$_{perl_name}, @$functions ], + functions_detailed => [ @$functions ], + includes => [ @includes ], + my_xs_prefix => $myprefix, + destructor => $destructor, + boot => $boot, + newXS => $newxs + }; + + print $fh Dumper $pdd; + close $fh; + + $fh = $self->open_class_file($module, '.pod'); + $self -> generate_pod($fh, $pdd); + close $fh; +} + +# ============================================================================ + +sub generate { + my $self = shift; + + $self->prepare; + + # now done by write_missing_makefilepls + #for (qw(ModPerl::WrapXS Apache APR)) { + # $self->write_makefilepl($_); + #} + + $self->write_typemap; + + for (qw(typedefs sv_convert)) { + $self->write_typemap_h_file($_); + } + + $self->get_functions; + $self->get_structures; + + while (my($module, $functions) = each %{ $self->{XS} }) { +# my($root, $sub) = split '::', $module; +# if (-e "$self->{XS_DIR}/$root/$sub/$sub.xs") { +# $module = join '::', $root, "Wrap$sub"; +# } + if (!$module) + { + print "WARNING: empty module\n" ; + next ; + } + print "mod $module\n" ; + $self->write_makefilepl($module); + $self->write_xs($module, $functions); + $self->write_pm($module); + $self->write_docs($module, $functions); + } + + $self -> write_missing_makefilepls ; +} + +# ============================================================================ + +sub stats { + my $self = shift; + + $self->get_functions; + $self->get_structures; + + my %stats; + + while (my($module, $functions) = each %{ $self->{XS} }) { + $stats{$module} += @$functions; + if (my $newxs = $self->{newXS}->{$module}) { + $stats{$module} += @$newxs; + } + } + + return \%stats; +} + +# ============================================================================ +=pod + +=head2 mapline_elem (o, elem) + +Called for each structure element that is written to the map file by +checkmaps. Allows the user to change the element name, for example +adding a different perl name. + +Default: returns the element unmodified + +=cut + +sub mapline_elem { return $_[1] } ; + +# ============================================================================ +=pod + +=head2 mapline_func (o) + +Called for each function that is written to the map file by checkmaps. Allows +the user to change the function name, for example adding a different perl +name. + +Default: returns the element unmodified + +=cut + +sub mapline_func { return $_[1] } ; + +# ============================================================================ + +sub checkmaps { + my $self = shift; + my $prefix = shift; + + $self = $self -> new if (!ref $self) ; + + my $result = $self -> {typemap} -> checkmaps ; + $self -> {typemap} -> writemaps ($result, $prefix) if ($prefix) ; + + return $result ; +} + +# ============================================================================ + +sub run { + my $class = shift ; + + my $xs = $class -> new; + + $xs->generate; +} + + +1; +__END__