ExtUtils-XSBuilder-0.28/0000755000000000000000000000000010415747655013577 5ustar rootrootExtUtils-XSBuilder-0.28/XSBuilder.pm0000644000000000000000000000013710415747640015771 0ustar rootroot package ExtUtils::XSBuilder ; use strict ; use vars qw{$VERSION} ; $VERSION = '0.28' ; 1; ExtUtils-XSBuilder-0.28/README0000755000000000000000000000301010033172752014436 0ustar rootroot ExtUtils::XSBuilder - Automatic XS glue code generation ------------------------------------------------------- Copyright (c) 2000-2001 Doug MacEachern Copyright (c) 2001-2004 Gerald Richter / ecos gmbh (www.ecos.de) You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. 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. $Id: README,v 1.4 2004/03/29 03:49:31 richter Exp $ OVERVIEW ======== ExtUtils::XSBuilder is a set modules to parse C header files and create XS glue code and documentation out of it. Idealy this allows to "write" an interface to a C library without coding a line. Since no C-API is ideal, some adjuments are necessary most of the time. So to use this module you must still be familar with C and XS programming, but it removes a lot of stupid work and copy&paste from you. Also when the C API changes, most of the time you only have to rerun XSBuilder to get your new Perl API. INSTALLATION ============ perl Makefile.PL make install DOCUMENTATION ============= XSBuilder.pod contains the documentation xsbuilder.osc2002.pod contains my slides from the O'Reilly OpenSource Convention 2002 AUTHOR ====== Doug MacEachern has written most of the code for mod_perl 2.0. G. Richter has genarlized the code to make it useable outside mod_perl. ExtUtils-XSBuilder-0.28/XSBuilder.pod0000755000000000000000000003565010304764606016150 0ustar rootroot =head1 NAME ExtUtils::XSBuilder - Automatic Perl XS glue code generation =head1 DESCRIPTION ExtUtils::XSBuilder is a set modules to parse C header files and create XS glue code and documentation out of it. Idealy this allows to "write" an interface to a C library without coding a line. Since no C API is ideal, some adjuments are necessary most of the time. So to use this module you must still be familiar with C and XS programming, but it removes a lot of stupid work and copy & paste from you. Also when the C API changes, most of the time you only have to rerun XSBuilder to get your new Perl API. The creation process takes place in the following steps: =head2 Derive a class from ExtUtils::XSBuilder::ParseSource This class must override some methods to tell XSBuilder which C header files to parse and some other necessary parameters. You need at least to override the C method to give the name of the package you want to create and either the C method which returns all C header files to parse, or the C method to return a list of all directories which should be scanned for C header files. Of course there are more methods you can overide. See L for a full list of overrideable methods. =head2 Scan the source files If your derived class is called MyClass::ParseSource you simply start the source scan with perl -MMyClass::ParseSource -e 'MyClass::ParseSource->run' You may also put this into a small script to ease usage, set the Perl libpath, etc. During the source scan, XSBuilder creates a set of tables which contain the results of parsing. If you haven't changed the default locations in your subclass, these tables are created under C, followed by the name of the module returned by the C method you created. There you will find four generated modules: C, which holds the function declarations; C, which holds the structures; C, which contains constants found in the header files; and C, which contains definitions for callback types. Since source scanning may take some time, we create intermediate tables and transform them into XS code later, rather than creating XS code directly. Since we save the result, we can avoid rescanning the source files as long as they don't change. =head2 Derive a class from ExtUtils::XSBuilder::WrapXS The WrapXS class is responsible for taking the information generated both from the source files and from the map files (see below) to create the XS code. As with the ParseSource class, you must override this method with your own implementaion, to tell WrapXS what to do. See L for a list of overrideable methods. =head2 Create map files XSBuilder will not automaticly 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, C, C, and C. Each map file is named with a user selectable prefix (e.g. C,) followed by an underscore, the map type name, and the map extension C<.map>. For example, hints for functions relating to error processing in your source may be contained in a map file named C. =over 4 =item foo_types.map Contains the mapping from C types to Perl classes. =item foo_functions.map Contains the mapping from C functions to Perl functions. Can be used to reorder arguments, tell XSBuilder which arguments are actualy return values and in which Perl package the function will be created. =item foo_structures.map Contains the mapping from C structures to Perl classes and defines for which classes the access methods should be created. You can also specify if you want a C method for the class. =item foo_callbacks.map Contains the mapping form C callback functions to Perl callback functions. Can be used to reorder arguments, tell XSBuilder which arguments are return values, and in which Perl package the functions will be created. =back For a detailed description of the map file formats see below. To have a starting point, XSBuilder is able to create default map files which simply include all types, functions and structures. You can recreate the map files anytime and XSBuilder will append all items which are not already in the map files. First copy the _types.map file from the xsbuilder directory to your maps directory. This file contains the standard mapping for some basic types. If, for example, your derived class is called MyClass::WrapXS, you simply start the creation/update of the map files with perl -MMyClass::WrapXS -e 'MyClass::WrapXS->checkmaps(" ")' The argument to checkmaps supplies a character to be prepended to the first column of the new map entries. If you do not pass an argument to checkmaps, no map files are written, and checkmaps will only compare what is missing. (You need to print the result somehow e.g. by using Data::Dumper). You may also put this into a small script to ease usage, set the Perl libpath, etc. After you have created your default maps, you must edit the C file, which contains all types that were found in the source. Append a pipe (C<|>) followed by the class or type name, e.g. int | IV struct request_rec | Apache::RequestRec . =head2 Create the XS files Now we can create the code. By running perl -MMyClass::WrapXS -e 'MyClass::WrapXS->run' XSBuilder will create the XS, pm and Makefile.PL files for every module that is mentioned in the maps. The result is placed as a directory hierarchy under WrapXS. To control the content of the C and the C file, you can override the C and C methods. You can include additional code in the XS files by writing an include file which is included at the top of the XS file. This file can contain helper functions that can't be automatically generated. The files must be placed under the C directory, with the correct path and name. For example, to have a header file included for the module Apache::DAV, create a file named C. The same can be done for inclusion in the pm file. Following the example above, the file name would be C. =head1 Format of the map files For all map files blank lines are ignored and lines starting with a C<#> are treated as comments and are also ignored. =head2 Types map file Contains the mapping from C type to Perl classes. Format is the name of the C type followed by the name of the Perl class or the XS type specifier, separated by a C<|>. Example: int | IV struct request_rec | Apache::RequestRec If you have a Perl class with a single-level namespace (e.g. Apache) you need to postfix it with two colons (e.g. "Apache::"). When both a typedef and a structure share the same name, structures must be written as with a "struct " prefix (e.g. "struct foo".) Addionally, you can give the id for the typemap if you need a special conversion and one or more other names for the struct: struct request_rec | Apache::RequestRec | T_APACHEOBJ | r An optional fifth parameter specifies that the data needs to be copied when assigned to a struct member and selects the way how memory is allocated: char * | PV | | | strdup The actual code for memory allocation is provided inside the structure map, for example: MALLOC=strdup:$dest = ($type)ap_pstrdup(obj -> pool, $src) MALLOC=malloc:ap_palloc(obj -> pool, $src, sizeof($type)) ; memcpy($dest,$src,sizeof($type)) This gives two ways to allocate memory and copy the data into it. The fifth parameter in the type map selects which of these two should be used. $src, $dest and $type are replaced by the source, the destination and the type. C is a pointer to the C-structure. =head3 Special Types =over =item String, PV and PVnull A string is represented in C as a pointer to an null terminated range of characters. In Perl the it is called C (pointer value). When converting a Perl C to a C string Perl by default converts it to an empty string. While this is save, this is not always what is required, because many C interfaces treat NULL as a special case. For this reason the C type is introduced, which converts C to C and C to C. To make it work you need the following line in your type map file: PVnull | PVnull | | | strdup Now you can defines any type, structure memeber or function argument as type C. =back =head2 Functions map file Contains the mapping from C functions to Perl functions. This can be used to reorder arguments, tell XSBuilder which arguments are return values, and in which Perl package the function will be created. There are some directives which affect the function mappings that follow it. Each directive may appear in the file more than once. =over 4 =item MODULE the module name (file name) where the function should be defined, e.g. MODULE=Apache::Connection will define the functions that follow in files named Apache/Connection.{pm,xs} =item PACKAGE The name of the package that functions are defined in. If undefined, PACKAGE defaults to the value of MODULE. A value of 'guess' indicates that package name should be guessed based on first argument found that maps to a Perl class. Falls back on the prefix (ap_ -> Apache, apr_ -> APR). =item PREFIX The prefix to be stripped from C functions when creating the XS stubs. Defaults to the value of PACKAGE, converted to C naming convention. For example, PREFIX=APR::Base64 will strip C from the C functions. If the prefix does not match, it defaults to C or C. =back B You must have at least one C definition otherwise all functions will be ignored. The format of entries is: C function name | dispatch function name (dispatch argspec) | argspec | Perl alias The C (the C function that is actually called) defaults to C function name. If the dispatch function name is just a prefix (mpxs_, MPXS_), the C is appended to it. The return type may be specified before the C, and defaults to the C in the C<{foo}::FunctionTable> module generated by the C module. The C is optional. If supplied, it can be used to pass different parameters to the dispatch function then to the XS function. If the function name begins with C, a new function is defined (for defining functions that are not parsed from the source). C must be supplied. C is not included in the generated function name. The C defaults to arguments in C<{foo}::FunctionTable>, as generated by the C module. Argument types can be specified to override those in the C<{foo}::FunctionTable>. Default values can also be specified, e.g. arg=default_value For example: ap_get_client_block | mpxs_ | r, SV *:buffer, bufsiz ap_setup_client_block | | r, read_policy=REQUEST_CHUNKED_ERROR ap_make_array | ap_make_array(r->pool, nelts, elt_size) | request_rec *:r, nelts, elt_size argspec of '...' indicates passthru, calling the function with (aTHX_ I32 items, SP **sp, SV **MARK) To mark an argument as return only you can prefix it with < e.g. dav_open_lockdb | | r, ro, open_lockdb (0) ; The return argument (e.g. lockdb) will always be passed by address to the function. The function alias, if defined, will be created in the current C. Function names on lines that do not begin with a word character or a single space are skipped. Function names can be prefixed with the following symbols: '!' => 'disabled or not yet implemented', '~' => 'implemented but not auto-generated', '-' => 'likely never be available to Perl', '>' => '"private" to your C library', '?' => 'unclassified', =head2 Structures map file Contains the mapping from C structures to Perl classes and defines the members for which access methods should be created. A C method may be specified, if desired. The format looks like the following: member1 member2 new An optional module name can be given, to specify in which module the code should be placed. To place the structure in My::Module, for example, specify: For all members that are listed here, XSBuilder will generate an access method to read and write it's content. If you want to name the perl access method differently than the C member, you can write cMemberValue | member_value | type this will map the C structure member to the access function C. The default is to use the same name in Perl as in C. As third argument you can give a typename. This defaults to the type of the variable. It can be used to specify a different type, for special conversion needs. (e.g. PV versus PVnull) If you give the C member, XSBuilder will create a new method for that class, which can be used to create a new instance and initialize it with data. =head2 Callbacks map file The format of entries is: C function name | argspec The content is the same as function map, it but contains the callbacks. =head1 Additional generated methods For structures, XSBuilder will generate two additional methods: C, and C. =head2 new ($initialvalue) With C you can create a new Perl object for an C structure. Optionally, you can pass either a hashref with initial data, or another object, who's data will be copied into the new object. =head2 init_callbacks C should be called during object initialization. It will fill in all callback members of a structure with pointers that cause a method call into the object, when the callback is called from C. You can call it either with $obj -> init_callbacks or MyModule -> init_callbacks ($obj) ; =head1 Callbacks A callback which is part of a structure will cause a call to the method with the same name as the structure member, prefixed with C. For example, if you have a structure member named C, then the Perl method C will be called whenever the C code calls the callback. If you want to call the callback on your own you need to call the method which is called like the structure member, e.g. C. NOTE: You need to call C during your method initialzation to be able to call callbacks. ExtUtils-XSBuilder-0.28/Changes0000755000000000000000000000600310300603462015050 0ustar rootroot* 0.28 - More information output in case mapping between C and Perl fails. - init_callbacks can take the object as a second argument - Documenatations updates * 0.27 - add support for char arrays - better handle win32 api * 0.26 - Include a default POD Template object * 0.25 - Make XSBuilder.pm compatible with CPAN.pm - Added minimal load test * 0.03 - Generation of pod files. (Based on a patch from Lyle Brooks) - Fix undef value which occurs when running under Perl 5.8.0. Patch from Angus Lees. * 0.02 - structs that are contained in another struct are now handled correctly. When reading the struct memeber a new object is returned, which can be used to access the members of the contained struct. The contained struct cannot be set directly. - In class name in xxx_types.map can end with :: to use single level classnames (e.g. request_rec * | Apache:: for mod_perl 1.x) - Argspec of xxx_functions.map can specify argument as return only by prefixing it with < e.g. dav_open_lockdb | | r, ro, open_lockdb (0) ; The return argument (e.g. lockdb) will always be passed by address to the function. - xs/xxxx_sv_convert.h now also contains macros to convert C data types to Perl for non object types e.g. IV - better handling for structs that for which a typedef doesn't exist. - method checkmaps & writemaps creates new_*.map with all functions/structures/types/callbacks that are not already in a map file. - ParseSource now scans for callbacks and generates a CallbackTable.pm with similar format as FunctionTable.pm - WrapXS generates callbacks for struct members as method calls when the struct doesn't contains any field where to store some userdata. An optimized version which passes the perl object in some user data field need still to be done. - Extra include files now given in xs/maps/foo_types instead of hardcoded in TypeMap.pm - prefixes for conversion macros and other generated functions are now set via an overrideable method - support for passing structure by value as function argument / return type - macros in xxx_sv_convert.h now correctly convert NULL to undef and viceversa - Structure members can have a different name in Perl and C. Controlled via the map file. - %convert_alias has been moved into types.map - typemap ids (e.g. T_APACHEOBJ) has been moved into types.map - it possible to configure the way how memory for strings is allocated via map files, by giveing a malloctype in type map file and allocation code in structure map file. - a dispatch argspec can now given in the map file, this allows to pass $r to the xs function and r -> pool to the C function by writing: ap_make_array | ap_make_array(r->pool, nelts, elt_size) | request_rec *:r, nelts, elt_size - handle conversion from package name to directory correctly when more then two levels of namespaces e.g. Apache::DAV::Resource -> Apache/DAV/Resource/Resource_pm ExtUtils-XSBuilder-0.28/test.pl0000644000000000000000000000015610415732120015072 0ustar rootroot use ExtUtils::testlib ; BEGIN { print "loading ... " } ; use ExtUtils::XSBuilder::WrapXS ; print "ok\n" ; ExtUtils-XSBuilder-0.28/Makefile.PL0000755000000000000000000000063207600606716015547 0ustar rootrootuse ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'ExtUtils::XSBuilder', 'VERSION_FROM' => 'XSBuilder.pm', 'AUTHOR' => 'Gerald Richter ', 'ABSTRACT' => 'Automatic XS glue code generation', 'PREREQ_PM' => { 'Parse::RecDescent' => 0, 'Tie::IxHash' => 0 }, ); ExtUtils-XSBuilder-0.28/xsbuilder.osc2002.pod0000644000000000000000000004266507523536644017410 0ustar rootroot =head1 XSBuilder - Autogenerating XS-glue Code O'Reilly OpenSource Convention 2002 Gerald Richter ecos gmbh http://www.ecos.de =head1 XSBuilder - What is it? =head2 It's purpose is to automaticly generate a Perl interface to C Code =head2 Solves the problem, that the Perl interface is not always uptodate with the C interface =head2 Saves a lot of Copy&Paste work =head2 Systematical changes have to be done only once For example changes in the memory management of strings. =head2 Is part of mod_perl 2.0 build system Most code is developed by Doug MacEachern. Additionaly I have =over =item abstracted the code from mod_perl so it's useable for any C code =item added new features like callbacks and the ability to parse comments =item Replaced C::Scan with a Parse::RecDescent to be platform and compiler independend =back Goal is to replace the current mod_perl XS generation code with XSBuilder =head2 Inline versus XSBuilder =over =item Inline: embed C-Code into Perl =item XSBuilder: Create interface for existing C-libraries/applicationen =back =head1 XSBuilder - What does it do? =head2 Create Perl functions/methods for every C function The function can be assigned to different packages, also automaticly by inspecting the first parameter =head2 Create a Perl class for every C structure Every element of structure becomes a Perl method to get/set it's value. The object can be either a scalar reference (used by mod_perl) or a reference to a hash (use by Embperl), which allows to store extra data by the Perl code into this hash. =head2 Create glue code to handle callbacks There several sorts of callback, not all are implemented right now =head2 Create Perl constant subs Coming soon... =head1 XSBuilder - How does it work? =head2 Parse the C header files Extract =over =item Functions, their arguments and return types =item Structures and it's members =item Constants =item Callbacks =back and create four tables which contains the results =head2 Create the XS code Input is =over =item The source tables =item Mapfiles which contains the mapping from C to Perl =item Addtional C and Perl code that can be used to customize the interface =back Output is =over =item The XS files (one form every generated class) =item Makefile.PL for every class =item pm files =back =head1 Parse the source =head2 Create your own ParseSource class and override methods... package Apache::DAV::ParseSource; use strict; use vars qw{@ISA $VERSION} ; use ExtUtils::XSBuilder::ParseSource ; @ISA = ('ExtUtils::XSBuilder::ParseSource') ; $VERSION = '0.01'; my $dav_dir = 'C:\perl\msrc\cvs\mod_dav' ; my $ap_dir = 'c:\programme\apache group\apache' ; # ============================================================================ sub find_includes { my $self = shift; return $self->{includes} if $self->{includes}; my @includes = ("$ap_dir/include/ap_alloc.h", "$dav_dir/mod_dav.h") ; return $self->{includes} = $self -> sort_includes (\@includes) ; } # ============================================================================ sub package { 'Apache::DAV' } # ============================================================================ sub preprocess { my $self = shift ; $_[0] =~ s/(?:API_EXPORT)(?:_NONSTD)?\s*\(\s*(.*?)\s*\)/$1/g ; } 1; =head2 ...run it use FindBin ; use lib ($FindBin::Bin) ; require ParseSource ; Apache::DAV::ParseSource -> run ; =head2 ...and you get C:\perl\msrc\davint>perl xsbuilder\source_scan.pl Will use mod_dav in C:\perl\msrc\cvs\mod_dav Will use Apache in c:\programme\apache group\apache Initialize parser scan c:\programme\apache group\apache/include/ap_alloc.h ... constant: APACHE_ALLOC_H func: ap_init_alloc func: ap_cleanup_alloc func: ap_make_sub_pool func: ap_destroy_pool constant: ap_pool_join func: ap_pool_join func: ap_find_pool func: ap_pool_is_ancestor func: ap_clear_pool func: ap_cleanup_for_exec func: ap_palloc func: ap_pcalloc func: ap_pstrdup func: ap_pstrndup func: ap_pstrcat func: ap_pvsprintf valuefield: ap_pool * : pool valuefield: int : elt_size valuefield: int : nelts valuefield: int : nalloc valuefield: char * : elts struct: (type=array_header) ... =head2 The result is stored in four tables =over =item xsbuilder/tables/Apache/DAV/FuntionTable.pm Contains all function, it arguments and comments =item xsbuilder/tables/Apache/DAV/ConstantTable.pm Contains all constants =item xsbuilder/tables/Apache/DAV/StructureTable.pm Contains all structures, it's members and their comments =item xsbuilder/tables/Apache/DAV/CallbackTable.pm Contains all callback function definitions =back =head1 Create the map files =head2 Mapfiles are used to tell XSBuilder how C datatypes, structures and function aruments should be mapped into Perl ones. =head2 Create your own WrapXS class and override methods package Apache::DAV::WrapXS ; use strict; use vars qw{@ISA $VERSION} ; use ExtUtils::XSBuilder::WrapXS ; @ISA = ('ExtUtils::XSBuilder::WrapXS') ; $VERSION = '0.01'; # ============================================================================ sub new_parsesource { [ Apache::DAV::ParseSource->new ] } # ============================================================================ sub my_xs_prefix { 'davxs_' } # ============================================================================ sub h_filename_prefix { 'moddav_xs_' } # ============================================================================ sub xs_includes { my $self = shift ; my $i = $self -> SUPER::xs_includes ; my @i = grep (!/ap_alloc/, @$i) ; return \@i ; } =head2 XSBuilder can create/update initial maps for you use FindBin ; use lib ($FindBin::Bin) ; require ParseSource ; require WrapXS ; Apache::DAV::WrapXS->checkmaps (' '); =head2 run it C:\perl\msrc\davint>perl xsbuilder\xs_check.pl Will use mod_dav in C:\perl\msrc\cvs\mod_dav Will use Apache in c:\programme\apache group\apache Parse xsbuilder\maps/_types.map... WARNING: No *_function.map file found in xsbuilder\maps WARNING: No *_callback.map file found in xsbuilder\maps WARNING: No *_structure.map file found in xsbuilder\maps Write xsbuilder\maps/new_function.map... Write xsbuilder\maps/new_callback.map... Write xsbuilder\maps/new_structure.map... Write xsbuilder\maps/new_type.map... =head2 Now we have four map files =over 4 =item new_types.map Contains the mapping from C type to Perl classes =item new_functions.map Contains the mapping form C functions to Perl functions. Can be used to reorder arguments, tell XSBuilder which arguments are actualy return values and in which Perl package the function will be created. =item new_structures.map Contains the mapping from C structures to Perl classes and defines for which members a access methods should be created. You can also specify if you want a C method for the class. =item new_callbacks.map Contains the mapping form C callback functions to Perl callback functions. Can be used to reorder arguments, tell XSBuilder which arguments are actualy return values and in which Perl package the function will be created. =back It's a good idea to rename the prefix from C to something unique, here we use C Everytime you rerun checkmaps, XSBuilder will create new_* files with the items that are not already part of the other maps. =head2 Next step is to customize the maps... =head1 type map =head2 autogenerated dav_type.map DIR | FILE | HANDLE | array_header | dav_buffer | dav_dyn_context | dav_dyn_hooks | dav_dyn_module | dav_dyn_provider | dav_error | dav_get_props_result | dav_hooks_liveprop | dav_hooks_locks | dav_hooks_repository | dav_if_header | dav_if_state_type | ... =head2 Add Perl classes struct array_header | Apache::Array struct dav_buffer | struct dav_datum | Apache::DAV::Datum struct dav_dyn_context | Apache::DAV::DynContext struct dav_dyn_hooks | Apache::DAV::DynHooks struct dav_dyn_module | Apache::DAV::DynModule struct dav_dyn_provider | Apache::DAV::DynProvider struct dav_error | Apache::DAV::Error struct dav_get_props_result | Apache::DAV::PropsResult struct dav_hooks_db | Apache::DAV::HooksDb struct dav_hooks_liveprop | Apache::DAV::HooksLiveprop struct dav_hooks_locks | Apache::DAV::HooksLocks struct dav_hooks_repository | Apache::DAV::HooksRepository struct dav_hooks_vsn | struct dav_if_header | Apache::DAV::IfHeader struct dav_if_state_list | Apache::DAV::StateList ... struct pool | Apache::Pool struct request_rec | Apache:: struct server_rec | Apache::Server ... Defines the mapping from C datatypes to Perl datatypes and classes and tells XSBuilder which datatype are (like) structures =head1 function map Function map defines the mapping from C functions arguments to Perl arguments =over =item Tell XSBuilder where to place functions and which prefix to strip MODULE=Apache::DAV PACKAGE=guess PREFIX=dav_ =item Simple entries in the function map will be mapped 1:1 from C to Perl dav_add_response dav_buffer_append dav_buffer_init dav_buffer_place dav_buffer_place_mem dav_check_bufsize dav_close_propdb dav_collect_liveprop_uris dav_dyn_module_add dav_empty_elem ... =item The following map file entry tells XSBuilder that the value of C should be returned dav_get_resource | | r, lookup_uri($uri); # get a mod_dav resource object my ($err, $resource) = $subr->get_resource; =item You can let XSBuilder insert your custom code, for the interface If you call C from Perl C will be called, which can adjust the arguments and return types as necessary. The actual code for C will be taken from separate include file. dav_get_props | glue_ dav_get_allprops | glue_ xsinclude\Apache\DAV\PropResult\Apache__DAV__PropResults.h dav_get_props_result * dav_glue_get_props(dav_propdb * db, dav_xml_doc *doc) { dav_get_props_result * result = (dav_get_props_result *)ap_palloc (db -> p, sizeof (dav_get_props_result)) ; *result = dav_get_props(db, doc) ; return result ; } =item Arguments can be replaced MODULE=Apache::Array PACKAGE=Apache::Array PREFIX=ap_ ap_make_array | ap_make_array(r->pool, nelts, elt_size) | request_rec *:r, nelts, elt_size ap_make_array requires a pool a it's first parameter, we pass the request_rec from Perl and XSBuilder will take the pool from the request_rec. =back =head1 structure map MALLOC=strdup:$dest = ($type)strdup($src) FREE=strdup:free($src) name ns lang first_cdata following_cdata parent next first_child attr last_child ns_scope propid provider ns_map new MALLOC=strdup:$dest = ($type)ap_pstrdup(obj -> pool, $src) pool elt_size nelts nalloc elts private =head2 Create a accessor functions for every element and, if requested, a new method $setprop = Apache::DAV::XMLElem -> new ({name => 'prop'}) ; $elem = Apache::DAV::XMLElem -> new ({name => $name, ns => $namespaces}) ; $setprop -> first_child($elem) ; $first = $setprop -> first_child ; =head2 some datatypes, like strings, requires dynamic allocated memory From _types.map,which conatins a set of standard types int | IV int * | UNDEFINED unsigned int | UV signed int | IV long | IV long int | IV unsigned long | UV unsigned | UV char * | PV | | | strdup const char * | PV | | | strdup const char ** | UNDEFINED char const * | PV | | | strdup unsigned char * | PV | | | strdup const unsigned char * | PV | | | strdup ... =head1 callback maps Callback maps have the same options a function maps # dav_hooks_db -> open dav_error *(*)(pool * p,const dav_resource * resource,int ro,dav_db * * pdb) | p, resource, ro=0, has_locks dav_error *(*)(dav_lockdb * lockdb,const dav_resource * resource,int * locks_present) =head1 Generate the XS files use FindBin ; use lib ($FindBin::Bin) ; require ParseSource ; require WrapXS ; Apache::DAV::WrapXS->run; =head2 ...and run... C:\perl\msrc\davint>perl xsbuilder\xs_generate.pl Will use mod_dav in C:\perl\msrc\cvs\mod_dav Will use Apache in c:\programme\apache group\apache Parse xsbuilder\maps/_types.map... Parse xsbuilder\maps/dav_type.map... mkdir xs writing...xs//typemap Parse xsbuilder\maps/dav_functions.map... WARNING: Cannot map type int(*)(void * ,const char * ,const char * ) for function ap_table_do WARNING: Cannot map type dav_buffer * for function dav_buffer_append WARNING: Cannot map type dav_buffer * for function dav_buffer_init WARNING: Cannot map type dav_buffer * for function dav_buffer_place WARNING: Cannot map type dav_buffer * for function dav_buffer_place_mem WARNING: Cannot map type dav_buffer * for function dav_check_bufsize WARNING: Cannot map return type int * for function dav_collect_liveprop_uris WARNING: Cannot map type dav_resource * * for function dav_ensure_resource_writable WARNING: Cannot map type dav_buffer * for function dav_lock_get_activelock WARNING: Cannot map type dav_buffer * for function dav_set_bufsize WARNING: Cannot map type int * for function dav_xml2text struct array_header... Parse xsbuilder\maps/dav_structure.map... elt_size... nelts... nalloc... elts... struct dav_buffer... struct dav_datum... dptr... dsize... struct dav_dyn_context... =head1 Makefile.PL =head2 We need create a top level Makefile.PL use ExtUtils::MakeMaker (); my $apdir = '/path/to/apache'; my $davdir = '/path/to/moddav'; %MMARGS = ( 'INC' => "-I\"$davdir\" -I\"$apdir/include\" -I\"$apdir/os/unix\" -I\"$dir/xs\" -I\"$dir/xsinclude\"", ) ; open FH, ">xs/mmargs.pl" or die "Cannot open xs/mmargs.pl ($!)" ; print FH Data::Dumper -> Dump ([\%MMARGS], ['MMARGS']) ; close FH ; ExtUtils::MakeMaker::WriteMakefile( 'NAME' => 'Apache::DAV', 'VERSION' => '0.13', %MMARGS, ); =head2 Makefile.PL's for all class are generated automaticly C:\perl\msrc\davint>perl Makefile.PL Will use Apache in c:\programme\apache group\apache Will use mod_dav in C:\perl\msrc\cvs\mod_dav Checking if your kit is complete... Looks good Writing Makefile for Apache::Array Writing Makefile for Apache::DAV::Datum Writing Makefile for Apache::DAV::DynContext Writing Makefile for Apache::DAV::DynHooks Writing Makefile for Apache::DAV::DynModule Writing Makefile for Apache::DAV::DynProvider Writing Makefile for Apache::DAV::Error Writing Makefile for Apache::DAV::HooksDb Writing Makefile for Apache::DAV::HooksLiveprop Writing Makefile for Apache::DAV::HooksLocks Writing Makefile for Apache::DAV::HooksRepository Writing Makefile for Apache::DAV::IfHeader Writing Makefile for Apache::DAV::Lock Writing Makefile for Apache::DAV::LockDB Writing Makefile for Apache::DAV::LockTokenList Writing Makefile for Apache::DAV::LockupResult Writing Makefile for Apache::DAV::PropCtx Writing Makefile for Apache::DAV::PropsResult Writing Makefile for Apache::DAV::Resource Writing Makefile for Apache::DAV::Response Writing Makefile for Apache::DAV::StateList Writing Makefile for Apache::DAV::Text Writing Makefile for Apache::DAV::TextHeader Writing Makefile for Apache::DAV::WalkerCtx Writing Makefile for Apache::DAV::XMLAttr Writing Makefile for Apache::DAV::XMLDoc Writing Makefile for Apache::DAV::XMLElem Writing Makefile for Apache::DAV Writing Makefile for Apache::TableEntry Writing Makefile for Apache Writing Makefile for WrapXS Writing Makefile for Apache::DAV =head2 and now compile... =head1 How does it go on... =head2 Generating documentation XSBuilder already extracts source comments for functions and structures. It also parses doxygen comments, which are used in Apache 2.0. Lyle Brooks has started on automaticly createing POD files from this information. =head2 Improving callbacks Callbacks are the main area that needs improvement. =head2 Bring it back to mod_perl 2.0 =head2 First version will be released just after the conference to CPAN =head2 Any feedback and help appreciated =head2 Questions?ExtUtils-XSBuilder-0.28/META.yml0000644000000000000000000000057510415747655015057 0ustar rootroot# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: ExtUtils-XSBuilder version: 0.28 version_from: XSBuilder.pm installdirs: site requires: Parse::RecDescent: 0 Tie::IxHash: 0 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.17 ExtUtils-XSBuilder-0.28/XSBuilder/0000755000000000000000000000000010415747655015440 5ustar rootrootExtUtils-XSBuilder-0.28/XSBuilder/C/0000755000000000000000000000000010415747655015622 5ustar rootrootExtUtils-XSBuilder-0.28/XSBuilder/C/grammar.pm0000755000000000000000000002711107503553414017603 0ustar rootrootpackage ExtUtils::XSBuilder::C::grammar; # initial grammar is taken from Inline::C::grammar & Inline::Struct::grammar use strict; use vars qw{$VERSION @EXPORT @ISA} ; use Exporter ; use Data::Dumper ; $VERSION = '0.30'; @ISA = qw{Exporter} ; @EXPORT = qw{cdef_define cdef_enum cdef_struct cdef_function_declaration} ; # ============================================================================ sub cdef_define { my ($thisparser, $name, $comment) = @_ ; my $elem = { name => $name, $comment?(comment => $comment):() } ; if ($thisparser->{srcobj}->handle_define($elem)) { push @{$thisparser->{data}{constants}}, $elem ; print "constant: $name\n" ; } else { print "constant: $name (ignore because handle_define returned false)\n" ; } } # ============================================================================ sub cdef_enum { my ($thisparser, $names) = @_ ; for (@{$names}) { if (ref $_) { my $elem = { name => $_ -> [0], $_->[1] && @{$_->[1]}?('comment' => join (' ', @{$_->[1]})):() } ; push @{$thisparser->{data}{constants}}, $elem if ($thisparser->{srcobj}->handle_enum($elem)) ; } } 1 ; } # ============================================================================ sub cdef_struct { my ($thisparser, $perlname, $cname, $fields, $type) = @_; my $seen = \$thisparser->{data}{structure}{$cname || $type} ; my $s = $$seen ; return 0 if ($s && ($s -> {elts} && !$type)) ; #print "cdef $cname $type\n" ; $s ||= {} ; $s -> {type} ||= $cname ; $s -> {type} = $type if ($type) ; if ($fields) { my @fields; my @comment ; for (@$fields) { if (ref $_) { push @fields, { 'type' => $_->[0], 'name' => $_->[1], ($_->[2] && @{$_->[2]}) || @comment?('comment' => join (' ', @{$_->[2]}, @comment)):(), $_->[3] && @{$_->[3]}?('args' => $_->[3]):(), } ; @comment = () ; } else { push @comment, $_ ; } } $s -> {elts} = \@fields ; } $s -> {stype} = $cname if ($cname) ; if ($fields) { if ($thisparser->{srcobj}->handle_struct($s)) { push @{$thisparser->{data}{structures}}, $s ; print "struct: $cname (type=$type)\n" ; } else { print "struct: $cname (ignore because handle_struct returned false)\n" ; } } $$seen = $s ; return $s ; } # ============================================================================ sub cdef_function_declaration { my ($thisparser, $function, $rettype, $args) = @_ ; return 0 if (!$function) ; return 0 if ($thisparser->{data}{function}{$function}++) ; my $s = { 'name' => $function } ; my $dummy = 'arg0' ; $s -> {return_type} = $rettype ; my @args ; my $i = 0 ; for (@{$args}) { if (ref $_) { push @args, { 'type' => $_->[0], 'name' => $_->[1] || "arg$i", } if ($_->[0] ne 'void') ; } $i++ ; } $s -> {args} = \@args ; if ($thisparser->{srcobj}->handle_function($s)) { push @{$thisparser->{data}{functions}}, $s ; print "func: $function\n" ; } else { print "func: $function (ignore because handle_function returned false)\n" ; } return $s ; } # ============================================================================ sub grammar { <<'END'; { use ExtUtils::XSBuilder::C::grammar ; # import cdef_xxx functions } code: comment_part(s) {1} comment_part: comment(s?) part { #print "comment: ", Data::Dumper::Dumper(\@item) ; $item[2] -> {comment} = "@{$item[1]}" if (ref $item[1] && @{$item[1]} && ref $item[2]) ; 1 ; } | comment part: prepart | stdpart { if ($thisparser -> {my_neednewline}) { print "\n" ; $thisparser -> {my_neednewline} = 0 ; } $return = $item[1] ; } # prepart can be used to extent the parser (for default it always fails) prepart: '?' {0} stdpart: define { $return = cdef_define ($thisparser, $item[1][0], $item[1][1]) ; } | struct { $return = cdef_struct ($thisparser, @{$item[1]}) ; } | enum { $return = cdef_enum ($thisparser, $item[1][1]) ; } | function_declaration { $return = cdef_function_declaration ($thisparser, @{$item[1]}) ; } | struct_typedef { my ($type,$alias) = @{$item[1]}[0,1]; $return = cdef_struct ($thisparser, undef, $type, undef, $alias) ; } | comment | anything_else comment: m{\s* // \s* ([^\n]*) \s*? \n }x { $1 } | m{\s* /\* \s* ([^*]+|\*(?!/))* \s*? \*/ ([ \t]*)? }x { $item[1] =~ m#/\*\s*?(.*?)\s*?\*/#s ; $1 } semi_linecomment: m{;\s*\n}x { $return = [] ; 1 ; } | ';' comment(s?) { $item[2] } function_definition: rtype IDENTIFIER '(' (s?) ')' '{' {[@item[2,1], $item[4]]} pTHX: 'pTHX_' function_declaration: type_identifier '(' pTHX(?) (s?) ')' function_declaration_attr ( ';' | '{' ) { #print Data::Dumper::Dumper (\@item) ; [ $item[1][1], $item[1][0], @{$item[3]}?[['pTHX', 'aTHX' ], @{$item[4]}]:$item[4] ] } define: '#define' IDENTIFIER /.*?\n/ { $item[3] =~ m{(?:/\*\s*(.*?)\s*\*/|//\s*(.*?)\s*$)} ; [$item[2], $1] } ignore_cpp: '#' /.*?\n/ struct: 'struct' IDENTIFIER '{' field(s) '}' ';' { # [perlname, cname, fields] [$item[2], "@item[1,2]", $item[4]] } | 'typedef' 'struct' '{' field(s) '}' IDENTIFIER ';' { # [perlname, cname, fields] [$item[6], undef, $item[4], $item[6]] } | 'typedef' 'struct' IDENTIFIER '{' field(s) '}' IDENTIFIER ';' { # [perlname, cname, fields, alias] [$item[3], "@item[2,3]", $item[5], $item[7]] } struct_typedef: 'typedef' 'struct' IDENTIFIER IDENTIFIER ';' { ["@item[2,3]", $item[4]] } enum: 'enum' IDENTIFIER '{' enumfield(s) '}' ';' { [$item[2], $item[4]] } | 'typedef' 'enum' '{' enumfield(s) '}' IDENTIFIER ';' { [undef, $item[4], $item[6]] } | 'typedef' 'enum' IDENTIFIER '{' enumfield(s) '}' IDENTIFIER ';' { [$item[3], $item[5], $item[7]] } field: comment | define { $return = cdef_define ($thisparser, $item[1][0], $item[1][1]) ; } | valuefield | callbackfield | ignore_cpp valuefield: type_identifier comment(s?) semi_linecomment { $thisparser -> {my_neednewline} = 1 ; print " valuefield: $item[1][0] : $item[1][1]\n" ; [$item[1][0], $item[1][1], [$item[2]?@{$item[2]}:() , $item[3]?@{$item[3]}:()] ] } callbackfield: rtype '(' '*' IDENTIFIER ')' '(' (s?) ')' comment(s?) semi_linecomment { my $type = "$item[1](*)(" . join(',', map { "$_->[0] $_->[1]" } @{$item[7]}) . ')' ; my $dummy = 'arg0' ; my @args ; for (@{$item[7]}) { if (ref $_) { push @args, { 'type' => $_->[0], 'name' => $_->[1], } if ($_->[0] ne 'void') ; } } my $s = { 'name' => $type, 'return_type' => $item[1], args => \@args } ; push @{$thisparser->{data}{callbacks}}, $s if ($thisparser->{srcobj}->handle_callback($s)) ; $thisparser -> {my_neednewline} = 1 ; print " callbackfield: $type : $item[4]\n" ; [$type, $item[4], [$item[9]?@{$item[9]}:() , $item[10]?@{$item[10]}:()]] ; } enumfield: comment | IDENTIFIER comment(s?) /,?/ comment(s?) { [$item[1], [$item[2]?@{$item[2]}:() , $item[4]?@{$item[4]}:()] ] ; } rtype: modmodifier(s) TYPE star(s?) { my @modifier = @{$item[1]} ; shift @modifier if ($modifier[0] eq 'extern' || $modifier[0] eq 'static') ; $return = join ' ',@modifier, $item[2] ; $return .= join '',' ',@{$item[3]} if @{$item[3]}; 1 ; } | TYPE(s) star(s?) { $return = join (' ', @{$item[1]}) ; $return .= join '',' ',@{$item[2]} if @{$item[2]}; #print "rtype $return \n" ; 1 ; } modifier(s) star(s?) { join ' ',@{$item[1]}, @{$item[2]} ; } arg: type_identifier {[$item[1][0],$item[1][1]]} | '...' {['...']} arg_decl: rtype '(' '*' IDENTIFIER ')' '(' (s?) ')' { my $type = "$item[1](*)(" . join(',', map { "$_->[0] $_->[1]" } @{$item[7]}) . ')' ; my $dummy = 'arg0' ; my @args ; for (@{$item[7]}) { if (ref $_) { push @args, { 'type' => $_->[0], 'name' => $_->[1], } if ($_->[0] ne 'void') ; } } my $s = { 'name' => $type, 'return_type' => $item[1], args => \@args } ; push @{$thisparser->{data}{callbacks}}, $s if ($thisparser->{srcobj}->handle_callback($s)) ; [$type, $item[4], [$item[9]?@{$item[9]}:() , $item[11]?@{$item[11]}:()]] ; } | 'pTHX' { ['pTHX', 'aTHX' ] } | type_identifier { [$item[1][0], $item[1][1] ] } | '...' {['...']} function_declaration_attr: type_identifier: type_varname { my $r ; my @type = @{$item[1]} ; #print "type = @type\n" ; my $name = pop @type ; if (@type && ($name !~ /\*/)) { $r = [join (' ', @type), $name] } else { $r = [join (' ', @{$item[1]})] ; } #print "r = @$r\n" ; $r ; } type_varname: attribute(s?) TYPE(s) star(s) varname(?) { [@{$item[1]}, @{$item[2]}, @{$item[3]}, @{$item[4]}] ; } | attribute(s?) varname(s) { $item[2] ; } varname: ##IDENTIFIER '[' IDENTIFIER ']' IDENTIFIER '[' /[^]]+/ ']' { "$item[1]\[$item[3]\]" ; } | IDENTIFIER ':' IDENTIFIER { $item[1] } | IDENTIFIER { $item[1] } star: '*' | 'const' '*' modifier: 'const' | 'struct' | 'enum' | 'unsigned' | 'long' | 'extern' | 'static' | 'short' | 'signed' modmodifier: 'const' | 'struct' | 'enum' | 'extern' | 'static' attribute: 'extern' | 'static' # IDENTIFIER: /[a-z]\w*/i IDENTIFIER: /\w+/ TYPE: /\w+/ anything_else: /.*/ END } 1; __END__ =pod | function_definition { my $function = $item[1][0]; $return = 1, last if $thisparser->{data}{done}{$function}++; push @{$thisparser->{data}{functions}}, $function; $thisparser->{data}{function}{$function}{return_type} = $item[1][1]; $thisparser->{data}{function}{$function}{arg_types} = [map {ref $_ ? $_->[0] : '...'} @{$item[1][2]}]; $thisparser->{data}{function}{$function}{arg_names} = [map {ref $_ ? $_->[1] : '...'} @{$item[1][2]}]; } =cut ExtUtils-XSBuilder-0.28/XSBuilder/StructureMap.pm0000755000000000000000000001073110304756662020434 0ustar rootrootpackage ExtUtils::XSBuilder::StructureMap; use strict; use warnings FATAL => 'all'; use ExtUtils::XSBuilder::MapUtil qw(function_table structure_table); use Data::Dumper ; our @ISA = qw(ExtUtils::XSBuilder::MapBase); sub new { my $class = shift; my $self = bless {wrapxs => shift}, $class; $self->{IGNORE_RE} = qr{^$}; return $self ; } sub generate { my $self = shift; my $map = $self->get; for my $entry (@{ structure_table($self -> {wrapxs}) }) { my $type = $entry->{type}; my $elts = $entry->{elts}; next unless @$elts; next if $type =~ $self->{IGNORE_RE}; next unless grep { not exists $map->{$type}->{ $_->{name} } } @$elts; print "<$type>\n"; for my $e (@$elts) { print " $e->{name}\n"; } print "\n\n"; } } sub disabled { shift->{disabled} } sub check { my $self = shift; my $map = $self->get; my @missing; my $parsesource = $self -> {wrapxs} -> parsesource_objects ; loop: for my $entry (@{ structure_table($self -> {wrapxs}) }) { my $type = $entry->{type}; for my $name (map $_->{name}, @{ $entry->{elts} }) { next if exists $map->{$type}->{$name}; next if $type =~ $self->{IGNORE_RE}; push @missing, "$type.$name"; } push @missing, "$type.new" if (!exists $map->{$type}->{'new'}) ; push @missing, "$type.private" if (!exists $map->{$type}->{'private'}) ; } return @missing ? \@missing : undef; } sub check_exists { my $self = shift; my %structures; for my $entry (@{ structure_table($self -> {wrapxs}) }) { $structures{ $entry->{type} } = { map { $_->{name}, 1 } @{ $entry->{elts} } }; } my @missing; while (my($type, $elts) = each %{ $self->{map} }) { for my $name (keys %$elts) { next if exists $structures{$type}->{$name}; push @missing, "$type.$name"; } } return @missing ? \@missing : undef; } sub parse { my($self, $fh, $map) = @_; my($disabled, $class, $class2); my %cur; my %malloc; my %free; while ($fh->readline) { if (/MALLOC=\s*(.*?)\s*:\s*(.*?)$/) { $malloc{$1} = $2 ; next; } if (/FREE=\s*(.*?)\s*:\s*(.*?)$/) { $free{$1} = $2 ; next; } elsif (m:^(\W?)]+)>:) { $map->{$class}{-malloc} = { %malloc } ; $map->{$class}{-free} = { %free } ; next; } elsif (m:^(\W?)]+)>:) { my $args; $disabled = $1; ($class, $args) = split /\s+/, $2, 2; if ($class eq 'struct') { ($class2, $args) = split /\s+/, $args, 2; $class .= ' ' . $class2 ; } %cur = (); if ($args and $args =~ /E=/) { %cur = $self->parse_keywords($args); } $self->{MODULES}->{$class} = $cur{MODULE} if $cur{MODULE}; next; } elsif (s/^(\w+):\s*//) { push @{ $self->{$1} }, split /\s+/; next; } if (s/^(\W)\s*// or $disabled) { my @parts = split /\s*\|\s*/ ; $map->{$class}->{$parts[0]} = undef; push @{ $self->{disabled}->{ $1 || '!' } }, "$class.$_"; } else { my @parts = split /\s*\|\s*/ ; $map->{$class}->{$parts[0]} = { name => $parts[0], perl_name => $parts[1] || $parts[0], type => $parts[2] } ; } } if (my $ignore = $self->{IGNORE}) { $ignore = join '|', @$ignore; $self->{IGNORE_RE} = qr{^($ignore)}; } else { $self->{IGNORE_RE} = qr{^$}; } } sub get { my $self = shift; $self->{map} ||= $self->parse_map_files; } sub write { my ($self, $fh, $newentries, $prefix) = @_ ; my $last = '' ; foreach my $type (@$newentries) { my ($struct, $elem) = split (/\./, $type) ; $fh -> print ("$prefix\n") if ($last && $last ne $struct) ; $fh -> print ("$prefix<$struct>\n") if ($last ne $struct) ; $last = $struct ; $fh -> print ($prefix, ' ', $self -> {wrapxs} -> mapline_elem ($elem), "\n") ; } $fh -> print ("$prefix\n") if ($last) ; } 1; __END__ ExtUtils-XSBuilder-0.28/XSBuilder/CallbackMap.pm0000755000000000000000000000441610276663563020140 0ustar rootrootpackage ExtUtils::XSBuilder::CallbackMap; use strict; use warnings FATAL => 'all'; use ExtUtils::XSBuilder::MapUtil qw(callback_table); our @ISA = qw(ExtUtils::XSBuilder::FunctionMap); # ============================================================================ #look for callbacks that do not exist in *.map sub check { my $self = shift; my $map = $self->get; my @missing; my $parsesource = $self -> {wrapxs} -> parsesource_objects ; loop: for my $name (map $_->{name}, @{ callback_table($self -> {wrapxs}) }) { next if exists $map->{$name}; push @missing, $name ; } return @missing ? \@missing : undef; } # ============================================================================ #look for callbacks in *.map that do not exist sub check_exists { my $self = shift; my %callbacks = map { $_->{name}, 1 } @{ callback_table($self -> {wrapxs}) }; my @missing = (); #print Data::Dumper -> Dump ([\%callbacks, $self->{map}]) ; for my $name (keys %{ $self->{map} }) { next if $callbacks{$name}; push @missing, $name ; } return @missing ? \@missing : undef; } # ============================================================================ sub parse { my($self, $fh, $map) = @_; my %cur; my $disabled = 0; while ($fh->readline) { my($type, $argspec) = split /\s*\|\s*/; my $entry = $map->{$type} = { name => $type, argspec => $argspec ? [split /\s*,\s*/, $argspec] : "", }; #avoid 'use of uninitialized value' warnings $entry->{$_} ||= "" for keys %{ $entry }; } } sub write { my ($self, $fh, $newentries, $prefix) = @_ ; foreach (@$newentries) { my $line = $self -> {wrapxs} -> mapline_func ($_) ; if ($line =~ /\)\((.*?)\)/) { my @args = split (/,/, $1) ; $line .= ' | ' if (@args) ; my $i = 0 ; foreach (@args) { $line .= ',' if ($i++ > 0) ; /([^ ]+)$/ ; my $arg = $1 ; $line .= '<' if (/\* \*/) ; $line .= $arg ; } } $fh -> print ($prefix, $line, "\n") ; } } ExtUtils-XSBuilder-0.28/XSBuilder/TypeMap.pm0000644000000000000000000006360110415732357017354 0ustar rootrootpackage ExtUtils::XSBuilder::TypeMap; use strict; use warnings FATAL => 'all'; use ExtUtils::XSBuilder::FunctionMap (); use ExtUtils::XSBuilder::CallbackMap (); use ExtUtils::XSBuilder::StructureMap (); use ExtUtils::XSBuilder::MapUtil qw(list_first function_table structure_table callback_table callback_hash); use Data::Dumper ; our @ISA = qw(ExtUtils::XSBuilder::MapBase); sub new { my $class = shift; my $self = bless { INCLUDE => [], wrapxs => shift }, $class; $self->{function_map} = ExtUtils::XSBuilder::FunctionMap ->new ($self -> {wrapxs}), $self->{structure_map} = ExtUtils::XSBuilder::StructureMap->new ($self -> {wrapxs}), $self->{callback_map} = ExtUtils::XSBuilder::CallbackMap ->new ($self -> {wrapxs}), $self->get; $self; } my %special = map { $_, 1 } qw(UNDEFINED NOTIMPL CALLBACK); sub special { my($self, $class) = @_; return $special{$class}; } sub function_map { shift->{function_map}->get } sub structure_map { shift->{structure_map}->get } sub callback_map { shift->{callback_map}->get } sub parse { my($self, $fh, $map) = @_; while ($fh->readline) { if (/E=/) { my %args = $self->parse_keywords($_); while (my($key,$val) = each %args) { push @{ $self->{$key} }, $val; } next; } my @aliases; my($type, $class, $typemapid, $aliastypes, $malloctype) = split /\s*\|\s*/, $_, 5; if (!$typemapid && $class) { if ($class =~ /::/) { $typemapid = 'T_PTROBJ'; } else { $typemapid = "T_$class"; } } $class ||= 'UNDEFINED'; if ($type =~ s/^struct\s+(.*)/$1/) { push @aliases, "$type *", "const $type *", $type, "const $type", "struct $type", "const struct $type", "struct $type *", "const struct $type *", "$type **", "const $type **" ; my $cname = $class; if ($cname =~ s/::/__/g) { push @{ $self->{typedefs} }, [$type, $cname]; } } elsif ($type =~ /_t$/) { push @aliases, $type, "$type *", "const $type *"; } else { push @aliases, $type; } my $t = { class => $class, typemapid => $typemapid } ; $t -> {aliastypes} = [ split (/\s*,\s*/, $aliastypes) ] if ($aliastypes) ; $t -> {malloctype} = $malloctype if ($malloctype) ; for (@aliases) { $map->{$_} = $t ; } } } sub get { my $self = shift; $self->{map} ||= $self->parse_map_files; } my $ignore = join '|', qw{ ap_LINK ap_HOOK _ UINT union._ union.block_hdr cleanup process_chain iovec struct.rlimit Sigfunc in_addr_t }; sub should_ignore { my($self, $type) = @_; return 1 if $type =~ /^($ignore)/o; } sub is_callback { my($self, $type) = @_; return 1 if $type =~ /\(/ and $type =~ /\)/; #XXX: callback } sub exists { my($self, $type) = @_; return 1 if $self->is_callback($type) || $self->should_ignore($type); $type =~ s/\[\d+\]$//; #char foo[64] return exists $self->get->{$type}; } sub map_type { my($self, $type, $quiet) = @_; my $t = $self->get->{$type}; my $class = $t -> {class} ; unless ($class and ! $self->special($class)) { print "WARNING: Type '$type' not in mapfile\n" if (!$quiet); return undef ; } if ($class =~ /(.*?)::$/) { return $1 ; } if ($class =~ /::/) { return $class; } else { return $type; } } sub map_malloc_type { my($self, $type) = @_; my $t = $self->get->{$type}; return $t -> {malloctype} ; } sub map_class { my($self, $type) = @_; my $t = $self->get->{$type}; my $class = $t -> {class} ; return unless $class and ! $self->special($class); if ($class =~ /(.*?)::$/) { return $1 ; } return $class ; } sub null_type { my($self, $type) = @_; my $t = $self->get->{$type}; my $class = $t -> {class} ; if ($class =~ /^[INU]V/) { return '0'; } elsif ($class =~ /^(U_)?CHAR$/) { return '0'; # xsubpp seems to mangle q{'\0'} } else { return 'NULL'; } } sub can_map { my $self = shift; my $map = shift; my $return_type = shift ; if (!$self->map_type($return_type)) { print "WARNING: Cannot map return type $return_type for function ", $map->{name} || '???', "\n" ; return undef ; } return 1 if ($map->{argspec}) ; for (@_) { if (!$self->map_type($_)) { print "WARNING: Cannot map type $_ for function ", $map->{name} || '???', "\n" ; return undef ; } } return 1; } sub map_arg { my($self, $arg) = @_; #print Dumper ($arg), 'map ', $self->map_type($arg->{type}), "\n" ; return { name => $arg->{name}, default => $arg->{default}, type => $self->map_type($arg->{type}) || $arg->{type}, rtype => $arg->{type}, class => $self->{map}->{$arg->{type}}->{class} || "", } } sub map_args { my($self, $func, $entry) = @_; #my $entry = $self->function_map->{ $func->{name} }; my $argspec = $entry->{argspec}; my $args = []; my $retargs = []; if ($argspec) { $entry->{orig_args} = [ map $_->{name}, @{ $func->{args} } ]; #print "argspec ", Dumper($argspec) ; for my $arg (@$argspec) { my $default; my $return ; if ($arg =~ /^<(.*?)$/) { $arg = $1 ; $return = 1 ; } ($arg, $default) = split /=/, $arg, 2; my($type, $name) ; if ($arg =~ /^(.+)\s*:\s*(.+)$/) { $type = $1 ; $name = $2 ; } #my($type, $name) = split /:(?:[^:])/, $arg, 2; my $arghash ; if ($type and $name) { $arghash = { name => $name, type => $type, default => $default, }; } else { my $e = list_first { $_->{name} eq $arg } @{ $func->{args} }; if ($e) { $arghash = { %$e, default => $default}; } elsif ($arg eq '...') { $arghash = { name => '...', type => 'SV *'}; } else { warn "bad argspec: $func->{name} ($arg)\n", Dumper ($func->{args}) ; } } if ($arghash){ if ($return) { $arghash -> {return} = 1 ; $arghash -> {type} =~ s/\s*\*$// ; push @$retargs, $arghash ; } else { push @$args, $arghash ; } } } } else { $args = $func->{args}; } return ([ map $self->map_arg($_), @$args ], [ map $self->map_arg($_), @$retargs ]) ; } # ============================================================================ sub map_cb_or_func { my($self, $func, $map, $class) = @_; return unless $map; return unless $self->can_map($map, $func->{return_type} || 'void', map $_->{type}, @{ $func->{args} }); my ($mfargs, $mfretargs) = $self->map_args($func, $map) ; my $mf = { name => $func->{name}, comment => $func->{comment}, return_type => $self->map_type($map->{return_type} || $func->{return_type} || 'void'), args => $mfargs, retargs => $mfretargs, perl_name => $map->{name}, }; for (qw(dispatch argspec dispatch_argspec orig_args prefix)) { $mf->{$_} = $map->{$_}; } $mf->{class} = $class if ($class) ; unless ($mf->{class}) { $mf->{class} = $map->{class} || $self->first_class($mf); #print "GUESS class=$mf->{class} for $mf->{name}\n"; } $mf->{prefix} ||= $self -> {function_map} -> guess_prefix($mf); $mf->{module} = $map->{module} || $mf->{class}; $mf; } # ============================================================================ sub map_function { my($self, $func) = @_; my $map = $self->function_map->{ $func->{name} }; return unless $map; return $self -> map_cb_or_func ($func, $map) ; } # ============================================================================ sub map_callback { my($self, $callb, $class) = @_; my $name = $callb -> {type} ; my $callback = callback_hash ($self -> {wrapxs}) -> {$name} ; #print $callb -> {name} || '???' ," $name -> ", $callback || '-', "\n" ; return unless $callback; my $map = $self->callback_map->{ $name }; #print "$name -> map=", $map || '-', "\n" ; return unless $map; my $cb = $self -> map_cb_or_func ($callback, $map, $class) ; return unless $cb ; my $orig_args = $cb -> {orig_args} ; $orig_args = [ map $_->{name}, @{ $cb->{args} } ] if (!$orig_args) ; my %args = map { $_->{name} => $_ } @{ $cb->{args} } ; my %retargs = map { $_->{name} => $_ } @{ $cb->{retargs} } ; #print "mcb ", Dumper($cb), " cba ", Dumper($callback->{args}) , " args ", Dumper(\%args) ; $cb -> {orig_args} = [ map ($retargs{$_}?"\&$_":(($args{$_}{type} !~ /::/) || ($args{$_}{rtype} =~ /\*$/)? $_:"*$_"), @{ $orig_args }) ]; my $cbargs = [ { type => $class, name => '__self'} ] ; push @$cbargs, @{ $cb->{args} } if (@{ $cb->{args}}) ; $cb->{args} = $cbargs ; #print 'func', Dumper($callback), 'map', Dumper($map), 'cb', Dumper($cb) ; return $cb ; } # ============================================================================ sub map_structure { my($self, $struct) = @_; my($class, @elts); my $stype = $struct->{type}; return unless ($class = $self->map_type($stype)) ; my $module = $self->{structure_map}->{MODULES}->{$stype} || $class ; for my $e (@{ $struct->{elts} }) { my($name, $type) = ($e->{name}, $e->{type}); my $rtype; my $mapping ; if (!exists ($self->structure_map->{$stype}->{$name})) { if (!$name) { print "WARNING: The following struct element is not in mapfile and has no name\n", Dumper ($e) ; } else { print "WARNING: $name not in mapfile\n" ; } next ; } if (!($mapping = $self->structure_map->{$stype}->{$name})) { print "WARNING: $stype for $name not in mapfile\n" ; next ; } my $mallocmap = $self->structure_map->{$stype}{-malloc} ; my $freemap = $self->structure_map->{$stype}{-free} ; #print 'mapping: ', Dumper($mapping, $type) ; if ($rtype = $self->map_type($type, 1)) { #print "rtype=$rtype\n" ; my $malloctype = $self->map_malloc_type($type) ; push @elts, { name => $name, perl_name => $mapping -> {perl_name} || $name, comment => $e -> {comment}, type => $mapping -> {type} || $rtype, rtype => $type, default => $self->null_type($type), pool => $self->class_pool($class), class => $self->{map}->{$type}{class} || "", $malloctype?(malloc => $mallocmap -> {$malloctype}):(), $malloctype?(free => $freemap -> {$malloctype}):(), }; #print Dumper($elts[-1], $stype, $mallocmap, $self->map_malloc_type($type)) ; } elsif ($rtype = $self->map_callback($e, $class)) { push @elts, { name => $name, perl_name => $mapping -> {perl_name} || $name, func => { %$rtype, name => $name, perl_name => $rtype->{alias} || $name, module => $module, dispatch => "(*__self->$name)", comment => $e -> {comment}}, rtype => $type, default => 'NULL', #pool => $self->class_pool($class), class => $class || "", callback => 1, }; } else { print "WARNING: Type '$type' for struct memeber '$name' in not in types mapfile\n" ; } } return { module => $module, class => $class, type => $stype, elts => \@elts, has_new => $self->structure_map->{$stype}->{'new'}?1:0, has_private => $self->structure_map->{$stype}->{'private'}?1:0, comment => $struct -> {comment}, }; } sub destructor { my($self, $prefix) = @_; $self->function_map->{$prefix . 'DESTROY'}; } sub first_class_ok { 1 } ; sub first_class { my($self, $func) = @_; my $map = $self->get ; for my $e (@{ $func->{args} }) { ###next unless $e->{type} =~ /::/; # use map -> rtype to catch class:: next unless $map->{$e->{rtype}}{class} =~ /::/; #there are alot of util functions that take an APR::Pool #that do not belong in the APR::Pool class ###next if (!$self -> first_class_ok ($func, $e)) ; next if $e->{type} eq 'APR::Pool' and $func->{name} !~ /^apr_pool/; return $1 if ($e->{type} =~ /^(.*?)::$/) ; return $e->{type}; } return $func->{name} =~ /^apr_/ ? 'APR' : 'Apache'; } sub check { my $self = shift; my(@types, @missing, %seen); for my $entry (@{ structure_table($self -> {wrapxs}) }) { push @types, map $_->{type}, @{ $entry->{elts} } ; my $type = $entry -> {stype} || $entry->{type} ; push @types, $type =~/^struct\s+/?$type:"struct $type" ; } for my $entry (@{ function_table($self -> {wrapxs}) }) { push @types, grep { not $seen{$_}++ } ($entry->{return_type}, map $_->{type}, @{ $entry->{args} }) } #printf "%d types\n", scalar @types; for my $type (@types) { $type =~ s/\s*(\*\s*)+$// ; $type =~ s/const\s*// ; #$type =~ s/struct\s*// ; push @missing, $type unless ($self->exists($type) || $type eq 'new' || $type eq 'private') ; } return @missing ? \@missing : undef; } #look for Apache/APR structures that do not exist in structure.map my %ignore_check = map { $_,1 } qw{ module_struct cmd_how kill_conditions regex_t regmatch_t pthread_mutex_t unsigned void va_list ... iovec char int long const gid_t uid_t time_t pid_t size_t sockaddr hostent SV }; sub check_exists { my $self = shift; my %structures = map { my $t = $_->{type}; $t =~ s/^struct\s+// ; ($_->{type} => 1, $t => 1) } @{ structure_table($self) }; my @missing = (); my %seen; #print Data::Dumper -> Dump ([\%structures, structure_table($self)]) ; for my $name (keys %{ $self->{map} }) { 1 while $name =~ s/^\w+\s+(\w+)/$1/; $name =~ s/\s+\**.*$//; next if $seen{$name}++ or $structures{$name} or $ignore_check{$name}; push @missing, $name; } return @missing ? \@missing : undef; } sub checkmaps { my $self = shift ; my %result ; $result{missing_functions} = $self->{function_map} -> check ; $result{obsolete_functions} = $self->{function_map} -> check_exists ; $result{missing_callbacks} = $self->{callback_map} -> check ; $result{obsolete_callbacks} = $self->{callback_map} -> check_exists ; $result{missing_structures} = $self->{structure_map} -> check ; $result{obsolete_structures} = $self->{structure_map} -> check_exists ; $result{missing_types} = $self-> check ; $result{obsolete_types} = $self-> check_exists ; return \%result ; } sub writemaps { my $self = shift ; my $result = shift ; my $prefix = shift ; $self->{function_map} -> write_map_file ($result -> {missing_functions}, $prefix) ; $self->{callback_map} -> write_map_file ($result -> {missing_callbacks}, $prefix) ; $self->{structure_map} -> write_map_file ($result -> {missing_structures}, $prefix) ; $self -> write_map_file ($result -> {missing_types}) ; } sub write { my ($self, $fh, $newentries) = @_ ; my %types ; foreach my $type (@$newentries) { $type =~ s/\s*(\*\s*)+$// ; $type =~ s/const\s*// ; #$type =~ s/struct\s*// ; $types{$type} = 1 ; } foreach my $type (sort keys %types) { $fh -> print ("$type\t|\n") ; } } #XXX: generate this my %class_pools = map { (my $f = "mpxs_${_}_pool") =~ s/:/_/g; $_, $f; } qw{ Apache::RequestRec Apache::Connection Apache::URI }; sub class_pool : lvalue { my($self, $class) = @_; $class_pools{$class}; } sub h_wrap { my($self, $file, $code) = @_; $file = $self -> {wrapxs} -> h_filename_prefix . $file; my $h_def = uc "${file}_h"; my $preamble = "\#ifndef $h_def\n\#define $h_def\n\n"; my $postamble = "\n\#endif /* $h_def */\n"; return ("$file.h", $preamble . $code . $postamble); } sub typedefs_code { my $self = shift; my $map = $self->get; my %seen; my $file = $self -> {wrapxs} -> h_filename_prefix . 'typedefs'; my $h_def = uc "${file}_h"; my $code = ""; my @includes ; for (@includes, @{ $self->{INCLUDE} }) { $code .= qq{\#include "$_"\n} } for my $t (@{ $self->{typedefs} }) { next if $seen{ $t->[1] }++; my $class = $t->[1] ; $class =~ s/__$// ; $code .= "typedef $t->[0] * $class;\n"; } $code .= "typedef void * PTR;\n"; $code .= "#if PERL_VERSION > 5\n"; $code .= "typedef char * PV;\n"; $code .= "#endif\n"; $code .= "typedef char * PVnull;\n"; $code .= q{ #ifndef pTHX_ #define pTHX_ #endif #ifndef aTHX_ #define aTHX_ #endif #ifndef pTHX #define pTHX #endif #ifndef aTHX #define aTHX #endif #ifndef XSprePUSH #define XSprePUSH (sp = PL_stack_base + ax - 1) #endif } ; $self->h_wrap('typedefs', $code); } sub sv_convert_code { my $self = shift; my $map = $self->get; my %seen; my $cnvprefix = $self -> {wrapxs} -> my_cnv_prefix ; my $typemap_code = $self -> typemap_code ($cnvprefix); my $code = q{ #ifndef aTHX_ /* let it work with 5.005 */ #define aTHX_ #endif } ; while (my($ctype, $t) = each %$map) { my $ptype = $t -> {class} ; next if $self->special($ptype); next if ($ctype =~ /\s/) ; my $class = $ptype; my $tmcode ; $ptype =~ s/:/_/g ; $ptype =~ s/__$// ; $class =~ s/::$// ; next if $seen{$ptype}++; if ($typemap_code -> {$t -> {typemapid}}) { my $alias; my $expect = "expecting an $class derived object"; my $croak = "argument is not a blessed reference"; #Perl -> C my $define = "${cnvprefix}sv2_$ptype"; if ($tmcode = $typemap_code -> {$t -> {typemapid}}{perl2c}) { $code .= "#define $define(sv) " . eval (qq[qq[$tmcode]]) . "\n" ; } else { print "WARNING no convert code for $t -> {typemapid}\n" ; } if ($alias = $t -> {typealiases}[0]) { $code .= "#define ${cnvprefix}sv2_$alias $define\n\n"; } #C -> Perl $define = "${cnvprefix}${ptype}_2obj"; if ($tmcode = $typemap_code -> {$t -> {typemapid}}{c2perl}) { $code .= "#define $define(ptr) " . eval (qq[qq[$tmcode]]) . "\n" ; } else { print "WARNING no convert code for $t -> {typemapid}\n" ; } if ($alias) { $code .= "#define ${cnvprefix}${alias}_2obj $define\n\n"; } #Create $define = "${cnvprefix}${ptype}_create_obj"; if ($tmcode = $typemap_code -> {$t -> {typemapid}}{create}) { $code .= "#define $define(p,sv,rv,alloc) " . eval (qq[qq[$tmcode]]) . "\n" ; } if ($alias) { $code .= "#define ${cnvprefix}${alias}_2obj $define\n\n"; } #Destroy $define = "${cnvprefix}${ptype}_free_obj"; if ($tmcode = $typemap_code -> {$t -> {typemapid}}{destroy}) { $code .= "#define $define(ptr) " . eval (qq[qq[$tmcode]]) . "\n" ; } if ($alias) { $code .= "#define ${cnvprefix}${alias}_2obj $define\n\n"; } } else { if (($ptype =~ /^(\wV)$/) && $ptype ne 'SV') { my $class = $1; my $alias ; #Perl -> C my $define = "${cnvprefix}sv2_$ctype"; $code .= "#define $define(sv) ($ctype)Sv$class(sv)\n\n"; if ($alias = $t -> {typealiases}[0]) { $code .= "#define ${cnvprefix}sv2_$alias $define\n\n"; } #C -> Perl $define = "${cnvprefix}${ctype}_2obj"; my $lcclass = lc($class) ; my $l = $class eq 'PV'?',0':'' ; $code .= "#define $define(v) sv_2mortal(newSV$lcclass(v$l))\n\n"; if ($alias) { $code .= "#define ${cnvprefix}${alias}_2obj $define\n\n"; } } } } $code .= "#define ${cnvprefix}sv2_SV(sv) (sv)\n\n"; $code .= "#define ${cnvprefix}SV_2obj(x) (x)\n\n"; $code .= "#define ${cnvprefix}sv2_SVPTR(sv) (sv)\n\n"; $code .= "#define ${cnvprefix}SVPTR_2obj(x) (x==NULL?&PL_sv_undef:sv_2mortal(SvREFCNT_inc(x)))\n\n"; $code .= "#define ${cnvprefix}sv2_PV(sv) (SvPV(sv, PL_na))\n\n"; $code .= "#define ${cnvprefix}PV_2obj(x) (sv_2mortal(newSVpv(x, 0)))\n\n"; $code .= "#define ${cnvprefix}sv2_PVnull(sv) (SvOK(sv)?SvPV(sv, PL_na):NULL)\n\n"; $code .= "#define ${cnvprefix}PVnull_2obj(x) (x==NULL?&PL_sv_undef:sv_2mortal(newSVpv(x, 0)))\n\n"; $code .= "#define ${cnvprefix}sv2_IV(sv) SvIV(sv)\n\n"; $code .= "#define ${cnvprefix}IV_2obj(x) sv_2mortal(newSViv(x))\n\n"; $code .= "#define ${cnvprefix}sv2_NV(sv) SvNV(sv)\n\n"; $code .= "#define ${cnvprefix}NV_2obj(x) sv_2mortal(newSVnv(x))\n\n"; $code .= "#define ${cnvprefix}sv2_UV(sv) SvUV(sv)\n\n"; $code .= "#define ${cnvprefix}UV_2obj(x) sv_2mortal(newSVuv(x))\n\n"; $code .= "#define ${cnvprefix}sv2_PTR(sv) (SvROK(sv)?((void *)SvIV(SvRV(sv))):NULL)\n\n"; $code .= "#define ${cnvprefix}PTR_2obj(x) (x?newRV_noinc(newSViv ((IV)x)):&PL_sv_undef)\n\n"; $code .= "#define ${cnvprefix}sv2_CHAR(sv) (char)SvNV(sv)\n\n"; $code .= "#define ${cnvprefix}CHAR_2obj(x) sv_2mortal(newSVnv(x))\n\n"; $code .= "#define ${cnvprefix}sv2_AVREF(sv) (AV*)SvRV(sv)\n\n"; $code .= "#define ${cnvprefix}AVREF_2obj(x) (x?sv_2mortal(newRV((SV*)x)):&PL_sv_undef)\n\n"; $code .= "#define ${cnvprefix}sv2_HVREF(sv) (HV*)SvRV(sv)\n\n"; $code .= "#define ${cnvprefix}HVREF_2obj(x) (x?sv_2mortal(newRV((SV*)x)):&PL_sv_undef)\n\n"; $self->h_wrap('sv_convert', $code); } # ============================================================================ # NOTE: 'INPUT' code must not be ended with a ; sub typemap_code { my $self = shift ; my $cnvprefix = shift ; return { 'T_MAGICHASH_SV' => { 'OUTPUT' => ' if ($var -> _perlsv) $arg = $var -> _perlsv ; else $arg = &sv_undef ;', 'c2perl' => '(ptr->_perlsv?ptr->_perlsv:&sv_undef)', 'INPUT' => q[ { MAGIC * mg ; if ((mg = mg_find (SvRV($arg), '~'))) $var = *(($type *)(mg -> mg_ptr)) ; else croak (\"$var is not of type $type\") ; } ], 'perl2c' => q[(SvOK(sv)?((SvROK(sv) && SvMAGICAL(SvRV(sv))) \\\\ || (Perl_croak(aTHX_ "$croak ($expect)"),0) ? \\\\ *(($ctype **)(mg_find (SvRV(sv), '~') -> mg_ptr)) : ($ctype *)NULL):($ctype *)NULL) ], 'create' => q[ sv = (SV *)newHV () ; \\\\ p = alloc ; \\\\ memset (p, 0, sizeof($ctype)) ; \\\\ sv_magic ((SV *)sv, NULL, '~', (char *)&p, sizeof (p)) ; \\\\ rv = p -> _perlsv = newRV_noinc ((SV *)sv) ; \\\\ sv_bless (rv, gv_stashpv ("$class", 0)) ; ], 'destroy' => ' free(ptr)', }, 'T_PTROBJ' => { 'c2perl' => ' sv_setref_pv(sv_newmortal(), "$class", (void*)ptr)', 'perl2c' => q[(SvOK(sv)?((SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVMG)) \\\\ || (Perl_croak(aTHX_ "$croak ($expect)"),0) ? \\\\ ($ctype *)SvIV((SV*)SvRV(sv)) : ($ctype *)NULL):($ctype *)NULL) ], 'create' => q[ rv = newSViv(0) ; \\\\ sv = newSVrv (rv, "$class") ; \\\\ SvUPGRADE(sv, SVt_PVIV) ; \\\\ SvGROW(sv, sizeof (*p)) ; \\\\ p = ($ctype *)SvPVX(sv) ;\\\\ memset(p, 0, sizeof (*p)) ;\\\\ SvIVX(sv) = (IV)p ;\\\\ SvIOK_on(sv) ;\\\\ SvPOK_on(sv) ; ], }, 'T_AVREF' => { 'OUTPUT' => " \$arg = SvREFCNT_inc (${cnvprefix}AVREF_2obj(\$var));", 'INPUT' => " \$var = ${cnvprefix}sv2_AVREF(\$arg)", }, 'T_HVREF' => { 'OUTPUT' => " \$arg = SvREFCNT_inc (${cnvprefix}HVREF_2obj(\$var));", 'INPUT' => " \$var = ${cnvprefix}sv2_HVREF(\$arg)", }, 'T_SVPTR' => { 'OUTPUT' => " \$arg = SvREFCNT_inc (${cnvprefix}SVPTR_2obj(\$var));", 'INPUT' => " \$var = (\$type)${cnvprefix}sv2_SVPTR(\$arg)", }, 'T_PVnull' => { 'OUTPUT' => " \$arg = SvREFCNT_inc (${cnvprefix}PVnull_2obj(\$var));", 'INPUT' => " \$var = (\$type)${cnvprefix}sv2_PVnull(\$arg)", }, }, } 1; __END__ ExtUtils-XSBuilder-0.28/XSBuilder/PODTemplate.pm0000644000000000000000000000335310033174614020101 0ustar rootroot package ExtUtils::XSBuilder::PODTemplate; # -------------------------------------------------------------------------- sub new { my $class = shift ; my $self = {} ; bless $self, $class ; return $self ; } # -------------------------------------------------------------------------- sub since_default { undef } ; # -------------------------------------------------------------------------- sub gen_pod_head { my ($self, $module) = @_ ; qq{ =head1 NAME $module =head1 FUNCTIONS } ; } # -------------------------------------------------------------------------- sub gen_pod_func { my ($self, $objclass, $obj, $method, $args, $retclass, $ret, $comment, $since) = @_ ; my $argnames = join (',', map { $_ -> {name} } @{$args}[($objclass?1:0)..$#$args]) ; my $rettext = $retclass?'$ret = ':'' ; my $objtext = $objclass?"$obj -> ":'' ; my $data = qq{ =head2 \@func: $method() $rettext$objtext $method($argnames) =over 4 } ; foreach $arg (@$args) { $data .= qq{ =item \@param: $arg->{class} $arg->{name} $arg->{comment} } ; } if ($retclass) { $data .= qq{ =item \@ret: $retclass $retcomment } ; } $data .= qq{ =item \@since: $since =back $comment } ; return $data ; } # -------------------------------------------------------------------------- sub gen_pod_struct_member { my ($self, $objclass, $obj, $memberclass, $member, $comment, $since) = @_ ; qq{ =head2 \@func: $member() \$val = $obj -> $member(\$newval) =over 4 =item \@param: $objclass $obj =item \@param: $memberclass \$newval } . ($since?"=item \@since: $since\n\n":'') . qq{ =back $comment } ; } 1; ExtUtils-XSBuilder-0.28/XSBuilder/WrapXS.pm0000644000000000000000000016051510305234424017151 0ustar rootrootpackage 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__ ExtUtils-XSBuilder-0.28/XSBuilder/FunctionMap.pm0000755000000000000000000001321110276663153020215 0ustar rootrootpackage ExtUtils::XSBuilder::FunctionMap; use strict; use warnings FATAL => 'all'; use ExtUtils::XSBuilder::MapUtil qw(function_table structure_table); use Data::Dumper ; our @ISA = qw(ExtUtils::XSBuilder::MapBase); sub new { my $class = shift; bless {wrapxs => shift}, $class; } #for adding to function.map sub generate { my $self = shift; my $missing = $self->check; return unless $missing; print " $_\n" for @$missing; } sub disabled { shift->{disabled} } #look for functions that do not exist in *.map sub check { my $self = shift; my $map = $self->get; my @missing; my $parsesource = $self -> {wrapxs} -> parsesource_objects ; loop: for my $name (map $_->{name}, @{ function_table($self -> {wrapxs}) }) { next if exists $map->{$name}; #foreach my $obj (@$parsesource) # { # next loop if ($obj -> handle_func ($name)) ; # } push @missing, $name ; } return @missing ? \@missing : undef; } #look for functions in *.map that do not exist my $special_name = qr{(^DEFINE_|DESTROY$)}; sub check_exists { my $self = shift; my %functions = map { $_->{name}, 1 } @{ function_table($self -> {wrapxs}) }; my @missing = (); for my $name (keys %{ $self->{map} }) { next if $functions{$name}; push @missing, $name unless $name =~ $special_name; } return @missing ? \@missing : undef; } my $keywords = join '|', qw(MODULE PACKAGE PREFIX BOOT); sub class_c_prefix { my $self = shift; my $class = shift; $class =~ s/:/_/g; $class; } sub class_xs_prefix { my $self = shift; my $class = shift; my $class_prefix = $self -> class_c_prefix($class); return $self -> {wrapxs} -> my_xs_prefix . $class_prefix . '_' ; } sub needs_prefix { my $self = shift; my $name = shift; $self -> {wrapxs} -> needs_prefix ($name) ; } sub make_prefix { my($self, $name, $class) = @_; my $class_prefix = $self -> class_xs_prefix($class); return $name if $name =~ /^$class_prefix/; $class_prefix . $name; } sub guess_prefix { my $self = shift; my $entry = shift; my($name, $class) = ($entry->{name}, $entry->{class}); my $prefix = ""; my $myprefix = $self -> {wrapxs} -> my_xs_prefix ; $name =~ s/^DEFINE_//; $name =~ s/^$myprefix//i; (my $guess = lc($entry->{class} || $entry->{module}) . '_') =~ s/::/_/g; $guess =~ s/(apache)_/($1|ap)_{1,2}/; if ($name =~ s/^($guess).*/$1/i) { $prefix = $1; } else { if ($name =~ /^(apr?_)/) { $prefix = $1; } } #print "GUESS prefix=$guess, name=$entry->{name} -> $prefix\n"; return $prefix; } sub parse { my($self, $fh, $map) = @_; my %cur; my $disabled = 0; while ($fh->readline) { if (/($keywords)=/o) { $disabled = s/^\W//; #module is disabled my %words = $self->parse_keywords($_); if ($words{MODULE}) { %cur = (); } if ($words{PACKAGE}) { delete $cur{CLASS}; } for (keys %words) { $cur{$_} = $words{$_}; } next; } my($name, $dispatch, $argspec, $alias) = split /\s*\|\s*/; my $dispatch_argspec = '' ; if ($dispatch && ($dispatch =~ m#\s*(.*?)\s*\((.*)\)#)) { $dispatch = $1; $dispatch_argspec = $2; } my $return_type; if ($name =~ s/^([^:]+)://) { $return_type = $1; } if ($name =~ s/^(\W)// or not $cur{MODULE} or $disabled) { #notimplemented or cooked by hand $map->{$name} = undef; push @{ $self->{disabled}->{ $1 || '!' } }, $name; next; } if (my $package = $cur{PACKAGE}) { unless ($package eq 'guess') { $cur{CLASS} = $package; } if ($cur{ISA}) { $self->{isa}->{ $cur{MODULE} }->{$package} = delete $cur{ISA}; } if ($cur{BOOT}) { $self->{boot}->{ $cur{MODULE} } = delete $cur{BOOT}; } } else { $cur{CLASS} = $cur{MODULE}; } if ($name =~ /^DEFINE_/ and $cur{CLASS}) { $name =~ s{^(DEFINE_)(.*)} {$1 . $self->make_prefix($2, $cur{CLASS})}e; print "DEFINE $name arg=$argspec\n" ; } my $entry = $map->{$name} = { name => $alias || $name, dispatch => $dispatch, dispatch_argspec => $dispatch_argspec, argspec => $argspec ? [split /\s*,\s*/, $argspec] : "", return_type => $return_type, alias => $alias, }; for (keys %cur) { $entry->{lc $_} = $cur{$_}; } #avoid 'use of uninitialized value' warnings $entry->{$_} ||= "" for keys %{ $entry }; if ($entry->{dispatch} =~ /_$/) { $entry->{dispatch} .= $name; } } } sub get { my $self = shift; $self->{map} ||= $self->parse_map_files; } sub prefixes { my $self = shift; $self = ExtUtils::XSBuilder::FunctionMap->new unless ref $self; my $map = $self->get; my %prefix; while (my($name, $ent) = each %$map) { next unless $ent->{prefix}; $prefix{ $ent->{prefix} }++; } $prefix{$_} = 1 for qw(ap_ apr_); #make sure we get these [keys %prefix] } sub write { my ($self, $fh, $newentries, $prefix) = @_ ; foreach (@$newentries) { $fh -> print ($prefix, $self -> {wrapxs} -> mapline_func ($_), "\n") ; } } 1; __END__ ExtUtils-XSBuilder-0.28/XSBuilder/ParseSource.pm0000755000000000000000000003547610302415757020241 0ustar rootrootpackage ExtUtils::XSBuilder::ParseSource; use strict; use vars qw{$VERSION $verbose} ; use Config (); use Data::Dumper ; use Carp; use Parse::RecDescent; use File::Path qw(mkpath); use ExtUtils::XSBuilder::C::grammar ; $VERSION = '0.03'; $verbose = 1 ; =pod =head1 NAME ExtUtils::XSBuilder::ParseSource - parse C source files =head2 DESCRIPTION For more information, see L =cut # ============================================================================ sub new { my $class = shift; my $self = bless { @_, }, $class; $self; } # ============================================================================ =pod =head2 extent_parser (o) Allows the user to call the Extent or Replace method of the parser to add new syntax rules. This is mainly useful to include expansions for preprocessor macros. =cut sub extent_parser { } # ============================================================================ =pod =head2 preprocess (o) Allows the user to preprocess the source before it is given to the parser. You may modify the source, which is given as first argument in place. =cut sub preprocess { } # ============================================================================ sub parse { my $self = shift; $self -> find_includes ; my $c = $self -> {c} = {} ; print "Initialize parser\n" if ($verbose) ; my $grammar = ExtUtils::XSBuilder::C::grammar::grammar() or croak "Can't find C grammar\n"; $::RD_HINT++; my $parser = $self -> {parser} = Parse::RecDescent->new($grammar); $parser -> {data} = $c ; $parser -> {srcobj} = $self ; $self -> extent_parser ($parser) ; foreach my $inc (@{$self->{includes}}) { print "scan $inc ...\n" if ($verbose) ; $self->scan ($inc) ; } } # ============================================================================ sub scan { my ($self, $filename) = @_ ; my $txt ; { local $/ = undef ; open FH, $filename or die "Cannot open $filename ($!)" ; $txt = ; close FH ; } local $SIG{__DIE__} = \&Carp::confess; $self -> {parser} -> {srcfilename} = $filename ; $self -> preprocess ($txt) ; return $self -> {parser}->code($txt) or die "Cannot parse $filename" ; } # ============================================================================ sub DESTROY { my $self = shift; unlink $self->{scan_filename} } # ============================================================================ =pod =head2 include_dirs (o) Returns a reference to the list of directories that should be searched for include files which contain the functions, structures, etc. to be extracted. Default: C<'.'> =cut sub include_dirs { my $self = shift; ['.'], } # ============================================================================ =pod =head2 include_paths (o) Returns a reference to a list of directories that are given as include directories to the C compiler. This is mainly used to strip these directories from filenames to convert absolute paths to relative paths. Default: empty list (C<[]>) =cut sub include_paths { my $self = shift; [], } # ============================================================================ =pod =head2 unwanted_includes (o) Returns a reference to a list of include files that should not be processed. Default: empty list (C<[]>) =cut sub unwanted_includes { [] } # ============================================================================ =pod =head2 sort_includes (o, include_list) Passed an array ref of include files, it allows the user to define the sort order, so includes are processed correctly. Default: return the passed array reference. =cut sub sort_includes { return $_[1] ; } # ============================================================================ =pod =head2 find_includes (o) Returns a list of include files to be processed. Default: search directories given by C for all files and build a list of include files. All files starting with a word matched by C are not included in the list. =cut sub find_includes { my $self = shift; return $self->{includes} if $self->{includes}; require File::Find; my(@dirs) = $self->include_dirs; unless (-d $dirs[0]) { die "could not find include directory"; } print "Will search @dirs for include files...\n" if ($verbose) ; my @includes; my $unwanted = join '|', @{$self -> unwanted_includes} ; for my $dir (@dirs) { File::Find::finddepth({ wanted => sub { return unless /\.h$/; return if ($unwanted && (/^($unwanted)/o)); my $dir = $File::Find::dir; push @includes, "$dir/$_"; }, follow => $^O ne 'MSWin32', }, $dir); } return $self->{includes} = $self -> sort_includes (\@includes) ; } # ============================================================================ =pod =head2 handle_define (o) Passed a hash ref with the definition of a define, may modify it. Return false to discard it, return true to keep it. Default: C<1> =cut sub handle_define { 1 } ; # ============================================================================ =pod =head2 handle_enum (o) Passed a hash ref with the definition of a enum value, may modify it. Return false to discard it, return true to keep it. Default: C<1> =cut sub handle_enum { 1 } ; # ============================================================================ =pod =head2 handle_struct (o) Passed a hash ref with the definition of a struct, may modify it. Return false to discard it, return true to keep it. Default: C<1> =cut sub handle_struct { 1 } ; # ============================================================================ =pod =head2 handle_function (o) Passed a hash ref with the definition of a function, may modify it. Return false to discard it, return true to keep it. Default: C<1> =cut sub handle_function { 1 } ; # ============================================================================ =pod =head2 handle_callback (o) Passed a hash ref with the definition of a callback, may modify it. Return false to discard it, return true to keep it. Default: C<1> =cut sub handle_callback { 1 } ; # ============================================================================ sub get_constants { my($self) = @_; my $includes = $self->find_includes; my(%constants, %seen); my $defines_wanted_re = $self -> defines_wanted_re ; my $defines_wanted = $self -> defines_wanted ; my $defines_unwanted = $self -> defines_unwanted ; my $enums_wanted = $self -> enums_wanted ; my $enums_unwanted = $self -> enums_unwanted ; for my $file (@$includes) { open my $fh, $file or die "open $file: $!"; while (<$fh>) { if (s/^\#define\s+(\w+)\s+.*/$1/) { chomp; next if /_H$/; next if $seen{$_}++; $self->handle_constant(\%constants, $defines_wanted_re, $defines_wanted, $defines_unwanted); } elsif (m/enum[^\{]+\{/) { $self->handle_enum($fh, \%constants, $enums_wanted, $enums_unwanted); } } close $fh; } return \%constants; } # ============================================================================ sub get_constants { my $self = shift; my $key = 'parsed_constants'; return $self->{$key} if $self->{$key}; my $c = $self->{$key} = $self->{c}{constants} ||= [] ; # sort the constants by the 'name' attribute to ensure a # consistent output on different systems. $self->{$key} = [sort { $a->{name} cmp $b->{name} } @{$self->{$key}}]; } # ============================================================================ sub get_functions { my $self = shift; my $key = 'parsed_fdecls'; return $self->{$key} if $self->{$key}; my $c = $self->{c}{functions} ||= [] ; # sort the functions by the 'name' attribute to ensure a # consistent output on different systems. $self->{$key} = [sort { $a->{name} cmp $b->{name} } @$c]; } # ============================================================================ sub get_structs { my $self = shift; my $key = 'typedef_structs'; return $self->{$key} if $self->{$key}; my $c = $self->{c}{structures} ||= [] ; # sort the structs by the 'type' attribute to ensure a consistent # output on different systems. $self->{$key} = [sort { $a->{type} cmp $b->{type} } @$c]; } # ============================================================================ sub get_callbacks { my $self = shift; my $key = 'typedef_callbacks'; return $self->{$key} if $self->{$key}; my $c = $self->{c}{callbacks} ||= [] ; # sort the callbacks by the 'type' attribute to ensure a consistent # output on different systems. $self->{$key} = [sort { $a->{type} cmp $b->{type} } @$c]; } # ============================================================================ =pod =head2 package (o) Return package name for tables Default: C<'MY'> =cut sub package { 'MY' } # ============================================================================ =pod =head2 targetdir (o) Return name of target directory where to write tables Default: C<'./xsbuilder/tables'> =cut sub targetdir { './xsbuilder/tables' } # ============================================================================ sub write_functions_pm { my $self = shift; my $file = shift || 'FunctionTable.pm'; my $name = shift || $self -> package . '::FunctionTable'; $self->write_pm($file, $name, $self->get_functions); } # ============================================================================ sub write_structs_pm { my $self = shift; my $file = shift || 'StructureTable.pm'; my $name = shift || $self -> package . '::StructureTable'; $self->write_pm($file, $name, $self->get_structs); } # ============================================================================ sub write_constants_pm { my $self = shift; my $file = shift || 'ConstantsTable.pm'; my $name = shift || $self -> package . '::ConstantsTable'; $self->write_pm($file, $name, $self->get_constants); } # ============================================================================ sub write_callbacks_pm { my $self = shift; my $file = shift || 'CallbackTable.pm'; my $name = shift || $self -> package . '::CallbackTable'; $self->write_pm($file, $name, $self->get_callbacks); } # ============================================================================ sub pm_path { my($self, $file, $name, $create) = @_; my @parts = split '::', ($name || $self -> package . '::X') ; my($subdir) = join ('/', @parts[0..$#parts-1]) ; my $tdir = $self -> targetdir ; if (!-d "$tdir/$subdir") { if ($create) { mkpath ("$tdir/$subdir", 0, 0755) or die "Cannot create directory $tdir/$subdir ($!)" ; } else { die "Missing directory $tdir/$subdir" ; } } return "$tdir/$subdir/$file"; } # ============================================================================ sub write_pm { my($self, $file, $name, $data) = @_; require Data::Dumper; local $Data::Dumper::Indent = 1; $data ||= [] ; $file = $self -> pm_path ($file, $name, 1) ; # sort the hashes (including nested ones) for a consistent dump canonsort(\$data); my $dump = Data::Dumper->new([$data], [$name])->Dump; my $package = ref($self) || $self; my $version = $self->VERSION; my $date = scalar localtime; my $new_content = << "EOF"; package $name; # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! # ! WARNING: generated by $package/$version # ! $date # ! do NOT edit, any changes will be lost ! # !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! $dump 1; EOF my $old_content = ''; if (-e $file) { open PM, "<$file" or die "open $file: $!"; local $/ = undef; # slurp the file $old_content = ; close PM; } my $overwrite = 1; if ($old_content) { # strip the date line, which will never be the same before # comparing my $table_header = qr{^\#\s!.*}; (my $old = $old_content) =~ s/$table_header//mg; (my $new = $new_content) =~ s/$table_header//mg; $overwrite = 0 if $old eq $new; } if ($overwrite) { open PM, ">$file" or die "open $file: $!"; print PM $new_content; close PM; } } # ============================================================================ # # canonsort(\$data); # sort nested hashes in the data structure. # the data structure itself gets modified # sub canonsort { my $ref = shift; my $type = ref $$ref; return unless $type; require Tie::IxHash; my $data = $$ref; if ($type eq 'ARRAY') { for my $d (@$data) { canonsort(\$d); } } elsif ($type eq 'HASH') { for my $d (keys %$data) { canonsort(\$data->{$d}); } tie my %ixhash, 'Tie::IxHash'; # reverse sort so we get the order of: # return_type, name, args { type, name } for functions # type, elts { type, name } for structures for (sort { $b cmp $a } keys %$data) { $ixhash{$_} = $data->{$_}; } $$ref = \%ixhash; } } # ============================================================================ =pod =head2 run Call this class method to parse your source. Before you can do so you must provide a class that overrides the defaults in L. After that you scan the source files with MyClass -> run ; =cut sub run { my ($class) = @_ ; my $p = $class -> new() ; $p -> parse ; $p -> write_constants_pm ; $p -> write_functions_pm ; $p -> write_structs_pm ; $p -> write_callbacks_pm ; } 1; __END__ ExtUtils-XSBuilder-0.28/XSBuilder/MapUtil.pm0000644000000000000000000001320407421045511017332 0ustar rootrootpackage ExtUtils::XSBuilder::MapUtil; use strict; use warnings; use Exporter (); use Data::Dumper ; use IO::Handle ; use ExtUtils::XSBuilder::TypeMap ; our @EXPORT_OK = qw(list_first disabled_reason function_table structure_table callback_table callback_hash ); our @ISA = qw(Exporter); my %disabled_map = ( '!' => 'disabled or not yet implemented', '~' => 'implemented but not auto-generated', '-' => 'likely never be available to Perl', '>' => '"private" to apache', '?' => 'unclassified', '+' => 'automaticly added', ); # ============================================================================ my $function_table = []; sub function_table { return $function_table if @$function_table; my $parsesource = shift -> parsesource_objects ; $function_table = [] ; foreach my $src (@$parsesource) { require $src -> pm_path ('FunctionTable.pm') ; no strict ; push @$function_table, @${$src -> package . '::FunctionTable'} ; use strict ; } return $function_table; } # ============================================================================ my $callback_table = []; sub callback_table { return $callback_table if @$callback_table; my $parsesource = shift -> parsesource_objects ; $callback_table = [] ; foreach my $src (@$parsesource) { require $src -> pm_path ('CallbackTable.pm') ; no strict ; push @$callback_table, @${$src -> package . '::CallbackTable'} ; use strict ; } return $callback_table; } # ============================================================================ my $callback_hash ; sub callback_hash { return $callback_hash if $callback_hash ; my %callbacks = map { $_->{name}, $_ } @{ callback_table(shift) }; $callback_hash = \%callbacks ; } # ============================================================================ my $structure_table = []; sub structure_table { return $structure_table if @$structure_table; $structure_table = [] ; my $parsesource = shift -> parsesource_objects ; foreach my $src (@$parsesource) { require $src -> pm_path ('StructureTable.pm') ; no strict ; push @$structure_table, @${$src -> package . '::StructureTable'} ; use strict ; } return $structure_table; } # ============================================================================ sub disabled_reason { $disabled_map{+shift} || 'unknown'; } # ============================================================================ sub list_first (&@) { my $code = shift; for (@_) { return $_ if $code->(); } undef; } # ============================================================================ package ExtUtils::XSBuilder::MapBase; *function_table = \&ExtUtils::XSBuilder::function_table; *structure_table = \&ExtUtils::XSBuilder::structure_table; sub readline { my $fh = shift; while (<$fh>) { chomp; s/^\s+//; s/\s+$//; s/^\#.*//; s/\s*\#.*//; next unless $_; if (s:\\$::) { my $cur = $_; $_ = $cur . $fh->readline; return $_; } return $_; } } my $map_classes = join '|', qw(type structure function callback); sub map_files { my $self = shift; my $package = ref($self) || $self; my($wanted) = $package =~ /($map_classes)/io; my(@dirs) = ($self -> {wrapxs} -> xs_map_dir(), $self -> {wrapxs} -> xs_glue_dirs()); my @files; my @searchdirs = map { -d "$_/maps" ? "$_/maps" : $_ } @dirs ; for my $dir (@searchdirs) { opendir my $dh, $dir or warn "opendir $dir: $!"; for (readdir $dh) { next unless /\.map$/; my $file = "$dir/$_"; if ($wanted) { next unless $file =~ /$wanted/i; } #print "$package => $file\n"; push @files, $file; } closedir $dh; } print 'WARNING: No *_' . lc($wanted) . ".map file found in @searchdirs\n" if (!@files) ; return @files; } sub new_map_file { my $self = shift; my $package = ref($self) || $self; my($wanted) = $package =~ /($map_classes)/io; my(@dirs) = ($self -> {wrapxs} -> xs_map_dir(), $self -> {wrapxs} -> xs_glue_dirs()); my @files; my @searchdirs = map { -d "$_/maps" ? "$_/maps" : $_ } @dirs ; if (!@searchdirs) { print "WARNING: No maps directory found\n" ; return undef ; } return $searchdirs[0] . '/new_' . lc($wanted) . '.map' ; } sub parse_keywords { my($self, $line) = @_; my %words; for my $pair (split /\s+/, $line) { my($key, $val) = split /=/, $pair; unless ($key and $val) { die "parse error ($ExtUtils::XSBuilder::MapFile line $.)"; } $words{$key} = $val; } %words; } sub parse_map_files { my($self) = @_; my $map = {}; for my $file (map_files($self)) { print "Parse $file...\n" ; open my $fh, $file or die "open $file: $!"; local $ExtUtils::XSBuilder::MapFile = $file; bless $fh, __PACKAGE__; $self->parse($fh, $map); close $fh; } return $map; } sub write_map_file { my($self, $newentries, $prefix) = @_; return if (!$newentries || !@$newentries) ; my $file = $self -> new_map_file or die ; print "Write $file...\n" ; open my $fh, '>>', $file or die "open $file: $!"; local $ExtUtils::XSBuilder::MapFile = $file; #bless $fh, __PACKAGE__; $fh -> print ( "\n### Added " . scalar(localtime) . " ###\n\n" ); $self->write($fh, $newentries, $prefix); close $fh; } 1; __END__ ExtUtils-XSBuilder-0.28/MANIFEST0000755000000000000000000000057710276351754014740 0ustar rootrootREADME MANIFEST Changes Makefile.PL test.pl XSBuilder/CallbackMap.pm XSBuilder/FunctionMap.pm XSBuilder/MapUtil.pm XSBuilder/ParseSource.pm XSBuilder/StructureMap.pm XSBuilder/TypeMap.pm XSBuilder/WrapXS.pm XSBuilder/PODTemplate.pm XSBuilder/C/grammar.pm XSBuilder.pm XSBuilder.pod xsbuilder.osc2002.pod META.yml Module meta-data (added by MakeMaker)