FFI-Platypus-0.47000755001750001750 013065045605 13640 5ustar00ollisgollisg000000000000README100644001750001750 15217713065045605 14656 0ustar00ollisgollisg000000000000FFI-Platypus-0.47NAME FFI::Platypus - Write Perl bindings to non-Perl libraries with FFI. No XS required. VERSION version 0.47 SYNOPSIS use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib(undef); # search libc # call dynamically $ffi->function( puts => ['string'] => 'int' )->call("hello world"); # attach as a xsub and call (much faster) $ffi->attach( puts => ['string'] => 'int' ); puts("hello world"); DESCRIPTION Platypus is a library for creating interfaces to machine code libraries written in languages like C, C++, Fortran, Rust, Pascal. Essentially anything that gets compiled into machine code. This implementation uses libffi to accomplish this task. libffi is battle tested by a number of other scripting and virtual machine languages, such as Python and Ruby to serve a similar role. There are a number of reasons why you might want to write an extension with Platypus instead of XS: FFI / Platypus does not require messing with the guts of Perl XS is less of an API and more of the guts of perl splayed out to do whatever you want. That may at times be very powerful, but it can also be a frustrating exercise in hair pulling. FFI / Platypus is portable Lots of languages have FFI interfaces, and it is subjectively easier to port an extension written in FFI in Perl or another language to FFI in another language or Perl. One goal of the Platypus Project is to reduce common interface specifications to a common format like JSON that could be shared between different languages. FFI / Platypus could be a bridge to Perl 6 One of those "other" languages could be Perl 6 and Perl 6 already has an FFI interface I am told. FFI / Platypus can be reimplemented In a bright future with multiple implementations of Perl 5, each interpreter will have its own implementation of Platypus, allowing extensions to be written once and used on multiple platforms, in much the same way that Ruby-FFI extensions can be use in Ruby, JRuby and Rubinius. FFI / Platypus is pure perl (sorta) One Platypus script or module works on any platform where the libraries it uses are available. That means you can deploy your Platypus script in a shared filesystem where they may be run on different platforms. It also means that Platypus modules do not need to be installed in the platform specific Perl library path. FFI / Platypus is not C or C++ centric XS is implemented primarily as a bunch of C macros, which requires at least some understanding of C, the C pre-processor, and some C++ caveats (since on some platforms Perl is compiled and linked with a C++ compiler). Platypus on the other hand could be used to call other compiled languages, like Fortran, Rust, Pascal, C++, or even assembly, allowing you to focus on your strengths. FFI / Platypus does not require a parser Inline isolates the extension developer from XS to some extent, but it also requires a parser. The various Inline language bindings are a great technical achievement, but I think writing a parser for every language that you want to interface with is a bit of an anti-pattern. This document consists of an API reference, a set of examples, some support and development (for contributors) information. If you are new to Platypus or FFI, you may want to skip down to the EXAMPLES to get a taste of what you can do with Platypus. Platypus has extensive documentation of types at FFI::Platypus::Type and its custom types API at FFI::Platypus::API. CONSTRUCTORS new my $ffi = FFI::Platypus->new(%options); Create a new instance of FFI::Platypus. Any types defined with this instance will be valid for this instance only, so you do not need to worry about stepping on the toes of other CPAN FFI / Platypus Authors. Any functions found will be out of the list of libraries specified with the lib attribute. options lib Either a pathname (string) or a list of pathnames (array ref of strings) to pre-populate the lib attribute. ignore_not_found [version 0.15] Set the ignore_not_found attribute. lang [version 0.18] Set the lang attribute. ATTRIBUTES lib $ffi->lib($path1, $path2, ...); my @paths = $ffi->lib; The list of libraries to search for symbols in. The most portable and reliable way to find dynamic libraries is by using FFI::CheckLib, like this: use FFI::CheckLib 0.06; $ffi->lib(find_lib_or_die lib => 'archive'); # finds libarchive.so on Linux # libarchive.bundle on OS X # libarchive.dll (or archive.dll) on Windows # cygarchive-13.dll on Cygwin # ... # and will die if it isn't found FFI::CheckLib has a number of options, such as checking for specific symbols, etc. You should consult the documentation for that module. As a special case, if you add undef as a "library" to be searched, Platypus will also search the current process for symbols. This is mostly useful for finding functions in the standard C library, without having to know the name of the standard c library for your platform (as it turns out it is different just about everywhere!). You may also use the "find_lib" method as a shortcut: $ffi->find_lib( lib => 'archive' ); ignore_not_found [version 0.15] $ffi->ignore_not_found(1); my $ignore_not_found = $ffi->ignore_not_found; Normally the attach and function methods will throw an exception if it cannot find the name of the function you provide it. This will change the behavior such that function will return undef when the function is not found and attach will ignore functions that are not found. This is useful when you are writing bindings to a library and have many optional functions and you do not wish to wrap every call to function or attach in an eval. lang [version 0.18] $ffi->lang($language); Specifies the foreign language that you will be interfacing with. The default is C. The foreign language specified with this attribute changes the default native types (for example, if you specify Rust, you will get i32 as an alias for sint32 instead of int as you do with C). If the foreign language plugin supports it, this will also enable Platypus to find symbols using the demangled names (for example, if you specify CPP for C++ you can use method names like Foo::get_bar() with "attach" or "function". METHODS type $ffi->type($typename); $ffi->type($typename => $alias); Define a type. The first argument is the native or C name of the type. The second argument (optional) is an alias name that you can use to refer to this new type. See FFI::Platypus::Type for legal type definitions. Examples: $ffi->type('sint32'); # oly checks to see that sint32 is a valid type $ffi->type('sint32' => 'myint'); # creates an alias myint for sint32 $ffi->type('bogus'); # dies with appropriate diagnostic custom_type $ffi->custom_type($alias => { native_type => $native_type, native_to_perl => $coderef, perl_to_native => $coderef, perl_to_native_post => $coderef, }); Define a custom type. See FFI::Platypus::Type#Custom-Types for details. load_custom_type $ffi->load_custom_type($name => $alias, @type_args); Load the custom type defined in the module $name, and make an alias $alias. If the custom type requires any arguments, they may be passed in as @type_args. See FFI::Platypus::Type#Custom-Types for details. If $name contains :: then it will be assumed to be a fully qualified package name. If not, then FFI::Platypus::Type:: will be prepended to it. types my @types = $ffi->types; my @types = FFI::Platypus->types; Returns the list of types that FFI knows about. This will include the native libffi types (example: sint32, opaque and double) and the normal C types (example: unsigned int, uint32_t), any types that you have defined using the type method, and custom types. The list of types that Platypus knows about varies somewhat from platform to platform, FFI::Platypus::Type includes a list of the core types that you can always count on having access to. It can also be called as a class method, in which case, no user defined or custom types will be included in the list. type_meta my $meta = $ffi->type_meta($type_name); my $meta = FFI::Platypus->type_meta($type_name); Returns a hash reference with the meta information for the given type. It can also be called as a class method, in which case, you won't be able to get meta data on user defined types. The format of the meta data is implementation dependent and subject to change. It may be useful for display or debugging. Examples: my $meta = $ffi->type_meta('int'); # standard int type my $meta = $ffi->type_meta('int[64]'); # array of 64 ints $ffi->type('int[128]' => 'myintarray'); my $meta = $ffi->type_meta('myintarray'); # array of 128 ints function my $function = $ffi->function($name => \@argument_types => $return_type); my $function = $ffi->function($address => \@argument_types => $return_type); Returns an object that is similar to a code reference in that it can be called like one. Caveat: many situations require a real code reference, so at the price of a performance penalty you can get one like this: my $function = $ffi->function(...); my $coderef = sub { $function->(@_) }; It may be better, and faster to create a real Perl function using the attach method. In addition to looking up a function by name you can provide the address of the symbol yourself: my $address = $ffi->find_symbol('my_functon'); my $function = $ffi->function($address => ...); Under the covers, function uses find_symbol when you provide it with a name, but it is useful to keep this in mind as there are alternative ways of obtaining a functions address. Example: a C function could return the address of another C function that you might want to call, or modules such as FFI::TinyCC produce machine code at runtime that you can call from Platypus. Examples: my $function = $ffi->function('my_function_name', ['int', 'string'] => 'string'); my $return_string = $function->(1, "hi there"); attach $ffi->attach($name => \@argument_types => $return_type); $ffi->attach([$c_name => $perl_name] => \@argument_types => $return_type); $ffi->attach([$address => $perl_name] => \@argument_types => $return_type); $ffi->attach($name => \@argument_types => $return_type, sub { ... }); $ffi->attach([$c_name => $perl_name] => \@argument_types => $return_type, sub { ... }); $ffi->attach([$address => $perl_name] => \@argument_types => $return_type, sub { ... }); Find and attach a C function as a real live Perl xsub. The advantage of attaching a function over using the function method is that it is much much much faster since no object resolution needs to be done. The disadvantage is that it locks the function and the FFI::Platypus instance into memory permanently, since there is no way to deallocate an xsub. If just one $name is given, then the function will be attached in Perl with the same name as it has in C. The second form allows you to give the Perl function a different name. You can also provide an address (the third form), just like with the function method. Examples: $ffi->attach('my_functon_name', ['int', 'string'] => 'string'); $ffi->attach(['my_c_functon_name' => 'my_perl_function_name'], ['int', 'string'] => 'string'); my $string1 = my_function_name($int); my $string2 = my_perl_function_name($int); [version 0.20] If the last argument is a code reference, then it will be used as a wrapper around the attached xsub. The first argument to the wrapper will be the inner xsub. This can be used if you need to verify/modify input/output data. Examples: $ffi->attach('my_function', ['int', 'string'] => 'string', sub { my($my_function_xsub, $integer, $string) = @_; $integer++; $string .= " and another thing"; my $return_string = $my_function_xsub->($integer, $string); $return_string =~ s/Belgium//; # HHGG remove profanity $return_string; }); closure my $closure = $ffi->closure($coderef); Prepares a code reference so that it can be used as a FFI closure (a Perl subroutine that can be called from C code). For details on closures, see FFI::Platypus::Type#Closures. cast my $converted_value = $ffi->cast($original_type, $converted_type, $original_value); The cast function converts an existing $original_value of type $original_type into one of type $converted_type. Not all types are supported, so care must be taken. For example, to get the address of a string, you can do this: my $address = $ffi->cast('string' => 'opaque', $string_value); Something that won't work is trying to cast an array to anything: my $address = $ffi->cast('int[10]' => 'opaque', \@list); # WRONG attach_cast $ffi->attach_cast("cast_name", $original_type, $converted_type); my $converted_value = cast_name($original_value); This function attaches a cast as a permanent xsub. This will make it faster and may be useful if you are calling a particular cast a lot. sizeof my $size = $ffi->sizeof($type); Returns the total size of the given type in bytes. For example to get the size of an integer: my $intsize = $ffi->sizeof('int'); # usually 4 my $longsize = $ffi->sizeof('long'); # usually 4 or 8 depending on platform You can also get the size of arrays my $intarraysize = $ffi->sizeof('int[64]'); # usually 4*64 my $intarraysize = $ffi->sizeof('long[64]'); # usually 4*64 or 8*64 # depending on platform Keep in mind that "pointer" types will always be the pointer / word size for the platform that you are using. This includes strings, opaque and pointers to other types. This function is not very fast, so you might want to save this value as a constant, particularly if you need the size in a loop with many iterations. alignof [version 0.21] my $align = $ffi->alignof($type); Returns the alignment of the given type in bytes. find_lib [version 0.20] $ffi->find_lib( lib => $libname ); This is just a shortcut for calling FFI::CheckLib#find_lib and updating the "lib" attribute appropriately. Care should be taken though, as this method simply passes its arguments to FFI::CheckLib#find_lib, so if your module or script is depending on a specific feature in FFI::CheckLib then make sure that you update your prerequisites appropriately. find_symbol my $address = $ffi->find_symbol($name); Return the address of the given symbol (usually function). package [version 0.15] $ffi->package($package, $file); # usually __PACKAGE__ and __FILE__ can be used $ffi->package; # autodetect If you have used Module::Build::FFI to bundle C code with your distribution, you can use this method to tell the FFI::Platypus instance to look for symbols that came with the dynamic library that was built when your distribution was installed. abis my $href = $ffi->abis; my $href = FFI::Platypus->abis; Get the legal ABIs supported by your platform and underlying implementation. What is supported can vary a lot by CPU and by platform, or even between 32 and 64 bit on the same CPU and platform. They keys are the "ABI" names, also known as "calling conventions". The values are integers used internally by the implementation to represent those ABIs. abi $ffi->abi($name); Set the ABI or calling convention for use in subsequent calls to "function" or "attach". May be either a string name or integer value from the "abis" method above. EXAMPLES Here are some examples. These examples are provided in full with the Platypus distribution in the "examples" directory. There are also some more examples in FFI::Platypus::Type that are related to types. Integer conversions use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->attach(puts => ['string'] => 'int'); $ffi->attach(atoi => ['string'] => 'int'); puts(atoi('56')); Discussion: puts and atoi should be part of the standard C library on all platforms. puts prints a string to standard output, and atoi converts a string to integer. Specifying undef as a library tells Platypus to search the current process for symbols, which includes the standard c library. libnotify use FFI::CheckLib; use FFI::Platypus; # NOTE: I ported this from the like named eg/notify.pl that came with FFI::Raw # and it seems to work most of the time, but also seems to SIGSEGV sometimes. # I saw the same behavior in the FFI::Raw version, and am not really familiar # with the libnotify API to say what is the cause. Patches welcome to fix it. my $ffi = FFI::Platypus->new; $ffi->lib(find_lib_or_exit lib => 'notify'); $ffi->attach(notify_init => ['string'] => 'void'); $ffi->attach(notify_uninit => [] => 'void'); $ffi->attach([notify_notification_new => 'notify_new'] => ['string', 'string', 'string'] => 'opaque'); $ffi->attach([notify_notification_update => 'notify_update'] => ['opaque', 'string', 'string', 'string'] => 'void'); $ffi->attach([notify_notification_show => 'notify_show'] => ['opaque', 'opaque'] => 'void'); notify_init('FFI::Platypus'); my $n = notify_new('','',''); notify_update($n, 'FFI::Platypus', 'It works!!!', 'media-playback-start'); notify_show($n, undef); notify_uninit(); Discussion: libnotify is a desktop GUI notification library for the GNOME Desktop environment. This script sends a notification event that should show up as a balloon, for me it did so in the upper right hand corner of my screen. The most portable way to find the correct name and location of a dynamic library is via the FFI::CheckLib#find_lib family of functions. If you are putting together a CPAN distribution, you should also consider using FFI::CheckLib#check_lib_or_exit function in your Build.PL or Makefile.PL file (If you are using Dist::Zilla, check out the Dist::Zilla::Plugin::FFI::CheckLib plugin). This will provide a user friendly diagnostic letting the user know that the required library is missing, and reduce the number of bogus CPAN testers results that you will get. Also in this example, we rename some of the functions when they are placed into Perl space to save typing: attach [notify_notification_new => 'notify_new'] => [string,string,string] => opaque; When you specify a list reference as the "name" of the function the first element is the symbol name as understood by the dynamic library. The second element is the name as it will be placed in Perl space. Later, when we call notify_new: my $n = notify_new('','',''); We are really calling the C function notify_notification_new. Allocating and freeing memory use FFI::Platypus; use FFI::Platypus::Memory qw( malloc free memcpy ); my $ffi = FFI::Platypus->new; my $buffer = malloc 12; memcpy $buffer, $ffi->cast('string' => 'opaque', "hello there"), length "hello there\0"; print $ffi->cast('opaque' => 'string', $buffer), "\n"; free $buffer; Discussion: malloc and free are standard memory allocation functions available from the standard c library and. Interfaces to these and other memory related functions are provided by the FFI::Platypus::Memory module. structured data records package My::UnixTime; use FFI::Platypus::Record; record_layout(qw( int tm_sec int tm_min int tm_hour int tm_mday int tm_mon int tm_year int tm_wday int tm_yday int tm_isdst long tm_gmtoff string tm_zone )); my $ffi = FFI::Platypus->new; $ffi->lib(undef); # define a record class My::UnixTime and alias it to "tm" $ffi->type("record(My::UnixTime)" => 'tm'); # attach the C localtime function as a constructor $ffi->attach( localtime => ['time_t*'] => 'tm', sub { my($inner, $class, $time) = @_; $time = time unless defined $time; $inner->(\$time); }); package main; # now we can actually use our My::UnixTime class my $time = My::UnixTime->localtime; printf "time is %d:%d:%d %s\n", $time->tm_hour, $time->tm_min, $time->tm_sec, $time->tm_zone; Discussion: C and other machine code languages frequently provide interfaces that include structured data records (known as "structs" in C). They sometimes provide an API in which you are expected to manipulate these records before and/or after passing them along to C functions. There are a few ways of dealing with such interfaces, but the easiest way is demonstrated here defines a record class using a specific layout. For more details see FFI::Platypus::Record. (FFI::Platypus::Type includes some other ways of manipulating structured data records). libuuid use FFI::CheckLib; use FFI::Platypus; use FFI::Platypus::Memory qw( malloc free ); my $ffi = FFI::Platypus->new; $ffi->lib(find_lib_or_exit lib => 'uuid'); $ffi->type('string(37)' => 'uuid_string'); $ffi->type('record(16)' => 'uuid_t'); $ffi->attach(uuid_generate => ['uuid_t'] => 'void'); $ffi->attach(uuid_unparse => ['uuid_t','uuid_string'] => 'void'); my $uuid = "\0" x 16; # uuid_t uuid_generate($uuid); my $string = "\0" x 37; # 36 bytes to store a UUID string # + NUL termination uuid_unparse($uuid, $string); print "$string\n"; Discussion: libuuid is a library used to generate unique identifiers (UUID) for objects that may be accessible beyond the local system. The library is or was part of the Linux e2fsprogs package. Knowing the size of objects is sometimes important. In this example, we use the sizeof function to get the size of 16 characters (in this case it is simply 16 bytes). We also know that the strings "deparsed" by uuid_unparse are exactly 37 bytes. puts and getpid use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->attach(puts => ['string'] => 'int'); $ffi->attach(getpid => [] => 'int'); puts(getpid()); Discussion: puts is part of standard C library on all platforms. getpid is available on Unix type platforms. Math library use FFI::Platypus; use FFI::CheckLib; my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->attach(puts => ['string'] => 'int'); $ffi->attach(fdim => ['double','double'] => 'double'); puts(fdim(7.0, 2.0)); $ffi->attach(cos => ['double'] => 'double'); puts(cos(2.0)); $ffi->attach(fmax => ['double', 'double'] => 'double'); puts(fmax(2.0,3.0)); Discussion: On UNIX the standard c library math functions are frequently provided in a separate library libm, so you could search for those symbols in "libm.so", but that won't work on non-UNIX platforms like Microsoft Windows. Fortunately Perl uses the math library so these symbols are already in the current process so you can use undef as the library to find them. Strings use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->attach(puts => ['string'] => 'int'); $ffi->attach(strlen => ['string'] => 'int'); puts(strlen('somestring')); $ffi->attach(strstr => ['string','string'] => 'string'); puts(strstr('somestring', 'string')); #attach puts => [string] => int; puts(puts("lol")); $ffi->attach(strerror => ['int'] => 'string'); puts(strerror(2)); Discussion: Strings are not a native type to libffi but the are handled seamlessly by Platypus. Attach function from pointer use FFI::TinyCC; use FFI::Platypus; my $ffi = FFI::Platypus->new; my $tcc = FFI::TinyCC->new; $tcc->compile_string(q{ int add(int a, int b) { return a+b; } }); my $address = $tcc->get_symbol('add'); $ffi->attach( [ $address => 'add' ] => ['int','int'] => 'int' ); print add(1,2), "\n"; Discussion: Sometimes you will have a pointer to a function from a source other than Platypus that you want to call. You can use that address instead of a function name for either of the function or attach methods. In this example we use FFI::TinyCC to compile a short piece of C code and to give us the address of one of its functions, which we then use to create a perl xsub to call it. FFI::TinyCC embeds the Tiny C Compiler (tcc) to provide a just-in-time (JIT) compilation service for FFI. libzmq use constant ZMQ_IO_THREADS => 1; use constant ZMQ_MAX_SOCKETS => 2; use constant ZMQ_REQ => 3; use constant ZMQ_REP => 4; use FFI::CheckLib qw( find_lib_or_exit ); use FFI::Platypus; use FFI::Platypus::Memory qw( malloc ); use FFI::Platypus::Buffer qw( scalar_to_buffer buffer_to_scalar ); my $endpoint = "ipc://zmq-ffi-$$"; my $ffi = FFI::Platypus->new; $ffi->lib(undef); # for puts $ffi->attach(puts => ['string'] => 'int'); $ffi->lib(find_lib_or_exit lib => 'zmq'); $ffi->attach(zmq_version => ['int*', 'int*', 'int*'] => 'void'); my($major,$minor,$patch); zmq_version(\$major, \$minor, \$patch); puts("libzmq version $major.$minor.$patch"); die "this script only works with libzmq 3 or better" unless $major >= 3; $ffi->type('opaque' => 'zmq_context'); $ffi->type('opaque' => 'zmq_socket'); $ffi->type('opaque' => 'zmq_msg_t'); $ffi->attach(zmq_ctx_new => [] => 'zmq_context'); $ffi->attach(zmq_ctx_set => ['zmq_context', 'int', 'int'] => 'int'); $ffi->attach(zmq_socket => ['zmq_context', 'int'] => 'zmq_socket'); $ffi->attach(zmq_connect => ['opaque', 'string'] => 'int'); $ffi->attach(zmq_bind => ['zmq_socket', 'string'] => 'int'); $ffi->attach(zmq_send => ['zmq_socket', 'opaque', 'size_t', 'int'] => 'int'); $ffi->attach(zmq_msg_init => ['zmq_msg_t'] => 'int'); $ffi->attach(zmq_msg_recv => ['zmq_msg_t', 'zmq_socket', 'int'] => 'int'); $ffi->attach(zmq_msg_data => ['zmq_msg_t'] => 'opaque'); $ffi->attach(zmq_errno => [] => 'int'); $ffi->attach(zmq_strerror => ['int'] => 'string'); my $context = zmq_ctx_new(); zmq_ctx_set($context, ZMQ_IO_THREADS, 1); my $socket1 = zmq_socket($context, ZMQ_REQ); zmq_connect($socket1, $endpoint); my $socket2 = zmq_socket($context, ZMQ_REP); zmq_bind($socket2, $endpoint); do { # send our $sent_message = "hello there"; my($pointer, $size) = scalar_to_buffer $sent_message; my $r = zmq_send($socket1, $pointer, $size, 0); die zmq_strerror(zmq_errno()) if $r == -1; }; do { # recv my $msg_ptr = malloc 100; zmq_msg_init($msg_ptr); my $size = zmq_msg_recv($msg_ptr, $socket2, 0); die zmq_strerror(zmq_errno()) if $size == -1; my $data_ptr = zmq_msg_data($msg_ptr); my $recv_message = buffer_to_scalar $data_ptr, $size; print "recv_message = $recv_message\n"; }; Discussion: ØMQ is a high-performance asynchronous messaging library. There are a few things to note here. Firstly, sometimes there may be multiple versions of a library in the wild and you may need to verify that the library on a system meets your needs (alternatively you could support multiple versions and configure your bindings dynamically). Here we use zmq_version to ask libzmq which version it is. zmq_version returns the version number via three integer pointer arguments, so we use the pointer to integer type: int *. In order to pass pointer types, we pass a reference. In this case it is a reference to an undefined value, because zmq_version will write into the pointers the output values, but you can also pass in references to integers, floating point values and opaque pointer types. When the function returns the $major variable (and the others) has been updated and we can use it to verify that it supports the API that we require. Notice that we define three aliases for the opaque type: zmq_context, zmq_socket and zmq_msg_t. While this isn't strictly necessary, since Platypus and C treat all three of these types the same, it is useful form of documentation that helps describe the functionality of the interface. Finally we attach the necessary functions, send and receive a message. If you are interested, there is a fully fleshed out ØMQ Perl interface implemented using FFI called ZMQ::FFI. libarchive use FFI::Platypus (); use FFI::Platypus::API (); use FFI::CheckLib (); # This example uses FreeBSD's libarchive to list the contents of any # archive format that it suppors. We've also filled out a part of # the ArchiveWrite class that could be used for writing archive formats # supported by libarchive my $ffi = My::Platypus->new; $ffi->lib(FFI::CheckLib::find_lib_or_exit lib => 'archive'); $ffi->custom_type(archive => { native_type => 'opaque', perl_to_native => sub { ${$_[0]} }, native_to_perl => sub { # this works because archive_read_new ignores any arguments # and we pass in the class name which we can get here. my $class = FFI::Platypus::API::arguments_get_string(0); bless \$_[0], $class; }, }); $ffi->custom_type(archive_entry => { native_type => 'opaque', perl_to_native => sub { ${$_[0]} }, native_to_perl => sub { # works likewise for archive_entry objects my $class = FFI::Platypus::API::arguments_get_string(0); bless \$_[0], $class, }, }); package My::Platypus; use base qw( FFI::Platypus ); sub find_symbol { my($self, $name) = @_; my $prefix = lcfirst caller(2); $prefix =~ s{([A-Z])}{"_" . lc $1}eg; $self->SUPER::find_symbol(join '_', $prefix, $name); } package Archive; # base class is "abstract" having no constructor or destructor $ffi->attach( error_string => ['archive'] => 'string' ); package ArchiveRead; our @ISA = qw( Archive ); $ffi->attach( new => ['string'] => 'archive' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive'] => 'void' ); $ffi->attach( support_filter_all => ['archive'] => 'int' ); $ffi->attach( support_format_all => ['archive'] => 'int' ); $ffi->attach( open_filename => ['archive','string','size_t'] => 'int' ); $ffi->attach( next_header2 => ['archive', 'archive_entry' ] => 'int' ); $ffi->attach( data_skip => ['archive'] => 'int' ); # ... define additional read methods package ArchiveWrite; our @ISA = qw( Archive ); $ffi->attach( new => ['string'] => 'archive' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive'] => 'void' ); # ... define additional write methods package ArchiveEntry; $ffi->attach( new => ['string'] => 'archive_entry' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive_entry'] => 'void' ); $ffi->attach( pathname => ['archive_entry'] => 'string' ); # ... define additional entry methods package main; use constant ARCHIVE_OK => 0; # this is a Perl version of the C code here: # https://github.com/libarchive/libarchive/wiki/Examples#List_contents_of_Archive_stored_in_File my $archive_filename = shift @ARGV; unless(defined $archive_filename) { print "usage: $0 archive.tar\n"; exit; } my $archive = ArchiveRead->new; $archive->support_filter_all; $archive->support_format_all; my $r = $archive->open_filename($archive_filename, 1024); die "error opening $archive_filename: ", $archive->error_string unless $r == ARCHIVE_OK; my $entry = ArchiveEntry->new; while($archive->next_header2($entry) == ARCHIVE_OK) { print $entry->pathname, "\n"; $archive->data_skip; } Discussion: libarchive is the implementation of tar for FreeBSD provided as a library and available on a number of platforms. One interesting thing about libarchive is that it provides a kind of object oriented interface via opaque pointers. This example creates an abstract class Archive, and concrete classes ArchiveWrite, ArchiveRead and ArchiveEntry. The concrete classes can even be inherited from and extended just like any Perl classes because of the way the custom types are implemented. For more details on custom types see FFI::Platypus::Type and FFI::Platypus::API. Another advanced feature of this example is that we extend the FFI::Platypus class to define our own find_symbol method that prefixes the symbol names depending on the class in which they are defined. This means we can do this when we define a method for Archive: $ffi->attach( support_filter_all => ['archive'] => 'int' ); Rather than this: $ffi->attach( [ archive_read_support_filter_all => 'support_read_filter_all' ] => ['archive'] => 'int' ); ); If you didn't want to create an entire new class just for this little trick you could also use something like Object::Method to extend find_symbol. bzip2 use FFI::Platypus 0.20 (); # 0.20 required for using wrappers use FFI::CheckLib qw( find_lib_or_die ); use FFI::Platypus::Buffer qw( scalar_to_buffer buffer_to_scalar ); use FFI::Platypus::Memory qw( malloc free ); my $ffi = FFI::Platypus->new; $ffi->lib(find_lib_or_die lib => 'bz2'); $ffi->attach( [ BZ2_bzBuffToBuffCompress => 'compress' ] => [ 'opaque', # dest 'unsigned int *', # dest length 'opaque', # source 'unsigned int', # source length 'int', # blockSize100k 'int', # verbosity 'int', # workFactor ] => 'int', sub { my $sub = shift; my($source,$source_length) = scalar_to_buffer $_[0]; my $dest_length = int(length($source)*1.01) + 1 + 600; my $dest = malloc $dest_length; my $r = $sub->($dest, \$dest_length, $source, $source_length, 9, 0, 30); die "bzip2 error $r" unless $r == 0; my $compressed = buffer_to_scalar($dest, $dest_length); free $dest; $compressed; }, ); $ffi->attach( [ BZ2_bzBuffToBuffDecompress => 'decompress' ] => [ 'opaque', # dest 'unsigned int *', # dest length 'opaque', # source 'unsigned int', # source length 'int', # small 'int', # verbosity ] => 'int', sub { my $sub = shift; my($source, $source_length) = scalar_to_buffer $_[0]; my $dest_length = $_[1]; my $dest = malloc $dest_length; my $r = $sub->($dest, \$dest_length, $source, $source_length, 0, 0); die "bzip2 error $r" unless $r == 0; my $decompressed = buffer_to_scalar($dest, $dest_length); free $dest; $decompressed; }, ); my $original = "hello compression world\n"; my $compressed = compress($original); print decompress($compressed, length $original); Discussion: bzip2 is a compression library. For simple one shot attempts at compression/decompression when you expect the original and the result to fit within memory it provides two convenience functions BZ2_bzBuffToBuffCompress and BZ2_bzBuffToBuffDecompress. The first four arguments of both of these C functions are identical, and represent two buffers. One buffer is the source, the second is the destination. For the destination, the length is passed in as a pointer to an integer. On input this integer is the size of the destination buffer, and thus the maximum size of the compressed or decompressed data. When the function returns the actual size of compressed or compressed data is stored in this integer. This is normal stuff for C, but in Perl our buffers are scalars and they already know how large they are. In this sort of situation, wrapping the C function in some Perl code can make your interface a little more Perl like. In order to do this, just provide a code reference as the last argument to the "attach" method. The first argument to this wrapper will be a code reference to the C function. The Perl arguments will come in after that. This allows you to modify / convert the arguments to conform to the C API. What ever value you return from the wrapper function will be returned back to the original caller. Java Java: // On Linux build .so with // % gcj -fPIC -shared -o libexample.so Example.java public class Example { public static void print_hello() { System.out.println("hello world"); } public static int add(int a, int b) { return a + b; } } C++: #include #include #include #include extern "C" void gcj_start() { using namespace java::lang; JvCreateJavaVM(NULL); JvInitClass(&System::class$); } extern "C" void gcj_end() { JvDetachCurrentThread(); } Perl: use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib('./libexample.so'); # Java methods are mangled by gcj using the same format as g++ $ffi->attach( [ _ZN7Example11print_helloEJvv => 'print_hello' ] => [] => 'void' ); $ffi->attach( [ _ZN7Example3addEJiii => 'add' ] => ['int', 'int'] => 'int' ); # Initialize the Java runtime $ffi->function( gcj_start => [] => 'void' )->call; print_hello(); print add(1,2), "\n"; # Wind the java runtime down $ffi->function( gcj_end => [] => 'void' )->call; Makefile: GCJ=gcj CXX=g++ CFLAGS=-fPIC LDFLAGS=-shared RM=rm -f libexample.so: between.o Example.o $(GCJ) $(LDFLAGS) -o libexample.so between.o Example.o between.o: between.cpp $(CXX) $(CFLAGS) -c -o between.o between.cpp Example.o: Example.java $(GCJ) $(CFLAGS) -c -o Example.o Example.java clean: $(RM) *.o *.so Output: % make g++ -fPIC -c -o between.o between.cpp gcj -fPIC -c -o Example.o Example.java gcj -shared -o libexample.so between.o Example.o % perl example.pl hello world 3 Discussion: You can't call Java .class files directly from FFI / Platypus, but you can compile Java source and .class files into a shared library using the GNU Java Compiler gcj. Because we are calling Java functions from a program (Perl!) that was not started from a Java main() we have to initialize the Java runtime ourselves (details ). This can most easily be accomplished from C++. The GNU Java Compiler uses the same format to mangle method names as GNU C++. The C++ plugin for handles this more transparently by extracting the symbols from the shared library and using either FFI::Platypus::Lang::CPP::Demangle::XS or c++filt to determined the unmangled names. Although the Java source is compiled ahead of time with optimizations, it will not necessarily perform better than a real JVM just because it is compiled. In fact the gcj developers warn than gcj will optimize Java source better than Java .class files. The GNU Java Compiler also lags behind modern Java. Even so this enables you to call Java from Perl and potentially other Java based languages such as Scala, Groovy or JRuby. CAVEATS Platypus and Native Interfaces like libffi rely on the availability of dynamic libraries. Things not supported include: Systems that lack dynamic library support Like MS-DOS Systems that are not supported by libffi Like OpenVMS Languages that do not support using dynamic libraries from other languages Like Google's Go. Although I believe that XS won't help in this regard. Languages that do not compile to machine code Like .NET based languages and Java that can't be understood by gcj. The documentation has a bias toward using FFI / Platypus with C. This is my fault, as my background in mainly in C/C++ programmer (when I am not writing Perl). In many places I use "C" as a short form for "any language that can generate machine code and is callable from C". I welcome pull requests to the Platypus core to address this issue. In an attempt to ease usage of Platypus by non C programmers, I have written a number of foreign language plugins for various popular languages (see the SEE ALSO below). These plugins come with examples specific to those languages, and documentation on common issues related to using those languages with FFI. In most cases these are available for easy adoption for those with the know-how or the willingness to learn. If your language doesn't have a plugin YET, that is just because you haven't written it yet. SUPPORT IRC: #native on irc.perl.org (click for instant chat room login) If something does not work the way you think it should, or if you have a feature request, please open an issue on this project's GitHub Issue tracker: https://github.com/plicease/FFI-Platypus/issues CONTRIBUTING If you have implemented a new feature or fixed a bug then you may make a pull request on this project's GitHub repository: https://github.com/plicease/FFI-Platypus/pulls This project is developed using Dist::Zilla. The project's git repository also comes with Build.PL and cpanfile files necessary for building, testing (and even installing if necessary) without Dist::Zilla. Please keep in mind though that these files are generated so if changes need to be made to those files they should be done through the project's dist.ini file. If you do use Dist::Zilla and already have the necessary plugins installed, then I encourage you to run dzil test before making any pull requests. This is not a requirement, however, I am happy to integrate especially smaller patches that need tweaking to fit the project standards. I may push back and ask you to write a test case or alter the formatting of a patch depending on the amount of time I have and the amount of code that your patch touches. This project's GitHub issue tracker listed above is not Write-Only. If you want to contribute then feel free to browse through the existing issues and see if there is something you feel you might be good at and take a whack at the problem. I frequently open issues myself that I hope will be accomplished by someone in the future but do not have time to immediately implement myself. Another good area to help out in is documentation. I try to make sure that there is good document coverage, that is there should be documentation describing all the public features and warnings about common pitfalls, but an outsider's or alternate view point on such things would be welcome; if you see something confusing or lacks sufficient detail I encourage documentation only pull requests to improve things. The Platypus distribution comes with a test library named libtest that is normally automatically built by ./Build test. If you prefer to use prove or run tests directly, you can use the ./Build libtest command to build it. Example: % perl Build.PL % ./Build % ./Build libtest % prove -bv t # or an individual test % perl -Mblib t/ffi_platypus_memory.t The build process also respects these environment variables: FFI_PLATYPUS_DEBUG Build the XS code portion of Platypus with -g3 instead of what ever optimizing flags that your Perl normally uses. This is useful if you need to debug the C or XS code that comes with Platypus, but do not have a debugging Perl. % env FFI_PLATYPUS_DEBUG=1 perl Build.PL DEBUG: - $Config{lddlflags} = -shared -O2 -L/usr/local/lib -fstack-protector + $Config{lddlflags} = -shared -g3 -L/usr/local/lib -fstack-protector - $Config{optimize} = -O2 + $Config{optimize} = -g3 Created MYMETA.yml and MYMETA.json Creating new 'Build' script for 'FFI-Platypus' version '0.10' FFI_PLATYPUS_DEBUG_FAKE32 When building Platypus on 32 bit Perls, it will use the Math::Int64 C API and make Math::Int64 a prerequisite. Setting this environment variable will force Platypus to build with both of those options on a 64 bit Perl as well. % env FFI_PLATYPUS_DEBUG_FAKE32=1 perl Build.PL DEBUG_FAKE32: + making Math::Int64 a prerequisite (not normally done on 64 bit Perls) + using Math::Int64's C API to manipulate 64 bit values (not normally done on 64 bit Perls) Created MYMETA.yml and MYMETA.json Creating new 'Build' script for 'FFI-Platypus' version '0.10' FFI_PLATYPUS_NO_ALLOCA Platypus uses the non-standard and somewhat controversial C function alloca by default on platforms that support it. I believe that Platypus uses it responsibly to allocate small amounts of memory for argument type parameters, and does not use it to allocate large structures like arrays or buffers. If you prefer not to use alloca despite these precautions, then you can turn its use off by setting this environment variable when you run Build.PL: % env FFI_PLATYPUS_NO_ALLOCA=1 perl Build.PL NO_ALLOCA: + alloca() will not be used, even if your platform supports it. Created MYMETA.yml and MYMETA.json Creating new 'Build' script for 'FFI-Platypus' version '0.10' Coding Guidelines * Do not hesitate to make code contribution. Making useful contributions is more important than following byzantine bureaucratic coding regulations. We can always tweak things later. * Please make an effort to follow existing coding style when making pull requests. * Platypus supports all production Perl releases since 5.8.1. For that reason, please do not introduce any code that requires a newer version of Perl. Performance Testing As Mark Twain was fond of saying there are four types of lies: lies, damn lies, statistics and benchmarks. That being said, it can sometimes be helpful to compare the runtime performance of Platypus if you are making significant changes to the Platypus Core. For that I use `FFI-Performance`, which can be found in my GitHub repository here: https://github.com/plicease/FFI-Performance System integrators If you are including Platypus in a larger system (for example a Linux distribution), and you already have libffi as part of your system, you may be interested in Alt::Alien::FFI::System. This is an alternative to Alien::FFI that does not require Alien::Base. In fact it has zero non-Core dependencies, and doesn't even need to be installed. Simply include Alt::Alien::FFI::System's lib directory in your PERL5LIB path when you build Platypus. For example: % export PERL5LIB=/path/to/Alt-Alien-FFI-System/lib % cpanm FFI::Platypus SEE ALSO NativeCall Promising interface to Platypus inspired by Perl 6. FFI::Platypus::Type Type definitions for Platypus. FFI::Platypus::Record Define structured data records (C "structs") for use with Platypus. FFI::Platypus::API The custom types API for Platypus. FFI::Platypus::Memory Memory functions for FFI. FFI::CheckLib Find dynamic libraries in a portable way. Module::Build::FFI Bundle C code with your FFI extension. FFI::TinyCC JIT compiler for FFI. FFI::Platypus::Lang::C Documentation and tools for using Platypus with the C programming language FFI::Platypus::Lang::CPP Documentation and tools for using Platypus with the C++ programming language FFI::Platypus::Lang::Fortran Documentation and tools for using Platypus with Fortran FFI::Platypus::Lang::Pascal Documentation and tools for using Platypus with Free Pascal FFI::Platypus::Lang::Rust Documentation and tools for using Platypus with the Rust programming language FFI::Platypus::Lang::ASM Documentation and tools for using Platypus with the Assembly Convert::Binary::C A great interface for decoding C data structures, including structs, enums, #defines and more. pack and unpack Native to Perl functions that can be used to decode C struct types. C::Scan This module can extract constants and other useful objects from C header files that may be relevant to an FFI application. One downside is that its use may require development packages to be installed. FFI::Raw Alternate interface to libffi with fewer features. It notably lacks the ability to create real xsubs, which may make FFI::Platypus much faster. Also lacking are pointers to native types, arrays and custom types. In its favor, it has been around for longer that Platypus, and has been battle tested to some success. Win32::API Microsoft Windows specific FFI style interface. Ctypes Ctypes was intended as a FFI style interface for Perl, but was never part of CPAN, and at least the last time I tried it did not work with recent versions of Perl. FFI Foreign function interface based on (nomenclature is everything) FSF's ffcall. It hasn't worked for quite some time, and ffcall is no longer supported or distributed. C::DynaLib Another FFI for Perl that doesn't appear to have worked for a long time. C::Blocks Embed a tiny C compiler into your Perl scripts. Alien::FFI Provides libffi for Platypus during its configuration and build stages. Alt::Alien::FFI::System An alternative for Alien::FFI intended mainly for system integrators. P5NCI Yet another FFI like interface that does not appear to be supported or under development anymore. ACKNOWLEDGMENTS In addition to the contributors mentioned below, I would like to acknowledge Brock Wilcox (AWWAIID) and Meredith Howard (MHOWARD) whose work on FFI::Sweet not only helped me get started with FFI but significantly influenced the design of Platypus. In addition I'd like to thank Alessandro Ghedini (ALEXBIO) who was always responsive to bug reports and pull requests for FFI::Raw, which was important in the development of the ideas on which Platypus is based. AUTHOR Author: Graham Ollis Contributors: Bakkiaraj Murugesan (bakkiaraj) Dylan Cali (calid) pipcet Zaki Mughal (zmughal) Fitz Elliott (felliott) Vickenty Fesunov (vyf) Gregor Herrmann (gregoa) COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Graham Ollis. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. typemap100644001750001750 276313065045605 15333 0ustar00ollisgollisg000000000000FFI-Platypus-0.47ffi_pl_string T_FFI_PL_STRING ffi_pl_type* T_FFI_PL_TYPE ffi_pl_function* T_FFI_PL_FUNCTION ffi_pl_closure* T_FFI_PL_CLOSURE_DATA ffi_pl_arguments* T_FFI_PL_ARGUMENTS OUTPUT T_FFI_PL_STRING $var != NULL ? sv_setpv((SV*)$arg, $var) : sv_setsv((SV*)$arg, &PL_sv_undef); T_FFI_PL_TYPE sv_setref_pv($arg, \"FFI::Platypus::Type\", (void *) $var); T_FFI_PL_FUNCTION sv_setref_pv($arg, \"FFI::Platypus::Function\", (void *) $var); T_FFI_PL_CLOSURE_DATA sv_setref_pv($arg, \"FFI::Platypus::ClosureData\", (void *) $var); INPUT T_FFI_PL_STRING $var = SvOK($arg) ? ($type)SvPV_nolen($arg) : NULL; T_FFI_PL_TYPE if(sv_isobject($arg) && sv_derived_from($arg, \"FFI::Platypus::Type\")) $var = INT2PTR($type, SvIV((SV *) SvRV($arg))); else Perl_croak(aTHX_ \"$var is not of type FFI::Platypus::Type\"); T_FFI_PL_FUNCTION if(sv_isobject($arg) && sv_derived_from($arg, \"FFI::Platypus::Function\")) $var = INT2PTR($type, SvIV((SV *) SvRV($arg))); else Perl_croak(aTHX_ \"$var is not of type FFI::Platypus::Function\"); T_FFI_PL_CLOSURE_DATA if(sv_isobject($arg) && sv_derived_from($arg, \"FFI::Platypus::ClosureData\")) $var = INT2PTR($type, SvIV((SV *) SvRV($arg))); else Perl_croak(aTHX_ \"$var is not of type FFI::Platypus::ClosureData\"); T_FFI_PL_ARGUMENTS if(sv_isobject($arg) && sv_derived_from($arg, \"FFI::Platypus::API::ARGV\")) $var = INT2PTR($type, SvIV((SV *) SvRV($arg))); else Perl_croak(aTHX_ \"$var is not of type FFI::Platypus::API::ARGV\"); SUPPORT100644001750001750 34213065045605 14777 0ustar00ollisgollisg000000000000FFI-Platypus-0.47SUPPORT If something does not work the way you think it should, or if you have a feature request, please open an issue on this project's GitHub Issue tracker: https://github.com/plicease/FFI-Platypus/issues Changes100644001750001750 2577413065045605 15253 0ustar00ollisgollisg000000000000FFI-Platypus-0.47Revision history for FFI-Platypus 0.47 2017-03-23 18:26:01 -0400 - Fix installer bug where My::ShareConfig was accidentally declared as a prereq 0.46 2017-03-23 15:47:29 -0400 - Remove some internal use of Module::Build with the intent of one day migrating to EUMM or some other installer - Remove Module::Build::FFI. It now has its own distribution. - Prefix the lang attribute with an equal '=' sign to indicate a fully qualified class name instead of one under FFI::Platypus::Lang 0.45 2016-10-24 07:59:57 -0400 - Remove check for Threaded Perl / OpenBSD, as the issue there has been reported fixed 0.44 2016-10-20 14:31:23 -0400 - You can now control which implementation of strdup FFI::Platypus::Memory uses via the FFI_PLATYPUS_MEMORY_STRDUP_IMPL environment variable. 0.43 2016-07-08 03:28:57 -0400 - Numerous fixes for systems with 64bit big-endian arch (previously only 32bit big-endian had been tested) - Officially discourage the use of FFI::Platypus::Declare 0.42 2016-05-06 16:31:01 -0400 - Support for MSYS2 0.41 2016-04-09 16:03:07 -0400 - For the return value undef can be passed in to mean 'void'. - Fixed installer bug where ABI probe would silently fail if /tmp was mounted noexec - Avoid unnecessary downgrade on when Perl is compiled to use longdouble 0.40 2015-08-29 08:45:19 -0400 - Closure declerations ignore white space between () and -> 0.39 2015-08-24 03:23:10 -0400 - Fixed spurious warning: auto loading of record class (via FFI::Platypus::Record) was ALWAYS warning, when it should have only been warning on load failure. 0.38 2015-08-13 17:13:07 -0400 - closure method now comes with a more useful diagnostic thinks to Carp::croak - Added a check for standard C headers. This seems to help the configure stage find ptrdiff_t, which was frequently not detected correctly (at least on Linux). - Improved thread safety by using MY_CXT for some very infrequently used global variables. - Added IRC meta data information for metacpan.org. Please join us at #native on irc.perl.org! - Many minor documentation corrections and tweaks. Most significant is that Convert::Binary::C can now be recommended as it is once again properly maintained. - Added tests for threads and forks. If these tests fail in your environment please let me know! 0.37 2015-05-29 14:28:21 -0400 - Added compatability back in for older version of constant (newer one is not available on CPAN yet) 0.36 2015-05-29 13:40:32 -0400 - Explicitly require constant pragma version 1.32 0.35 2015-05-29 12:06:39 -0400 - FFI::Platypus::Record uses constant to create size of alignment constants instead of creating them with a sub reference (this usage was deprecated in Perl 5.22) 0.34 2015-05-07 09:27:04 -0400 - Require Alien::FFI which is more reliable at configure time on some platforms 0.33 2015-03-23 21:55:02 -0400 - Additional fix for Microsoft Visual C++ that didn't get folded into the previous release. - Fixed segfault during global destruction (gh#53) 0.32 2015-03-18 13:02:53 -0400 - Make sure -L flags from Alien::FFI come before those in perl Config For more reliable builds - Support for Microsoft Visual C++ (you will probably also need Alien::FFI 0.09 or beter) 0.31 2015-02-26 13:41:23 -0500 - Fix bug involving wide custom arguments "wide" meaning where a single Perl argument is translated into multiple machine code arguments. (pipcet++ gh#43) 0.30 2015-02-25 17:50:54 -0500 - You can now pass an opaque in place of a closure type (pipcet++ gh#40,gh#41) - FFI closures are now cached and can be reused if the same closure is passed repeatedly (pipcet++ gh#40,gh#42) - Passing non-reference to scalar as a pointer argument will now issue a warning (gh#5) 0.29 2015-02-24 08:50:34 -0500 - Delayed loading of Win32::ErrorMode to avoid build prereq failure on Windows 0.28 2015-02-23 14:01:54 -0500 - Fix Win32 probe prereq on non-Strawberry 5.20.x+ - Fix for Solaris cc 0.27 2015-02-22 11:17:05 -0500 - Interface to alternate ABIs / calling conventions - Added abi method - Added abis class method - Simplify Win32 probe - Added FFI::Platypus::Lang::Win32 which provides data types used by the Windows API. Takes care of subtle differences between Win32 and Win64. - Fixed bugs specific to 5.8.x - Language plugins can now specify an ABI with abi class method - Default ABI for FFI::Platypus::Lang::Win32 is stdcall on 32bit windows 0.26 2015-02-18 17:47:43 -0500 - Added support for pointers to longdouble (in C "long double *") type - Added support for array of longdouble (in C "long double []") type - Added tied array interface for record array members (see FFI::Platypus::Record::TieArray) Marked as EXPERIMENTAL - Array members of records can now be accessed (set/get) by element - Array members of records types are now documented (see FFI::Platypus::Record) - Bugfix: array wasn't being updated on return for variable length array types - Should now build with an Alien::FFI that was built with ALIEN_FORCE=1 0.25 2015-02-16 20:18:41 -0500 - Probe for proper long double support instead of trusting ffi.h - This disables long double support on cygwin, which does not seem to work, at least in so far as it seems to work on other platforms patches to prove otherwise are welcome. 0.24 2015-02-16 15:38:58 -0500 - Fixed Windows / Strawberry configuration issues 0.23 2015-02-16 05:44:39 -0500 - Support for longdouble (in C "long double") type. - Support for complex_float (in C "float complex") type - Support for complex_double (in C "double complex") type - Fixes for Big Endian architectures (tested on Linux PowerPC) 0.22 2015-02-12 07:47:32 -0500 - Variable length arrays - More recent version of Config::AutoConf required in the configure step (gh#33 zmughal) - Documentation improvements and additional examples, including a crazy Java one 0.21 2015-02-09 06:23:03 -0500 - Added FFI::Platypus#alignof method - Added FFI::Platypus::Record module - Added fixed length strings example: string(10) - Added ro and rw trait for strings 0.20 2015-02-05 14:06:11 -0500 - Added optional wrapper argument to FFI::Platypus#attach and FFI::Platypus::Declare#attach - Added FFI::Platypus#find_lib method - FFI::CheckLib is now a runtime requirement for Platypus - Bumped Alien::FFI requirement to 0.06 0.19 2015-02-03 13:34:53 -0500 - Accept additional extensions, in addition to dlext Example: on OS X both .bundle and .dylib can be used Example: although arguably wrong, on cygwin sometimes .so is used - Added Module::Build::FFI->ffi_dlext class method 0.18 2015-01-30 15:22:07 -0500 - Improved support for C++ in Module::Build::FFI - Module::Build::FFI can now be subclassed to support foreign languages other than C and C++. See Module::Build::FFI::Rust as an example. - Added a hook to allow different names for native types. See FFI::Platypus::Lang::Rust for an example. - Added a hook to allow mangling of symbol (function) names. See FFI::Platypus::Lang::CPP for an example with C++ - Module::Build::FFI#ffi_include_dir can now be an array reference - Module::Build::FFI#ffi_source_dir can now be an array reference - Module::Build::FFI#ffi_libtest_dir can now be an array reference - Module::Build::FFI will build assembly source files (with .s extensions) in the libtest and ffi directories 0.17 2015-01-28 11:11:02 -0500 - Allow integer and floating point type default to 0 when not provided without warning - You can now take the sizeof a custom type (it will be the size of the native type that is actually passed on the C argument stack). - Sizeof should be faster now as it doesn't look up the other meta information or create a hash to contain it - Added record type see FFI::Platypus::Type#Records - Added bool as a primitive type. 0.16 2015-01-23 17:31:00 -0500 - Bumping Alien::FFI version requirement up to 0.04 Thus indirectly Alien::Base to 0.07 Believe this may fix a cpan testers failure that I am seeing 0.15 2015-01-23 16:46:27 -0500 - add FFI::Platypus#ignore_not_found attribute - add FFI::Platypus#package method - Module::Build::FFI was moved into this distribution (formerly distributed as part of FFI-Util) - added aliases: uchar, ushort, uint and ulong 0.14 2015-01-22 08:19:42 -0500 - Fixed some broken links in the documentation 0.12 2015-01-21 23:22:16 -0500 - First CPAN release - Improved documentation - Functionally identically to 0.11 0.11 2015-01-21 16:33:58 -0500 - Release candidate 2 - arguments are available during custom return type even when platform does not support alloca - More documentation and examples - FFI::Platypus::API now use prototypes so you can skip the () 0.10 2015-01-20 04:06:17 -0500 - Release candidate 1 - Added custom Types API (see FFI::Platypus::API) - Added String Pointer custom type (FFI::Platypus::Type::StringPointer) - Added Pointer / Size Buffer custom type (FFI::Platypus::Type::PointerSizeBuffer) 0.09 2015-01-19 03:01:48 -0500 - Third beta - moved cast and sizeof from FFI::Platypus::Memory into FFI::Platypus methods. - cast and size of functions for FFI::Platypus::Declare - attach_cast for faster casting - renamed FFI::Platypus::Declare#function to FFI::Platypus::Declare#attach to more closely match the OO interface - adjusted custom type interface - renamed ffi_to_perl native_to_perl - renamed perl_to_ffi perl_to_native - type argument is now part of the hash and is called native_type 0.08 2015-01-16 10:55:14 -0500 - Second beta - add FFI::Platypus::Buffer stole the buffer functions from FFI::Util can do this with cast, but cast is slow - Fixed bug where cast didn't work with closures. - closure data now free'd when it the closure goes out of scope (GH#4) 0.07 2015-01-15 18:53:45 -0500 - First (mostly complete) beta - workaround some issues with closures - much more comprehensive documentation 0.06 2015-01-14 17:13:57 -0500 - fix typo in last version that broke 32 bit Perls. oops. 0.05 2015-01-14 17:04:25 -0500 - Forth (and mostly complete) alpha - custom types written in Perl are supported. - bug fixes for 32 bit Perls (with compilers that support int64_t) 0.04 2015-01-13 11:14:54 -0500 - Third (and incomplete) alpha - all basic types supported everywhere - closures do not support non basic types or returning strings from a closure 0.03 2015-01-09 15:40:14 -0500 - Second (and incomplete) alpha - closure support added (only integer arguments implmented). - memory leak related to closures will be fixed in the next alpha. 0.02 2015-01-07 17:40:35 -0500 - Early (and incomplete) alpha 0.01 2015-01-07 17:21:27 -0500 - Original (and incompatible) prototype LICENSE100644001750001750 4365513065045605 14763 0ustar00ollisgollisg000000000000FFI-Platypus-0.47This software is copyright (c) 2015 by Graham Ollis. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2015 by Graham Ollis. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2015 by Graham Ollis. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. 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. The End INSTALL100644001750001750 220613065045605 14752 0ustar00ollisgollisg000000000000FFI-Platypus-0.47This is the Perl distribution FFI-Platypus. Installing FFI-Platypus is straightforward. ## Installation with cpanm If you have cpanm, you only need one line: % cpanm FFI::Platypus If it does not have permission to install modules to the current perl, cpanm will automatically set up and install to a local::lib in your home directory. See the local::lib documentation (https://metacpan.org/pod/local::lib) for details on enabling it in your environment. ## Installing with the CPAN shell Alternatively, if your CPAN shell is set up, you should just be able to do: % cpan FFI::Platypus ## Manual installation As a last resort, you can manually install it. Download the tarball, untar it, then build it: % perl Build.PL % ./Build && ./Build test Then install it: % ./Build install If your perl is system-managed, you can create a local::lib in your home directory to install modules to. For details, see the local::lib documentation: https://metacpan.org/pod/local::lib ## Documentation FFI-Platypus documentation is available as POD. You can run perldoc from a shell to read the documentation: % perldoc FFI::Platypus dist.ini100644001750001750 1121313065045605 15403 0ustar00ollisgollisg000000000000FFI-Platypus-0.47name = FFI-Platypus author = Graham Ollis license = Perl_5 copyright_holder = Graham Ollis copyright_year = 2015 version = 0.47 [@Author::Plicease] :version = 2.12 release_tests = 1 installer = ModuleBuild copy_mb = 1 allow_dirty = Build.PL allow_dirty = cpanfile diag = +Alien::Base diag = +PkgConfig irc = irc://irc.perl.org/#native travis_status = 1 preamble = | #use Config; preamble = | #if($^O eq 'openbsd' && !$Config{usethreads} && do { require Alien::FFI; Alien::FFI->install_type eq 'system'}) preamble = | #{ preamble = | # print "Configuration not supported.\n"; preamble = | # print "Please reinstall Alien::FFI with ALIEN_FORCE=1\n"; preamble = | # print "See https://github.com/plicease/FFI-Platypus/issues/19\n"; preamble = | # exit 0; preamble = | #} diag_preamble = | $post_diag = sub { diag_preamble = | eval { diag_preamble = | use Alien::FFI; diag_preamble = | use FFI::Platypus; diag_preamble = | use FFI::Platypus::Memory; diag_preamble = | diag "Alien::FFI version = ", $Alien::FFI::VERSION; diag_preamble = | diag "Alien::FFI->install_type = ", Alien::FFI->install_type; diag_preamble = | diag "Alien::FFI->cflags = ", Alien::FFI->cflags; diag_preamble = | diag "Alien::FFI->libs = ", Alien::FFI->libs; diag_preamble = | diag "Alien::FFI->dist_dir = ", eval { Alien::FFI->dist_dir } || 'undef'; diag_preamble = | diag "Alien::FFI->version = ", eval { Alien::FFI->config('version') } || 'unknown'; diag_preamble = | spacer(); diag_preamble = | require FFI::Platypus::ShareConfig; diag_preamble = | my $share_config = 'FFI::Platypus::ShareConfig'; diag_preamble = | my %type_map = %{ $share_config->get('type_map') }; diag_preamble = | my $diag = $share_config->get('diag'); diag_preamble = | foreach my $key (sort keys %{ $diag->{args} }) diag_preamble = | { diag_preamble = | diag "mb.args.$key=", $diag->{args}->{$key}; diag_preamble = | } diag_preamble = | foreach my $key (sort keys %{ $diag->{config} }) diag_preamble = | { diag_preamble = | diag "config.$key=", $diag->{config}->{$key}; diag_preamble = | } diag_preamble = | diag "ffi.platypus.memory.strdup_impl=$FFI::Platypus::Memory::_strdup_impl"; diag_preamble = | spacer(); diag_preamble = | my %r; diag_preamble = | while(my($k,$v) = each %type_map) diag_preamble = | { diag_preamble = | push @{ $r{$v} }, $k; diag_preamble = | } diag_preamble = | diag "Types:"; diag_preamble = | foreach my $type (sort keys %r) diag_preamble = | { diag_preamble = | diag sprintf(" %-8s : %s", $type, join(', ', sort @{ $r{$type} })); diag_preamble = | } diag_preamble = | spacer(); diag_preamble = | my $abi = FFI::Platypus->abis; diag_preamble = | diag "ABIs:"; diag_preamble = | foreach my $key (sort keys %$abi) diag_preamble = | { diag_preamble = | diag sprintf(" %-20s %s", $key, $abi->{$key}); diag_preamble = | } diag_preamble = | spacer(); diag_preamble = | diag "Probes:"; diag_preamble = | my $probe = $share_config->get("probe"); diag_preamble = | diag sprintf(" %-20s %s", $_, $probe->{$_}) for keys %$probe; diag_preamble = | }; diag_preamble = | diag "extended diagnostic failed: $@" if $@; diag_preamble = | }; [RemovePrereqs] ; comes with Perl 5.8.1 or better remove = strict remove = warnings remove = base remove = overload remove = open remove = bytes remove = utf8 remove = XSLoader remove = File::Spec remove = File::Copy remove = Scalar::Util remove = Exporter remove = Carp remove = Encode remove = File::Glob remove = File::Path remove = Text::ParseWords ; comes with Strawberry (only place we use it) remove = Win32 remove = Win32::Process remove = Win32API::File [Prereqs / ConfigurePrereqs] -phase = configure Alien::FFI = 0.12 ExtUtils::CBuilder = 0 Config::AutoConf = 0.309 FFI::CheckLib = 0.05 JSON::PP = 0 [Prereqs / TestPrereqs] -phase = test Alien::FFI = 0.012 [Prereqs] constant = 1.32 [Prereqs / DevPrereqs] -phase = develop Devel::PPPort = 3.28 [Author::Plicease::Upload] cpan = 1 [PPPort] filename = include/ppport.h [Meta::Dynamic::Config] [MetaNoIndex] directory = examples [InsertExample] remove_boiler = 1 [Author::Plicease::Thanks] current = Graham Ollis contributor = Bakkiaraj Murugesan (bakkiaraj) contributor = Dylan Cali (calid) contributor = pipcet contributor = Zaki Mughal (zmughal) contributor = Fitz Elliott (felliott) contributor = Vickenty Fesunov (vyf) contributor = Gregor Herrmann (gregoa) [Run::AfterBuild] run = perl inc/run/after_build2.pl xs000755001750001750 013065045605 14213 5ustar00ollisgollisg000000000000FFI-Platypus-0.47dl.xs100644001750001750 73413065045605 15312 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xsMODULE = FFI::Platypus PACKAGE = FFI::Platypus::dl void * dlopen(filename); ffi_pl_string filename PROTOTYPE: $ CODE: RETVAL = dlopen(filename, RTLD_LAZY); OUTPUT: RETVAL const char * dlerror(); PROTOTYPE: void * dlsym(handle, symbol); void *handle const char *symbol PROTOTYPE: $$ int dlclose(handle); void *handle PROTOTYPE: $ CODE: if(!PL_dirty) RETVAL = dlclose(handle); else RETVAL = 0; OUTPUT: RETVAL META.yml100644001750001750 205413065045605 15173 0ustar00ollisgollisg000000000000FFI-Platypus-0.47--- abstract: 'Write Perl bindings to non-Perl libraries with FFI. No XS required.' author: - 'Graham Ollis ' build_requires: Alien::FFI: '0.012' Module::Build: '0.3601' Test::More: '0.94' perl: '5.008001' configure_requires: Alien::FFI: '0.12' Config::AutoConf: '0.309' ExtUtils::CBuilder: '0' FFI::CheckLib: '0.05' JSON::PP: '0' Module::Build: '0.3601' perl: '5.008001' dynamic_config: '1' generated_by: 'Dist::Zilla version 6.009, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: FFI-Platypus no_index: directory: - examples requires: FFI::CheckLib: '0' File::ShareDir: '0' JSON::PP: '0' constant: '1.32' perl: '5.008001' resources: IRC: irc://irc.perl.org/#native bugtracker: https://github.com/plicease/FFI-Platypus/issues homepage: https://metacpan.org/pod/FFI::Platypus repository: git://github.com/plicease/FFI-Platypus.git version: '0.47' x_serialization_backend: 'YAML::Tiny version 1.70' Build.PL100644001750001750 367313065045605 15226 0ustar00ollisgollisg000000000000FFI-Platypus-0.47use strict; use warnings; BEGIN { #use Config; #if($^O eq 'openbsd' && !$Config{usethreads} && do { require Alien::FFI; Alien::FFI->install_type eq 'system'}) #{ # print "Configuration not supported.\n"; # print "Please reinstall Alien::FFI with ALIEN_FORCE=1\n"; # print "See https://github.com/plicease/FFI-Platypus/issues/19\n"; # exit 0; #} unless(eval q{ use 5.008001; 1}) { print "Perl 5.008001 or better required\n"; exit; } } # This file was automatically generated by Dist::Zilla::Plugin::ModuleBuild v6.009. use strict; use warnings; use Module::Build 0.3601; use lib qw{inc}; use My::ModuleBuild; my %module_build_args = ( "build_requires" => { "Module::Build" => "0.3601" }, "configure_requires" => { "Alien::FFI" => "0.12", "Config::AutoConf" => "0.309", "ExtUtils::CBuilder" => 0, "FFI::CheckLib" => "0.05", "JSON::PP" => 0, "Module::Build" => "0.3601", "perl" => "5.008001" }, "dist_abstract" => "Write Perl bindings to non-Perl libraries with FFI. No XS required.", "dist_author" => [ "Graham Ollis " ], "dist_name" => "FFI-Platypus", "dist_version" => "0.47", "license" => "perl", "module_name" => "FFI::Platypus", "recursive_test_files" => 1, "requires" => { "FFI::CheckLib" => 0, "File::ShareDir" => 0, "JSON::PP" => 0, "constant" => "1.32", "perl" => "5.008001" }, "share_dir" => { "dist" => "share" }, "test_requires" => { "Alien::FFI" => "0.012", "Test::More" => "0.94", "perl" => "5.008001" } ); my %fallback_build_requires = ( "Alien::FFI" => "0.012", "Module::Build" => "0.3601", "Test::More" => "0.94", "perl" => "5.008001" ); unless ( eval { Module::Build->VERSION(0.4004) } ) { delete $module_build_args{test_requires}; $module_build_args{build_requires} = \%fallback_build_requires; } my $build = My::ModuleBuild->new(%module_build_args); $build->create_build_script; MANIFEST100644001750001750 1020613065045605 15071 0ustar00ollisgollisg000000000000FFI-Platypus-0.47# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.009. Build.PL CONTRIBUTING Changes INSTALL LICENSE MANIFEST META.json META.yml README SUPPORT author.yml cpanfile dist.ini examples/archive.pl examples/attach_from_pointer.pl examples/bzip2.pl examples/char.pl examples/closure-opaque.pl examples/closure.c examples/closure.pl examples/get_uptime.pl examples/getpid.pl examples/integer.pl examples/java/Example.java examples/java/Makefile examples/java/between.cpp examples/java/example.pl examples/list_integer_types.pl examples/malloc.pl examples/math.pl examples/notify.pl examples/pipe.pl examples/string.pl examples/time.pl examples/time_oo.pl examples/time_record.pl examples/uuid.pl examples/var_array.c examples/var_array.pl examples/win32_beep.pl examples/win32_getSystemTime.pl examples/zmq3.pl inc/My/AutoConf.pm inc/My/Dev.pm inc/My/LibTest.pm inc/My/ModuleBuild.pm inc/My/Probe.pm inc/My/ShareConfig.pm inc/eg/complex.c inc/eg/small.c inc/probe/abi.c inc/probe/bigendian.c inc/probe/bigendian64.c inc/probe/complex.c inc/probe/longdouble.c inc/run/after_build2.pl inc/run/before_build.pl inc/run/generate_record_accessor.pl inc/run/readme.pl inc/run/test_examples.pl inc/run/travis.pl inc/run/travis_cpan.pl inc/template/abi.c inc/template/accessor.tt inc/template/accessor_wrapper.tt include/ffi_platypus.h include/ffi_platypus_call.h include/ffi_platypus_guts.h include/libtest.h include/perl_math_int64.h include/ppport.h lib/FFI/Platypus.pm lib/FFI/Platypus.xs lib/FFI/Platypus/API.pm lib/FFI/Platypus/Buffer.pm lib/FFI/Platypus/Declare.pm lib/FFI/Platypus/Lang/ASM.pm lib/FFI/Platypus/Lang/C.pm lib/FFI/Platypus/Lang/Win32.pm lib/FFI/Platypus/Memory.pm lib/FFI/Platypus/Record.pm lib/FFI/Platypus/Record/TieArray.pm lib/FFI/Platypus/ShareConfig.pm lib/FFI/Platypus/Type.pod lib/FFI/Platypus/Type/PointerSizeBuffer.pm lib/FFI/Platypus/Type/StringPointer.pm libtest/align.c libtest/align_array.c libtest/align_fixed.c libtest/align_string.c libtest/basic.c libtest/closure.c libtest/color.c libtest/complex_double.c libtest/complex_float.c libtest/double.c libtest/float.c libtest/longdouble.c libtest/memcmp4.c libtest/pointer.c libtest/record.c libtest/sint16.c libtest/sint32.c libtest/sint64.c libtest/sint8.c libtest/string.c libtest/uint16.c libtest/uint32.c libtest/uint64.c libtest/uint8.c share/README.txt t/00_diag.t t/01_use.t t/basic.t t/closure_die.t t/closure_reuse.t t/closure_space.t t/ffi_platypus_abi.t t/ffi_platypus_alignof.t t/ffi_platypus_attach.t t/ffi_platypus_attach_void.t t/ffi_platypus_buffer.t t/ffi_platypus_cast.t t/ffi_platypus_closure.t t/ffi_platypus_closure_private.t t/ffi_platypus_custom_type.t t/ffi_platypus_declare.t t/ffi_platypus_declare_abi.t t/ffi_platypus_declare_cast.t t/ffi_platypus_declare_lang.t t/ffi_platypus_declare_sizeof.t t/ffi_platypus_declare_sticky.t t/ffi_platypus_find_lib.t t/ffi_platypus_find_symbol.t t/ffi_platypus_function.t t/ffi_platypus_function_private.t t/ffi_platypus_ignore_not_found.t t/ffi_platypus_lang.t t/ffi_platypus_lang_win32.t t/ffi_platypus_lib.t t/ffi_platypus_memory.t t/ffi_platypus_memory__memcpy.t t/ffi_platypus_memory__realloc.t t/ffi_platypus_memory__strdup.t t/ffi_platypus_new.t t/ffi_platypus_record.t t/ffi_platypus_record_tiearray.t t/ffi_platypus_sizeof.t t/ffi_platypus_type.t t/ffi_platypus_type_pointer_size_buffer.t t/ffi_platypus_type_private.t t/ffi_platypus_type_string_pointer.t t/ffi_platypus_types.t t/forks.t t/threads.t t/type_complex_double.t t/type_complex_float.t t/type_double.t t/type_float.t t/type_longdouble.t t/type_opaque.t t/type_record.t t/type_sint16.t t/type_sint32.t t/type_sint64.t t/type_sint8.t t/type_string.t t/type_uint16.t t/type_uint32.t t/type_uint64.t t/type_uint8.t typemap xs/ABI.xs xs/API.xs xs/ClosureData.xs xs/Declare.xs xs/Function.xs xs/Record.xs xs/Type.xs xs/closure.c xs/complex.c xs/custom.c xs/dl.xs xs/havepm.c xs/meta.c xs/names.c xs/perl_math_int64.c xs/record_opaque.c xs/record_simple.c xs/record_string.c xs/windl.c xt/author/eol.t xt/author/no_tabs.t xt/author/pod.t xt/author/pod_coverage.t xt/author/pod_spelling_common.t xt/author/pod_spelling_system.t xt/author/strict.t xt/author/version.t xt/release/changes.t xt/release/fixme.t cpanfile100644001750001750 215113065045605 15424 0ustar00ollisgollisg000000000000FFI-Platypus-0.47requires "FFI::CheckLib" => "0"; requires "File::ShareDir" => "0"; requires "JSON::PP" => "0"; requires "constant" => "1.32"; requires "perl" => "5.008001"; on 'build' => sub { requires "Module::Build" => "0.3601"; }; on 'test' => sub { requires "Alien::FFI" => "0.012"; requires "Test::More" => "0.94"; requires "perl" => "5.008001"; }; on 'configure' => sub { requires "Alien::FFI" => "0.12"; requires "Config::AutoConf" => "0.309"; requires "ExtUtils::CBuilder" => "0"; requires "FFI::CheckLib" => "0.05"; requires "JSON::PP" => "0"; requires "Module::Build" => "0.3601"; requires "perl" => "5.008001"; }; on 'develop' => sub { requires "Devel::PPPort" => "3.28"; requires "FindBin" => "0"; requires "Test::CPAN::Changes" => "0"; requires "Test::EOL" => "0"; requires "Test::Fixme" => "0.07"; requires "Test::More" => "0.94"; requires "Test::NoTabs" => "0"; requires "Test::Pod" => "0"; requires "Test::Pod::Coverage" => "0"; requires "Test::Pod::Spelling::CommonMistakes" => "0"; requires "Test::Spelling" => "0"; requires "Test::Strict" => "0"; requires "YAML" => "0"; }; t000755001750001750 013065045605 14024 5ustar00ollisgollisg000000000000FFI-Platypus-0.47basic.t100644001750001750 23513065045605 15412 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 1; use FFI::Platypus; my $ffi = eval { FFI::Platypus->new }; diag $@ if $@; isa_ok $ffi, 'FFI::Platypus'; forks.t100644001750001750 101013065045605 15465 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More; BEGIN { plan skip_all => 'Test requires forks' unless eval q{ use forks; 1 } } use FFI::CheckLib; use FFI::Platypus; plan tests => 2; my $ffi = FFI::Platypus->new(lib => find_lib(lib => 'test', symbol => 'f0', libpath => 'libtest' )); sub f0 { $ffi->function(f0 => ['uint8'] => 'uint8')->call(@_); } sub otherthread { my $val = f0(22); undef $ffi; $val; } is(threads->create(\&otherthread)->join(), 22, 'works in a thread'); is f0(24), 24, 'works in main thread'; ABI.xs100644001750001750 117413065045605 15325 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xsMODULE = FFI::Platypus PACKAGE = FFI::Platypus::ABI int verify(abi) int abi PREINIT: ffi_abi ffi_abi; ffi_cif ffi_cif; ffi_type *args[1]; CODE: /* * I had at least one report from (unknown version of) libffi * where 999999 was accepted as a legal ABI, and all the other * tests passed */ if(abi < FFI_FIRST_ABI || abi > FFI_LAST_ABI) { RETVAL = 0; } else { ffi_abi = abi; if(ffi_prep_cif(&ffi_cif, ffi_abi, 0, &ffi_type_void, args) == FFI_OK) { RETVAL = 1; } else { RETVAL = 0; } } OUTPUT: RETVAL meta.c100644001750001750 1441013065045605 15465 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xs#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #include "ffi_platypus.h" size_t ffi_pl_sizeof(ffi_pl_type *self) { switch(self->platypus_type) { case FFI_PL_NATIVE: case FFI_PL_CUSTOM_PERL: case FFI_PL_EXOTIC_FLOAT: return self->ffi_type->size; case FFI_PL_STRING: if(self->extra[0].string.platypus_string_type == FFI_PL_STRING_FIXED) return self->extra[0].string.size; else return sizeof(void*); case FFI_PL_POINTER: case FFI_PL_CLOSURE: return sizeof(void*); case FFI_PL_ARRAY: return self->ffi_type->size * self->extra[0].array.element_count; case FFI_PL_RECORD: return self->extra[0].record.size; default: return 0; } } HV * ffi_pl_get_type_meta(ffi_pl_type *self) { HV *meta; const char *string; meta = newHV(); hv_store(meta, "size", 4, newSViv(ffi_pl_sizeof(self)), 0); if(self->platypus_type == FFI_PL_NATIVE || self->platypus_type == FFI_PL_EXOTIC_FLOAT) { hv_store(meta, "element_size", 12, newSViv(self->ffi_type->size), 0); hv_store(meta, "type", 4, newSVpv("scalar",0),0); if(self->platypus_type == FFI_PL_EXOTIC_FLOAT) hv_store(meta, "exotic", 6, newSViv(1), 0); } else if(self->platypus_type == FFI_PL_STRING) { hv_store(meta, "element_size", 12, newSViv(sizeof(void*)), 0); hv_store(meta, "type", 4, newSVpv("string",0),0); switch(self->extra[0].string.platypus_string_type) { case FFI_PL_STRING_RO: hv_store(meta, "access", 6, newSVpv("ro",0), 0); hv_store(meta, "fixed_size", 10, newSViv(0), 0); break; case FFI_PL_STRING_RW: hv_store(meta, "access", 6, newSVpv("rw",0), 0); hv_store(meta, "fixed_size", 10, newSViv(0), 0); break; case FFI_PL_STRING_FIXED: hv_store(meta, "access", 6, newSVpv("rw",0), 0); hv_store(meta, "fixed_size", 10, newSViv(1), 0); break; } } else if(self->platypus_type == FFI_PL_POINTER) { hv_store(meta, "element_size", 12, newSViv(self->ffi_type->size), 0); hv_store(meta, "type", 4, newSVpv("pointer",0),0); } else if(self->platypus_type == FFI_PL_ARRAY) { hv_store(meta, "element_size", 12, newSViv(self->ffi_type->size), 0); hv_store(meta, "type", 4, newSVpv("array",0),0); hv_store(meta, "element_count", 13, newSViv(self->extra[0].array.element_count), 0); } else if(self->platypus_type == FFI_PL_CLOSURE) { AV *signature; AV *argument_types; HV *subtype; int i; int number_of_arguments; number_of_arguments = self->extra[0].closure.ffi_cif.nargs; signature = newAV(); argument_types = newAV(); for(i=0; i < number_of_arguments; i++) { subtype = ffi_pl_get_type_meta(self->extra[0].closure.argument_types[i]); av_store(argument_types, i, newRV_noinc((SV*)subtype)); } av_store(signature, 0, newRV_noinc((SV*)argument_types)); subtype = ffi_pl_get_type_meta(self->extra[0].closure.return_type); av_store(signature, 1, newRV_noinc((SV*)subtype)); hv_store(meta, "signature", 9, newRV_noinc((SV*)signature), 0); hv_store(meta, "element_size", 12, newSViv(sizeof(void*)), 0); hv_store(meta, "type", 4, newSVpv("closure",0),0); } else if(self->platypus_type == FFI_PL_CUSTOM_PERL) { hv_store(meta, "type", 4, newSVpv("custom_perl",0),0); if(self->extra[0].custom_perl.perl_to_native != NULL) hv_store(meta, "custom_perl_to_native", 18, newRV_inc((SV*)self->extra[0].custom_perl.perl_to_native), 0); if(self->extra[0].custom_perl.perl_to_native_post != NULL) hv_store(meta, "custom_perl_to_native_post", 23, newRV_inc((SV*)self->extra[0].custom_perl.perl_to_native_post), 0); if(self->extra[0].custom_perl.native_to_perl != NULL) hv_store(meta, "custom_native_to_perl", 18, newRV_inc((SV*)self->extra[0].custom_perl.native_to_perl), 0); } else if(self->platypus_type == FFI_PL_RECORD) { hv_store(meta, "type", 4, newSVpv("record",0),0); hv_store(meta, "ref", 3, newSViv(self->extra[0].record.stash != NULL ? 1 : 0),0); } switch(self->ffi_type->type) { case FFI_TYPE_VOID: hv_store(meta, "element_type", 12, newSVpv("void",0),0); break; case FFI_TYPE_FLOAT: case FFI_TYPE_DOUBLE: #ifdef FFI_PL_PROBE_LONGDOUBLE case FFI_TYPE_LONGDOUBLE: #endif #ifdef FFI_TARGET_HAS_COMPLEX_TYPE case FFI_TYPE_COMPLEX: #endif hv_store(meta, "element_type", 12, newSVpv("float",0),0); break; case FFI_TYPE_UINT8: case FFI_TYPE_UINT16: case FFI_TYPE_UINT32: case FFI_TYPE_UINT64: hv_store(meta, "element_type", 12, newSVpv("int",0),0); hv_store(meta, "sign", 4, newSViv(0),0); break; case FFI_TYPE_SINT8: case FFI_TYPE_SINT16: case FFI_TYPE_SINT32: case FFI_TYPE_SINT64: hv_store(meta, "element_type", 12, newSVpv("int",0),0); hv_store(meta, "sign", 4, newSViv(1),0); break; case FFI_TYPE_POINTER: hv_store(meta, "element_type", 12, newSVpv("opaque",0),0); break; } switch(self->ffi_type->type) { case FFI_TYPE_VOID: string = "void"; break; case FFI_TYPE_FLOAT: string = "float"; break; case FFI_TYPE_DOUBLE: string = "double"; break; #ifdef FFI_PL_PROBE_LONGDOUBLE case FFI_TYPE_LONGDOUBLE: string = "longdouble"; break; #endif case FFI_TYPE_UINT8: string = "uint8"; break; case FFI_TYPE_SINT8: string = "sint8"; break; case FFI_TYPE_UINT16: string = "uint16"; break; case FFI_TYPE_SINT16: string = "sint16"; break; case FFI_TYPE_UINT32: string = "uint32"; break; case FFI_TYPE_SINT32: string = "sint32"; break; case FFI_TYPE_UINT64: string = "uint64"; break; case FFI_TYPE_SINT64: string = "sint64"; break; case FFI_TYPE_POINTER: string = "pointer"; break; #ifdef FFI_TARGET_HAS_COMPLEX_TYPE case FFI_TYPE_COMPLEX: string = self->ffi_type->size == 16 ? "complex_double" : "complex_float"; break; #endif default: string = NULL; break; } hv_store(meta, "ffi_type", 8, newSVpv(string,0),0); return meta; } API.xs100644001750001750 1533413065045605 15366 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xsMODULE = FFI::Platypus PACKAGE = FFI::Platypus::API int arguments_count() PROTOTYPE: PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); RETVAL = ffi_pl_arguments_count(MY_CXT.current_argv); OUTPUT: RETVAL void * arguments_get_pointer(i) int i PROTOTYPE: $ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); RETVAL = ffi_pl_arguments_get_pointer(MY_CXT.current_argv, i); OUTPUT: RETVAL void arguments_set_pointer(i, value) int i void *value PROTOTYPE: $$ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); ffi_pl_arguments_set_pointer(MY_CXT.current_argv, i, value); ffi_pl_string arguments_get_string(i) int i PROTOTYPE: $ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); RETVAL = ffi_pl_arguments_get_string(MY_CXT.current_argv, i); OUTPUT: RETVAL void arguments_set_string(i, value) int i ffi_pl_string value PROTOTYPE: $$ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); ffi_pl_arguments_set_string(MY_CXT.current_argv, i, value); UV arguments_get_uint8(i) int i PROTOTYPE: $ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); RETVAL = ffi_pl_arguments_get_uint8(MY_CXT.current_argv, i); OUTPUT: RETVAL void arguments_set_uint8(i, value) int i UV value PROTOTYPE: $$ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); ffi_pl_arguments_set_uint8(MY_CXT.current_argv, i, value); IV arguments_get_sint8(i) int i PROTOTYPE: $ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); RETVAL = ffi_pl_arguments_get_sint8(MY_CXT.current_argv, i); OUTPUT: RETVAL void arguments_set_sint8(i, value) int i IV value PROTOTYPE: $$ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); ffi_pl_arguments_set_sint8(MY_CXT.current_argv, i, value); float arguments_get_float(i) int i PROTOTYPE: $ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); RETVAL = ffi_pl_arguments_get_float(MY_CXT.current_argv, i); OUTPUT: RETVAL void arguments_set_float(i, value) int i float value PROTOTYPE: $$ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); ffi_pl_arguments_set_float(MY_CXT.current_argv, i, value); double arguments_get_double(i) int i PROTOTYPE: $ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); RETVAL = ffi_pl_arguments_get_double(MY_CXT.current_argv, i); OUTPUT: RETVAL void arguments_set_double(i, value) int i double value PROTOTYPE: $$ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); ffi_pl_arguments_set_double(MY_CXT.current_argv, i, value); UV arguments_get_uint16(i) int i PROTOTYPE: $ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); RETVAL = ffi_pl_arguments_get_uint16(MY_CXT.current_argv, i); OUTPUT: RETVAL void arguments_set_uint16(i, value) int i UV value PROTOTYPE: $$ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); ffi_pl_arguments_set_uint16(MY_CXT.current_argv, i, value); IV arguments_get_sint16(i) int i PROTOTYPE: $ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); RETVAL = ffi_pl_arguments_get_sint16(MY_CXT.current_argv, i); OUTPUT: RETVAL void arguments_set_sint16(i, value) int i IV value PROTOTYPE: $$ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); ffi_pl_arguments_set_sint16(MY_CXT.current_argv, i, value); UV arguments_get_uint32(i) int i PROTOTYPE: $ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); RETVAL = ffi_pl_arguments_get_uint32(MY_CXT.current_argv, i); OUTPUT: RETVAL void arguments_set_uint32(i, value) int i UV value PROTOTYPE: $$ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); ffi_pl_arguments_set_uint32(MY_CXT.current_argv, i, value); IV arguments_get_sint32(i) int i PROTOTYPE: $ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); RETVAL = ffi_pl_arguments_get_sint32(MY_CXT.current_argv, i); OUTPUT: RETVAL void arguments_set_sint32(i, value) int i IV value PROTOTYPE: $$ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); ffi_pl_arguments_set_sint32(MY_CXT.current_argv, i, value); void arguments_get_uint64(i) int i PROTOTYPE: $ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); #ifdef HAVE_IV_IS_64 XSRETURN_UV(ffi_pl_arguments_get_uint64(MY_CXT.current_argv, i)); #else { ST(0) = sv_newmortal(); sv_setu64(ST(0), ffi_pl_arguments_get_uint64(MY_CXT.current_argv, i)); XSRETURN(1); } #endif void arguments_set_uint64(i, value) int i SV* value PROTOTYPE: $$ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); #ifdef HAVE_IV_IS_64 ffi_pl_arguments_set_uint64(MY_CXT.current_argv, i, SvUV(value)); #else ffi_pl_arguments_set_uint64(MY_CXT.current_argv, i, SvU64(value)); #endif void arguments_get_sint64(i) int i PROTOTYPE: $ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); #ifdef HAVE_IV_IS_64 XSRETURN_IV(ffi_pl_arguments_get_sint64(MY_CXT.current_argv, i)); #else { ST(0) = sv_newmortal(); sv_setu64(ST(0), ffi_pl_arguments_get_sint64(MY_CXT.current_argv, i)); XSRETURN(1); } #endif void arguments_set_sint64(i, value) int i SV* value PROTOTYPE: $$ PREINIT: dMY_CXT; CODE: if(MY_CXT.current_argv == NULL) croak("Not in custom type handler"); #ifdef HAVE_IV_IS_64 ffi_pl_arguments_set_sint64(MY_CXT.current_argv, i, SvIV(value)); #else ffi_pl_arguments_set_sint64(MY_CXT.current_argv, i, SvI64(value)); #endif META.json100644001750001750 456413065045605 15353 0ustar00ollisgollisg000000000000FFI-Platypus-0.47{ "abstract" : "Write Perl bindings to non-Perl libraries with FFI. No XS required.", "author" : [ "Graham Ollis " ], "dynamic_config" : 1, "generated_by" : "Dist::Zilla version 6.009, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "FFI-Platypus", "no_index" : { "directory" : [ "examples" ] }, "prereqs" : { "build" : { "requires" : { "Module::Build" : "0.3601" } }, "configure" : { "requires" : { "Alien::FFI" : "0.12", "Config::AutoConf" : "0.309", "ExtUtils::CBuilder" : "0", "FFI::CheckLib" : "0.05", "JSON::PP" : "0", "Module::Build" : "0.3601", "perl" : "5.008001" } }, "develop" : { "requires" : { "Devel::PPPort" : "3.28", "FindBin" : "0", "Test::CPAN::Changes" : "0", "Test::EOL" : "0", "Test::Fixme" : "0.07", "Test::More" : "0.94", "Test::NoTabs" : "0", "Test::Pod" : "0", "Test::Pod::Coverage" : "0", "Test::Pod::Spelling::CommonMistakes" : "0", "Test::Spelling" : "0", "Test::Strict" : "0", "YAML" : "0" } }, "runtime" : { "requires" : { "FFI::CheckLib" : "0", "File::ShareDir" : "0", "JSON::PP" : "0", "constant" : "1.32", "perl" : "5.008001" } }, "test" : { "requires" : { "Alien::FFI" : "0.012", "Test::More" : "0.94", "perl" : "5.008001" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/plicease/FFI-Platypus/issues" }, "homepage" : "https://metacpan.org/pod/FFI::Platypus", "repository" : { "type" : "git", "url" : "git://github.com/plicease/FFI-Platypus.git", "web" : "https://github.com/plicease/FFI-Platypus" }, "x_IRC" : "irc://irc.perl.org/#native" }, "version" : "0.47", "x_serialization_backend" : "Cpanel::JSON::XS version 3.023" } author.yml100644001750001750 247313065045605 15754 0ustar00ollisgollisg000000000000FFI-Platypus-0.47--- pod_spelling_system: skip: 0 # list of words that are spelled correctly # (regardless of what spell check thinks) stopwords: - longdouble - sint - uint - parentheticals - ffi - xsub - JIT - xsubs - libffi - strdup - libc - libarchive - free'd - free'ing - SIGSEGV - Ctypes - libm - libnotify - libuuid - libzmq - deparsed - tcc - fsprogs - DLLs - libtest - bzip - Fortran - smushes - Bakkiaraj - Murugesan - bakkiaraj - demangling - lang - demangled - alignof - ALEXBIO - AWWAIID - Alessandro - Ghedini - MHOWARD - JRuby - Rubinius - reimplemented - Mughal - Zaki - zmughal - Scala - JVM - gcj - integrators - ABIs - abis - abi - ABI - pipcet - FSF - bzip2 - e2fsprogs - g3 - sint8 - sint16 - sint32 - sint64 - uint8 - uint16 - uint32 - uint64 - x86 - calid - Fitz - felliott - Fesunov - Vickenty - vyf - Gregor - Herrmann - gregoa pod_coverage: skip: 0 # format is "Class#method" or "Class", regex allowed # for either Class or method. private: - FFI::Platypus::Type::.* - FFI::Platypus::ShareConfig 01_use.t100644001750001750 100613065045605 15442 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More; use_ok 'FFI::Platypus'; use_ok 'FFI::Platypus::Declare'; use_ok 'FFI::Platypus::Memory'; use_ok 'FFI::Platypus::Buffer'; use_ok 'FFI::Platypus::API'; use_ok 'FFI::Platypus::Type::PointerSizeBuffer'; use_ok 'FFI::Platypus::Type::StringPointer'; use_ok 'FFI::Platypus::Lang::ASM'; use_ok 'FFI::Platypus::Lang::C'; use_ok 'FFI::Platypus::Lang::Win32'; use_ok 'FFI::Platypus::Record'; use_ok 'FFI::Platypus::Record::TieArray'; use_ok 'FFI::Platypus::ShareConfig'; done_testing; windl.c100644001750001750 674713065045605 15652 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xs#include #ifdef PERL_OS_WINDOWS #ifdef HAVE_WINDOWS_H #include #endif #ifdef HAVE_SYS_CYGWIN_H #include #endif #ifdef HAVE_STRING_H #include #endif /* * TODO: c::ac is not detecting psapi.h for some reason ... * but it should always be there in any platform that * we support */ #include typedef struct _library_handle { int is_null; int flags; HMODULE os_handle; } library_handle; static const char *error = NULL; /* * dlopen() */ void * windlopen(const char *filename, int flags) { char *win_path_filename; library_handle *handle; win_path_filename = NULL; #ifdef PERL_OS_CYGWIN if(filename != NULL) { ssize_t size; size = cygwin_conv_path(CCP_POSIX_TO_WIN_A | CCP_RELATIVE, filename, NULL, 0); if(size < 0) { error = "unable to determine length of string for cygwin_conv_path"; return NULL; } win_path_filename = malloc(size); if(win_path_filename == NULL) { error = "unable to allocate enough memory for cygwin_conv_path"; return NULL; } if(cygwin_conv_path(CCP_POSIX_TO_WIN_A | CCP_RELATIVE, filename, win_path_filename, size)) { error = "error in conversion for cygwin_conv_path"; free(win_path_filename); return NULL; } filename = win_path_filename; } #endif handle = malloc(sizeof(library_handle)); if(handle == NULL) { if(win_path_filename != NULL) free(win_path_filename); error = "unable to allocate memory for handle"; return NULL; } if(filename == NULL) { handle->is_null = 1; } else { handle->is_null = 0; handle->os_handle = LoadLibrary(filename); } handle->flags = flags; if(win_path_filename != NULL) free(win_path_filename); error = NULL; return (void*) handle; } /* * dlsym() */ void * windlsym(void *void_handle, const char *symbol_name) { library_handle *handle = (library_handle*) void_handle; static const char *not_found = "symbol not found"; void *symbol; if(!handle->is_null) { symbol = GetProcAddress(handle->os_handle, symbol_name); if(symbol == NULL) error = not_found; else error = NULL; return symbol; } else { int n; DWORD needed; HANDLE process; HMODULE mods[1024]; TCHAR mod_name[MAX_PATH]; process = OpenProcess( PROCESS_QUERY_INFORMATION | PROCESS_VM_READ, FALSE, GetCurrentProcessId() ); if(process == NULL) { error = "Process for self not found"; return NULL; } if(EnumProcessModules(process, mods, sizeof(mods), &needed)) { for(n=0; n < (needed/sizeof(HMODULE)); n++) { if(GetModuleFileNameEx(process, mods[n], mod_name, sizeof(mod_name) / sizeof(TCHAR))) { HMODULE handle = LoadLibrary(mod_name); if(handle == NULL) continue; symbol = GetProcAddress(handle, symbol_name); if(symbol != NULL) { error = NULL; FreeLibrary(handle); return symbol; } FreeLibrary(handle); } } } error = not_found; return NULL; } } /* * dlerror() */ const char * windlerror(void) { return error; } /* * dlclose() */ int windlclose(void *void_handle) { library_handle *handle = (library_handle*) void_handle; if(!handle->is_null) { FreeLibrary(handle->os_handle); } free(handle); error = NULL; return 0; } #endif names.c100644001750001750 230213065045605 15617 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xs#include "ffi_platypus.h" ffi_type * ffi_pl_name_to_type(const char *name) { if(!strcmp(name, "void")) { return &ffi_type_void; } else if(!strcmp(name, "uint8")) { return &ffi_type_uint8; } else if(!strcmp(name, "sint8")) { return &ffi_type_sint8; } else if(!strcmp(name, "uint16")) { return &ffi_type_uint16; } else if(!strcmp(name, "sint16")) { return &ffi_type_sint16; } else if(!strcmp(name, "uint32")) { return &ffi_type_uint32; } else if(!strcmp(name, "sint32")) { return &ffi_type_sint32; } else if(!strcmp(name, "uint64")) { return &ffi_type_uint64; } else if(!strcmp(name, "sint64")) { return &ffi_type_sint64; } else if(!strcmp(name, "float")) { return &ffi_type_float; } else if(!strcmp(name, "double")) { return &ffi_type_double; } else if(!strcmp(name, "opaque") || !strcmp(name, "pointer")) { return &ffi_type_pointer; } #ifdef FFI_PL_PROBE_LONGDOUBLE else if(!strcmp(name, "longdouble")) { return &ffi_type_longdouble; } #endif #if FFI_PL_PROBE_COMPLEX else if(!strcmp(name, "complex_float")) { return &ffi_type_complex_float; } else if(!strcmp(name, "complex_double")) { return &ffi_type_complex_double; } #endif else { return NULL; } } Type.xs100644001750001750 2012313065045605 15666 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xsMODULE = FFI::Platypus PACKAGE = FFI::Platypus::Type ffi_pl_type * _new(class, type, platypus_type, array_or_record_or_string_size, type_classname, rw) const char *class const char *type const char *platypus_type size_t array_or_record_or_string_size ffi_pl_string type_classname int rw PREINIT: ffi_pl_type *self; char *buffer; dMY_CXT; CODE: self = NULL; if(!strcmp(platypus_type, "string")) { Newx(buffer, sizeof(ffi_pl_type) + sizeof(ffi_pl_type_extra_string), char); self = (ffi_pl_type*) buffer; self->ffi_type = NULL; self->platypus_type = FFI_PL_STRING; self->extra[0].string.size = array_or_record_or_string_size; if(array_or_record_or_string_size == 0) { self->extra[0].string.platypus_string_type = rw ? FFI_PL_STRING_RW : FFI_PL_STRING_RO; } else { self->extra[0].string.platypus_string_type = FFI_PL_STRING_FIXED; } } else if(!strcmp(platypus_type, "ffi")) { Newx(self, 1, ffi_pl_type); self->ffi_type = NULL; if(!strcmp(type, "longdouble")) { self->platypus_type = FFI_PL_EXOTIC_FLOAT; if(MY_CXT.have_math_longdouble == -1) MY_CXT.have_math_longdouble = have_pm("Math::LongDouble"); } else if(!strcmp(type, "complex_float") || !strcmp(type, "complex_double")) { self->platypus_type = FFI_PL_EXOTIC_FLOAT; if(MY_CXT.have_math_complex == -1) MY_CXT.have_math_complex = have_pm("Math::Complex"); } else { self->platypus_type = FFI_PL_NATIVE; } } else if(!strcmp(platypus_type, "pointer")) { Newx(self, 1, ffi_pl_type); self->ffi_type = NULL; self->platypus_type = FFI_PL_POINTER; } else if(!strcmp(platypus_type, "array")) { Newx(buffer, sizeof(ffi_pl_type) + sizeof(ffi_pl_type_extra_array), char); self = (ffi_pl_type*) buffer; self->ffi_type = NULL; self->platypus_type = FFI_PL_ARRAY; self->extra[0].array.element_count = array_or_record_or_string_size; } else if(!strcmp(platypus_type, "record")) { Newx(buffer, sizeof(ffi_pl_type) + sizeof(ffi_pl_type_extra_record), char); self = (ffi_pl_type*) buffer; self->ffi_type = NULL; self->platypus_type = FFI_PL_RECORD; self->extra[0].record.size = array_or_record_or_string_size; self->extra[0].record.stash = type_classname != NULL ? gv_stashpv(type_classname, GV_ADD) : NULL; } else { croak("unknown ffi/platypus type: %s/%s", type, platypus_type); } if(self != NULL && self->ffi_type == NULL) { self->ffi_type = ffi_pl_name_to_type(type); if(self->ffi_type == NULL) { Safefree(self); self = NULL; croak("unknown ffi/platypus type: %s/%s", type, platypus_type); } } RETVAL = self; OUTPUT: RETVAL ffi_pl_type * _new_custom_perl(class, type, perl_to_native, native_to_perl, perl_to_native_post, argument_count) const char *class const char *type SV *perl_to_native SV *native_to_perl SV *perl_to_native_post int argument_count PREINIT: char *buffer; ffi_pl_type *self; ffi_type *ffi_type; ffi_pl_type_extra_custom_perl *custom; CODE: ffi_type = ffi_pl_name_to_type(type); if(ffi_type == NULL) croak("unknown ffi/platypus type: %s/custom", type); Newx(buffer, sizeof(ffi_pl_type) + sizeof(ffi_pl_type_extra_custom_perl), char); self = (ffi_pl_type*) buffer; self->platypus_type = FFI_PL_CUSTOM_PERL; self->ffi_type = ffi_type; custom = &self->extra[0].custom_perl; custom->perl_to_native = SvOK(perl_to_native) ? SvREFCNT_inc(perl_to_native) : NULL; custom->perl_to_native_post = SvOK(perl_to_native_post) ? SvREFCNT_inc(perl_to_native_post) : NULL; custom->native_to_perl = SvOK(native_to_perl) ? SvREFCNT_inc(native_to_perl) : NULL; custom->argument_count = argument_count-1; RETVAL = self; OUTPUT: RETVAL ffi_pl_type * _new_closure(class, return_type, ...) const char *class; ffi_pl_type *return_type PREINIT: char *buffer; ffi_pl_type *self, *tmp; int i; SV *arg; ffi_type *ffi_return_type; ffi_type **ffi_argument_types; ffi_status ffi_status; CODE: if(return_type->platypus_type != FFI_PL_NATIVE) { croak("Only native types are supported as closure return types"); } for(i=0; i<(items-2); i++) { arg = ST(2+i); tmp = INT2PTR(ffi_pl_type*, SvIV((SV*)SvRV(arg))); if(tmp->platypus_type != FFI_PL_NATIVE && tmp->platypus_type != FFI_PL_STRING) { croak("Only native types and strings are supported as closure argument types"); } } Newx(buffer, sizeof(ffi_pl_type) + sizeof(ffi_pl_type_extra_closure) + sizeof(ffi_pl_type)*(items-2), char); Newx(ffi_argument_types, items-2, ffi_type*); self = (ffi_pl_type*) buffer; self->ffi_type = &ffi_type_pointer; self->platypus_type = FFI_PL_CLOSURE; self->extra[0].closure.return_type = return_type; self->extra[0].closure.flags = 0; if(return_type->platypus_type == FFI_PL_NATIVE) { ffi_return_type = return_type->ffi_type; } else { ffi_return_type = &ffi_type_pointer; } for(i=0; i<(items-2); i++) { arg = ST(2+i); self->extra[0].closure.argument_types[i] = INT2PTR(ffi_pl_type*, SvIV((SV*)SvRV(arg))); if(self->extra[0].closure.argument_types[i]->platypus_type == FFI_PL_NATIVE) { ffi_argument_types[i] = self->extra[0].closure.argument_types[i]->ffi_type; } else { ffi_argument_types[i] = &ffi_type_pointer; } } ffi_status = ffi_prep_cif( &self->extra[0].closure.ffi_cif, FFI_DEFAULT_ABI, items-2, ffi_return_type, ffi_argument_types ); if(ffi_status != FFI_OK) { Safefree(self); Safefree(ffi_argument_types); if(ffi_status == FFI_BAD_TYPEDEF) croak("bad typedef"); else if(ffi_status == FFI_BAD_ABI) croak("bad abi"); else croak("unknown error with ffi_prep_cif"); } if( items-2 == 0 ) { self->extra[0].closure.flags |= G_NOARGS; } if(self->extra[0].closure.return_type->ffi_type->type == FFI_TYPE_VOID && self->extra[0].closure.return_type->platypus_type == FFI_PL_NATIVE) { self->extra[0].closure.flags |= G_DISCARD | G_VOID; } else { self->extra[0].closure.flags |= G_SCALAR; } RETVAL = self; OUTPUT: RETVAL SV* meta(self) ffi_pl_type *self PREINIT: HV *meta; CODE: meta = ffi_pl_get_type_meta(self); RETVAL = newRV_noinc((SV*)meta); OUTPUT: RETVAL int sizeof(self) ffi_pl_type *self CODE: RETVAL = ffi_pl_sizeof(self); OUTPUT: RETVAL void DESTROY(self) ffi_pl_type *self CODE: if(self->platypus_type == FFI_PL_CLOSURE) { if(!PL_dirty) Safefree(self->extra[0].closure.ffi_cif.arg_types); } else if(self->platypus_type == FFI_PL_CUSTOM_PERL) { ffi_pl_type_extra_custom_perl *custom; custom = &self->extra[0].custom_perl; if(custom->perl_to_native != NULL) SvREFCNT_dec(custom->perl_to_native); if(custom->perl_to_native_post != NULL) SvREFCNT_dec(custom->perl_to_native_post); if(custom->native_to_perl != NULL) SvREFCNT_dec(custom->native_to_perl); } if(!PL_dirty) Safefree(self); MODULE = FFI::Platypus PACKAGE = FFI::Platypus::Type::StringPointer void native_to_perl_xs(pointer) SV *pointer PREINIT: const char **string_c; SV *string_perl; CODE: /* we currently use the pp version instead */ if(SvOK(pointer)) { string_c = INT2PTR(const char**,SvIV(pointer)); if(*string_c != NULL) { string_perl = sv_newmortal(); sv_setpv(string_perl, *string_c); ST(0) = newRV_inc(string_perl); } else { ST(0) = newRV_noinc(&PL_sv_undef); } XSRETURN(1); } else { XSRETURN_EMPTY; } 00_diag.t100644001750001750 565013065045605 15562 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Config; use Test::More tests => 1; # This .t file is generated. # make changes instead to dist.ini my %modules; my $post_diag; $modules{$_} = $_ for qw( Alien::Base Alien::FFI Config::AutoConf ExtUtils::CBuilder FFI::CheckLib File::ShareDir JSON::PP Module::Build PkgConfig Test::More constant ); $post_diag = sub { eval { use Alien::FFI; use FFI::Platypus; use FFI::Platypus::Memory; diag "Alien::FFI version = ", $Alien::FFI::VERSION; diag "Alien::FFI->install_type = ", Alien::FFI->install_type; diag "Alien::FFI->cflags = ", Alien::FFI->cflags; diag "Alien::FFI->libs = ", Alien::FFI->libs; diag "Alien::FFI->dist_dir = ", eval { Alien::FFI->dist_dir } || 'undef'; diag "Alien::FFI->version = ", eval { Alien::FFI->config('version') } || 'unknown'; spacer(); require FFI::Platypus::ShareConfig; my $share_config = 'FFI::Platypus::ShareConfig'; my %type_map = %{ $share_config->get('type_map') }; my $diag = $share_config->get('diag'); foreach my $key (sort keys %{ $diag->{args} }) { diag "mb.args.$key=", $diag->{args}->{$key}; } foreach my $key (sort keys %{ $diag->{config} }) { diag "config.$key=", $diag->{config}->{$key}; } diag "ffi.platypus.memory.strdup_impl=$FFI::Platypus::Memory::_strdup_impl"; spacer(); my %r; while(my($k,$v) = each %type_map) { push @{ $r{$v} }, $k; } diag "Types:"; foreach my $type (sort keys %r) { diag sprintf(" %-8s : %s", $type, join(', ', sort @{ $r{$type} })); } spacer(); my $abi = FFI::Platypus->abis; diag "ABIs:"; foreach my $key (sort keys %$abi) { diag sprintf(" %-20s %s", $key, $abi->{$key}); } spacer(); diag "Probes:"; my $probe = $share_config->get("probe"); diag sprintf(" %-20s %s", $_, $probe->{$_}) for keys %$probe; }; diag "extended diagnostic failed: $@" if $@; }; my @modules = sort keys %modules; sub spacer () { diag ''; diag ''; diag ''; } pass 'okay'; my $max = 1; $max = $_ > $max ? $_ : $max for map { length $_ } @modules; our $format = "%-${max}s %s"; spacer; my @keys = sort grep /(MOJO|PERL|\A(LC|HARNESS)_|\A(SHELL|LANG)\Z)/i, keys %ENV; if(@keys > 0) { diag "$_=$ENV{$_}" for @keys; if($ENV{PERL5LIB}) { spacer; diag "PERL5LIB path"; diag $_ for split $Config{path_sep}, $ENV{PERL5LIB}; } elsif($ENV{PERLLIB}) { spacer; diag "PERLLIB path"; diag $_ for split $Config{path_sep}, $ENV{PERLLIB}; } spacer; } diag sprintf $format, 'perl ', $]; foreach my $module (@modules) { if(eval qq{ require $module; 1 }) { my $ver = eval qq{ \$$module\::VERSION }; $ver = 'undef' unless defined $ver; diag sprintf $format, $module, $ver; } else { diag sprintf $format, $module, '-'; } } if($post_diag) { spacer; $post_diag->(); } spacer; threads.t100644001750001750 237413065045605 16011 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More; BEGIN { plan skip_all => 'Test requires a threading Perl' unless eval q{ use threads; 1 } } use FFI::CheckLib; use FFI::Platypus; use Config; plan tests => 2; # if the perl was built under a chroot with a x64_64 kernel, # then the archcname may not be sufficient to verify that this # is a 32bit Perl. Use $Config{longsize} to probe for 64bit Perls. if("$^V" eq "v5.10.0" && $Config{longsize} == 4) { diag ''; diag ''; diag ''; diag "Note that there are known but unresolved issues with Platypus on threaded 5.10.0 32bit Perls."; diag "If you know that you will not be using threads you can safely ignore any failures with"; diag "this test. If you need threads you can either upgrade to 5.10.1+ or downgrade to 5.8.9-"; diag ''; diag "You can also follow along with this issue here:"; diag "https://github.com/plicease/FFI-Platypus/issues/68"; diag ''; diag ''; } my $ffi = FFI::Platypus->new(lib => find_lib(lib => 'test', symbol => 'f0', libpath => 'libtest' )); sub f0 { $ffi->function(f0 => ['uint8'] => 'uint8')->call(@_); } sub otherthread { my $val = f0(22); undef $ffi; $val; } is(threads->create(\&otherthread)->join(), 22, 'works in a thread'); is f0(24), 24, 'works in main thread'; custom.c100644001750001750 152013065045605 16027 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xs#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #include "ffi_platypus.h" #include "ffi_platypus_guts.h" SV* ffi_pl_custom_perl(SV *subref, SV *in_arg, int i) { if(subref == NULL) { return newSVsv(in_arg); } else { dSP; int count; SV *out_arg; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(in_arg); XPUSHs(sv_2mortal(newSViv(i))); PUTBACK; count = call_sv(subref, G_ARRAY); SPAGAIN; if(count >= 1) out_arg = SvREFCNT_inc(POPs); else out_arg = NULL; PUTBACK; FREETMPS; LEAVE; return out_arg; } } void ffi_pl_custom_perl_cb(SV *subref, SV *in_arg, int i) { dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(in_arg); XPUSHs(sv_2mortal(newSViv(i))); PUTBACK; call_sv(subref, G_VOID|G_DISCARD); FREETMPS; LEAVE; } havepm.c100644001750001750 65513065045605 15765 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xs#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #include "ffi_platypus.h" int have_pm(const char *pm_name) { dSP; int value; int count; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv(pm_name,0))); PUTBACK; count = call_pv("FFI::Platypus::_have_pm", G_SCALAR | G_EVAL); SPAGAIN; value = count >= 1 ? POPi : 0; PUTBACK; FREETMPS; LEAVE; return value; } CONTRIBUTING100644001750001750 1075313065045605 15601 0ustar00ollisgollisg000000000000FFI-Platypus-0.47CONTRIBUTING If you have implemented a new feature or fixed a bug then you may make a pull request on this project's GitHub repository: https://github.com/plicease/FFI-Platypus/pulls This project is developed using Dist::Zilla. The project's git repository also comes with Build.PL and cpanfile files necessary for building, testing (and even installing if necessary) without Dist::Zilla. Please keep in mind though that these files are generated so if changes need to be made to those files they should be done through the project's dist.ini file. If you do use Dist::Zilla and already have the necessary plugins installed, then I encourage you to run dzil test before making any pull requests. This is not a requirement, however, I am happy to integrate especially smaller patches that need tweaking to fit the project standards. I may push back and ask you to write a test case or alter the formatting of a patch depending on the amount of time I have and the amount of code that your patch touches. This project's GitHub issue tracker listed above is not Write-Only. If you want to contribute then feel free to browse through the existing issues and see if there is something you feel you might be good at and take a whack at the problem. I frequently open issues myself that I hope will be accomplished by someone in the future but do not have time to immediately implement myself. Another good area to help out in is documentation. I try to make sure that there is good document coverage, that is there should be documentation describing all the public features and warnings about common pitfalls, but an outsider's or alternate view point on such things would be welcome; if you see something confusing or lacks sufficient detail I encourage documentation only pull requests to improve things. The Platypus distribution comes with a test library named libtest that is normally automatically built by ./Build test. If you prefer to use prove or run tests directly, you can use the ./Build libtest command to build it. Example: % perl Build.PL % ./Build % ./Build libtest % prove -bv t # or an individual test % perl -Mblib t/ffi_platypus_memory.t The build process also respects these environment variables: FFI_PLATYPUS_DEBUG Build the XS code portion of Platypus with -g3 instead of what ever optimizing flags that your Perl normally uses. This is useful if you need to debug the C or XS code that comes with Platypus, but do not have a debugging Perl. % env FFI_PLATYPUS_DEBUG=1 perl Build.PL DEBUG: - $Config{lddlflags} = -shared -O2 -L/usr/local/lib -fstack-protector + $Config{lddlflags} = -shared -g3 -L/usr/local/lib -fstack-protector - $Config{optimize} = -O2 + $Config{optimize} = -g3 Created MYMETA.yml and MYMETA.json Creating new 'Build' script for 'FFI-Platypus' version '0.10' FFI_PLATYPUS_DEBUG_FAKE32 When building Platypus on 32 bit Perls, it will use the Math::Int64 C API and make Math::Int64 a prerequisite. Setting this environment variable will force Platypus to build with both of those options on a 64 bit Perl as well. % env FFI_PLATYPUS_DEBUG_FAKE32=1 perl Build.PL DEBUG_FAKE32: + making Math::Int64 a prerequisite (not normally done on 64 bit Perls) + using Math::Int64's C API to manipulate 64 bit values (not normally done on 64 bit Perls) Created MYMETA.yml and MYMETA.json Creating new 'Build' script for 'FFI-Platypus' version '0.10' FFI_PLATYPUS_NO_ALLOCA Platypus uses the non-standard and somewhat controversial C function alloca by default on platforms that support it. I believe that Platypus uses it responsibly to allocate small amounts of memory for argument type parameters, and does not use it to allocate large structures like arrays or buffers. If you prefer not to use alloca despite these precautions, then you can turn its use off by setting this environment variable when you run Build.PL: % env FFI_PLATYPUS_NO_ALLOCA=1 perl Build.PL NO_ALLOCA: + alloca() will not be used, even if your platform supports it. Created MYMETA.yml and MYMETA.json Creating new 'Build' script for 'FFI-Platypus' version '0.10' closure.c100644001750001750 1514613065045605 16222 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xs#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #include "ffi_platypus.h" #include "ffi_platypus_guts.h" #ifndef HAVE_IV_IS_64 #include "perl_math_int64.h" #endif void ffi_pl_closure_add_data(SV *closure, ffi_pl_closure *closure_data) { dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(closure); XPUSHs(sv_2mortal(newSViv(PTR2IV(closure_data)))); XPUSHs(sv_2mortal(newSViv(PTR2IV(closure_data->type)))); PUTBACK; call_pv("FFI::Platypus::Closure::add_data", G_DISCARD); FREETMPS; LEAVE; } ffi_pl_closure * ffi_pl_closure_get_data(SV *closure, ffi_pl_type *type) { dSP; int count; ffi_pl_closure *ret; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(closure); XPUSHs(sv_2mortal(newSViv(PTR2IV(type)))); PUTBACK; count = call_pv("FFI::Platypus::Closure::get_data", G_SCALAR); SPAGAIN; if (count != 1) ret = NULL; else ret = INT2PTR(void*, POPi); PUTBACK; FREETMPS; LEAVE; return ret; } void ffi_pl_closure_call(ffi_cif *ffi_cif, void *result, void **arguments, void *user) { dSP; ffi_pl_closure *closure = (ffi_pl_closure*) user; ffi_pl_type_extra_closure *extra = &closure->type->extra[0].closure; int flags = extra->flags; int i; int count; SV *sv; SV **svp; if(!(flags & G_NOARGS)) { ENTER; SAVETMPS; } PUSHMARK(SP); if(!(flags & G_NOARGS)) { for(i=0; i< ffi_cif->nargs; i++) { if(extra->argument_types[i]->platypus_type == FFI_PL_NATIVE) { switch(extra->argument_types[i]->ffi_type->type) { case FFI_TYPE_VOID: break; case FFI_TYPE_UINT8: sv = sv_newmortal(); sv_setuv(sv, *((uint8_t*)arguments[i])); XPUSHs(sv); break; case FFI_TYPE_SINT8: sv = sv_newmortal(); sv_setiv(sv, *((int8_t*)arguments[i])); XPUSHs(sv); break; case FFI_TYPE_UINT16: sv = sv_newmortal(); sv_setuv(sv, *((uint16_t*)arguments[i])); XPUSHs(sv); break; case FFI_TYPE_SINT16: sv = sv_newmortal(); sv_setiv(sv, *((int16_t*)arguments[i])); XPUSHs(sv); break; case FFI_TYPE_UINT32: sv = sv_newmortal(); sv_setuv(sv, *((uint32_t*)arguments[i])); XPUSHs(sv); break; case FFI_TYPE_SINT32: sv = sv_newmortal(); sv_setiv(sv, *((int32_t*)arguments[i])); XPUSHs(sv); break; case FFI_TYPE_UINT64: sv = sv_newmortal(); #ifdef HAVE_IV_IS_64 sv_setuv(sv, *((uint64_t*)arguments[i])); #else sv_setu64(sv, *((uint64_t*)arguments[i])); #endif XPUSHs(sv); break; case FFI_TYPE_SINT64: sv = sv_newmortal(); #ifdef HAVE_IV_IS_64 sv_setiv(sv, *((int64_t*)arguments[i])); #else sv_seti64(sv, *((int64_t*)arguments[i])); #endif XPUSHs(sv); break; case FFI_TYPE_FLOAT: sv = sv_newmortal(); sv_setnv(sv, *((float*)arguments[i])); XPUSHs(sv); break; case FFI_TYPE_DOUBLE: sv = sv_newmortal(); sv_setnv(sv, *((double*)arguments[i])); XPUSHs(sv); break; case FFI_TYPE_POINTER: sv = sv_newmortal(); if( *((void**)arguments[i]) != NULL) sv_setiv(sv, PTR2IV( *((void**)arguments[i]) )); XPUSHs(sv); break; } } else if(extra->argument_types[i]->platypus_type == FFI_PL_STRING) { sv = sv_newmortal(); if( *((char**)arguments[i]) != NULL) { if(extra->argument_types[i]->extra[0].string.platypus_string_type == FFI_PL_STRING_FIXED) sv_setpvn(sv, *((char**)arguments[i]), extra->argument_types[i]->extra[0].string.size); else sv_setpv(sv, *((char**)arguments[i])); } XPUSHs(sv); } } PUTBACK; } svp = hv_fetch((HV *)SvRV((SV *)closure->coderef), "code", 4, 0); if (svp) count = call_sv(*svp, flags | G_EVAL); else count = 0; if(SvTRUE(ERRSV)) { #ifdef warn_sv warn_sv(ERRSV); #else warn("%s", SvPV_nolen(ERRSV)); #endif } if(!(flags & G_DISCARD)) { SPAGAIN; if(count != 1) sv = &PL_sv_undef; else sv = POPs; if(extra->return_type->platypus_type == FFI_PL_NATIVE) { switch(extra->return_type->ffi_type->type) { case FFI_TYPE_UINT8: #if defined FFI_PL_PROBE_BIGENDIAN ((uint8_t*)result)[3] = SvUV(sv); #elif defined FFI_PL_PROBE_BIGENDIAN64 ((uint8_t*)result)[7] = SvUV(sv); #else *((uint8_t*)result) = SvUV(sv); #endif break; case FFI_TYPE_SINT8: #if defined FFI_PL_PROBE_BIGENDIAN ((int8_t*)result)[3] = SvIV(sv); #elif defined FFI_PL_PROBE_BIGENDIAN64 ((int8_t*)result)[7] = SvIV(sv); #else *((int8_t*)result) = SvIV(sv); #endif break; case FFI_TYPE_UINT16: #if defined FFI_PL_PROBE_BIGENDIAN ((uint16_t*)result)[1] = SvUV(sv); #elif defined FFI_PL_PROBE_BIGENDIAN64 ((uint16_t*)result)[3] = SvUV(sv); #else *((uint16_t*)result) = SvUV(sv); #endif break; case FFI_TYPE_SINT16: #if defined FFI_PL_PROBE_BIGENDIAN ((int16_t*)result)[1] = SvIV(sv); #elif defined FFI_PL_PROBE_BIGENDIAN64 ((int16_t*)result)[3] = SvIV(sv); #else *((int16_t*)result) = SvIV(sv); #endif break; case FFI_TYPE_UINT32: #if defined FFI_PL_PROBE_BIGENDIAN64 ((uint32_t*)result)[1] = SvUV(sv); #else *((uint32_t*)result) = SvUV(sv); #endif break; case FFI_TYPE_SINT32: #if defined FFI_PL_PROBE_BIGENDIAN64 ((int32_t*)result)[1] = SvIV(sv); #else *((int32_t*)result) = SvIV(sv); #endif break; case FFI_TYPE_UINT64: #ifdef HAVE_IV_IS_64 *((uint64_t*)result) = SvUV(sv); #else *((uint64_t*)result) = SvU64(sv); #endif break; case FFI_TYPE_SINT64: #ifdef HAVE_IV_IS_64 *((int64_t*)result) = SvIV(sv); #else *((int64_t*)result) = SvI64(sv); #endif break; case FFI_TYPE_FLOAT: *((float*)result) = SvNV(sv); break; case FFI_TYPE_DOUBLE: *((double*)result) = SvNV(sv); break; case FFI_TYPE_POINTER: *((void**)result) = SvOK(sv) ? INT2PTR(void*, SvIV(sv)) : NULL; break; } } PUTBACK; } if(!(flags & G_NOARGS)) { FREETMPS; LEAVE; } } complex.c100644001750001750 303713065045605 16171 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xs#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #include "ffi_platypus.h" #include "ffi_platypus_guts.h" static double decompose(SV *sv, int imag) { /* Re(z) */ dSP; int count; double result = 0.0; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv); PUTBACK; count = call_pv(imag ? "Math::Complex::Im" : "Math::Complex::Re", G_ARRAY); SPAGAIN; if(count >= 1) result = POPn; PUTBACK; FREETMPS; LEAVE; return result; } void ffi_pl_perl_complex_float(SV *sv, float *ptr) { if(sv_isobject(sv) && sv_derived_from(sv, "Math::Complex")) { ptr[0] = decompose(sv, 0); ptr[1] = decompose(sv, 1); } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) { AV *av = (AV*) SvRV(sv); SV **real_sv, **imag_sv; real_sv = av_fetch(av, 0, 0); imag_sv = av_fetch(av, 1, 0); ptr[0] = real_sv != NULL ? SvNV(*real_sv) : 0.0; ptr[1]= imag_sv != NULL ? SvNV(*imag_sv) : 0.0; } else { ptr[0] = SvNV(sv); ptr[1] = 0.0; } } void ffi_pl_perl_complex_double(SV *sv, double *ptr) { if(sv_isobject(sv) && sv_derived_from(sv, "Math::Complex")) { ptr[0] = decompose(sv, 0); ptr[1] = decompose(sv, 1); } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) { AV *av = (AV*) SvRV(sv); SV **real_sv, **imag_sv; real_sv = av_fetch(av, 0, 0); imag_sv = av_fetch(av, 1, 0); ptr[0] = real_sv != NULL ? SvNV(*real_sv) : 0.0; ptr[1]= imag_sv != NULL ? SvNV(*imag_sv) : 0.0; } else { ptr[0] = SvNV(sv); ptr[1] = 0.0; } } Record.xs100644001750001750 1272213065045605 16171 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xsMODULE = FFI::Platypus PACKAGE = FFI::Platypus::Record void _accessor(perl_name, path_name, type, offset) const char *perl_name ffi_pl_string path_name; ffi_pl_type *type int offset PROTOTYPE: $$$$ PREINIT: ffi_pl_record_member *member; CV *cv; void *function; /* not the correct prototype */ extern void ffi_pl_record_accessor_uint8(); extern void ffi_pl_record_accessor_uint16(); extern void ffi_pl_record_accessor_uint32(); extern void ffi_pl_record_accessor_uint64(); extern void ffi_pl_record_accessor_sint8(); extern void ffi_pl_record_accessor_sint16(); extern void ffi_pl_record_accessor_sint32(); extern void ffi_pl_record_accessor_sint64(); extern void ffi_pl_record_accessor_float(); extern void ffi_pl_record_accessor_double(); extern void ffi_pl_record_accessor_opaque(); extern void ffi_pl_record_accessor_uint8_array(); extern void ffi_pl_record_accessor_uint16_array(); extern void ffi_pl_record_accessor_uint32_array(); extern void ffi_pl_record_accessor_uint64_array(); extern void ffi_pl_record_accessor_sint8_array(); extern void ffi_pl_record_accessor_sint16_array(); extern void ffi_pl_record_accessor_sint32_array(); extern void ffi_pl_record_accessor_sint64_array(); extern void ffi_pl_record_accessor_float_array(); extern void ffi_pl_record_accessor_double_array(); extern void ffi_pl_record_accessor_opaque_array(); extern void ffi_pl_record_accessor_string_ro(); extern void ffi_pl_record_accessor_string_rw(); extern void ffi_pl_record_accessor_string_fixed(); CODE: Newx(member, 1, ffi_pl_record_member); member->offset = offset; if(type->platypus_type == FFI_PL_NATIVE) { member->count = 1; switch(type->ffi_type->type) { case FFI_TYPE_UINT8: function = ffi_pl_record_accessor_uint8; break; case FFI_TYPE_SINT8: function = ffi_pl_record_accessor_sint8; break; case FFI_TYPE_UINT16: function = ffi_pl_record_accessor_uint16; break; case FFI_TYPE_SINT16: function = ffi_pl_record_accessor_sint16; break; case FFI_TYPE_UINT32: function = ffi_pl_record_accessor_uint32; break; case FFI_TYPE_SINT32: function = ffi_pl_record_accessor_sint32; break; case FFI_TYPE_UINT64: function = ffi_pl_record_accessor_uint64; break; case FFI_TYPE_SINT64: function = ffi_pl_record_accessor_sint64; break; case FFI_TYPE_FLOAT: function = ffi_pl_record_accessor_float; break; case FFI_TYPE_DOUBLE: function = ffi_pl_record_accessor_double; break; case FFI_TYPE_POINTER: function = ffi_pl_record_accessor_opaque; break; default: Safefree(member); XSRETURN_PV("type not supported"); break; } } else if(type->platypus_type == FFI_PL_ARRAY) { member->count = type->extra[0].array.element_count; switch(type->ffi_type->type) { case FFI_TYPE_UINT8: function = ffi_pl_record_accessor_uint8_array; break; case FFI_TYPE_SINT8: function = ffi_pl_record_accessor_sint8_array; break; case FFI_TYPE_UINT16: function = ffi_pl_record_accessor_uint16_array; break; case FFI_TYPE_SINT16: function = ffi_pl_record_accessor_sint16_array; break; case FFI_TYPE_UINT32: function = ffi_pl_record_accessor_uint32_array; break; case FFI_TYPE_SINT32: function = ffi_pl_record_accessor_sint32_array; break; case FFI_TYPE_UINT64: function = ffi_pl_record_accessor_uint64_array; break; case FFI_TYPE_SINT64: function = ffi_pl_record_accessor_sint64_array; break; case FFI_TYPE_FLOAT: function = ffi_pl_record_accessor_float_array; break; case FFI_TYPE_DOUBLE: function = ffi_pl_record_accessor_double_array; break; case FFI_TYPE_POINTER: function = ffi_pl_record_accessor_opaque_array; break; default: Safefree(member); XSRETURN_PV("type not supported"); break; } } else if(type->platypus_type == FFI_PL_STRING) { switch(type->extra[0].string.platypus_string_type) { case FFI_PL_STRING_RO: member->count = 1; function = ffi_pl_record_accessor_string_ro; break; case FFI_PL_STRING_RW: member->count = 1; function = ffi_pl_record_accessor_string_rw; break; case FFI_PL_STRING_FIXED: member->count = type->extra[0].string.size; function = ffi_pl_record_accessor_string_fixed; break; } } else { Safefree(member); XSRETURN_PV("type not supported"); } if(path_name == NULL) path_name = "unknown"; /* * this ifdef is needed for Perl 5.8.8 support. * once we don't need to support 5.8.8 we can * remove this workaround (the ndef'd branch) */ #ifdef newXS_flags cv = newXSproto(perl_name, function, path_name, "$;$"); #else newXSproto(perl_name, function, path_name, "$;$"); cv = get_cv(perl_name,0); #endif CvXSUBANY(cv).any_ptr = (void*) member; XSRETURN_EMPTY; My000755001750001750 013065045605 14717 5ustar00ollisgollisg000000000000FFI-Platypus-0.47/incDev.pm100644001750001750 141513065045605 16134 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/Mypackage My::Dev; use strict; use warnings; use File::Spec; my $ppport_version = 3.28; my $ppport_h = File::Spec->catfile(qw( include ppport.h )); sub generate { if(!-r $ppport_h || -d '.git') { require Devel::PPPort; die "Devel::PPPort $ppport_version or better required for development" unless $Devel::PPPort::VERSION >= $ppport_version; my $old = ''; if(-e $ppport_h) { open my $fh, '<', $ppport_h; $old = do { local $/; <$fh> }; close $fh; } my $content = Devel::PPPort::GetFileContents('include/ppport.h'); if($content ne $old) { print "generating new $ppport_h\n"; open my $fh, '>', $ppport_h; print $fh $content; close $fh; } } } sub clean { unlink $ppport_h; } 1; Declare.xs100644001750001750 47413065045605 16253 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xsMODULE = FFI::Platypus PACKAGE = FFI::Platypus::Declare SV* sticky(subref) SV *subref PROTOTYPE: $ CODE: if(sv_isobject(subref) && sv_derived_from(subref, "FFI::Platypus::Closure")) RETVAL = SvREFCNT_inc(SvREFCNT_inc(subref)); else croak("object is not a closure"); OUTPUT: RETVAL type_sint8.t100644001750001750 517513065045605 16467 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 19; use FFI::CheckLib; use FFI::Platypus::Declare 'sint8', 'void', 'int', 'size_t', ['sint8 *' => 'sint8_p'], ['sint8 [10]' => 'sint8_a'], ['sint8 []' => 'sint8_a2'], ['(sint8)->sint8' => 'sint8_c']; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach [sint8_add => 'add'] => [sint8, sint8] => sint8; attach [sint8_inc => 'inc'] => [sint8_p, sint8] => sint8_p; attach [sint8_sum => 'sum'] => [sint8_a] => sint8; attach [sint8_sum2 => 'sum2'] => [sint8_a2,size_t] => sint8; attach [sint8_array_inc => 'array_inc'] => [sint8_a] => void; attach [pointer_null => 'null'] => [] => sint8_p; attach [pointer_is_null => 'is_null'] => [sint8_p] => int; attach [sint8_static_array => 'static_array'] => [] => sint8_a; attach [pointer_null => 'null2'] => [] => sint8_a; is add(-1,2), 1, 'add(-1,2) = 1'; is do { no warnings; add() }, 0, 'add() = 0'; my $i = -3; is ${inc(\$i, 4)}, 1, 'inc(\$i,4) = \1'; is $i, 1, "i=1"; is ${inc(\-3,4)}, 1, 'inc(\-3,4) = \1'; my @list = (-5,-4,-3,-2,-1,0,1,2,3,4); is sum(\@list), -5, 'sum([-5..4]) = -5'; is sum2(\@list,scalar @list), -5, 'sum([-5..4],10) = -5'; array_inc(\@list); do { local $SIG{__WARN__} = sub {}; array_inc() }; is_deeply \@list, [-4,-3,-2,-1,0,1,2,3,4,5], 'array increment'; is null(), undef, 'null() == undef'; is is_null(undef), 1, 'is_null(undef) == 1'; is is_null(), 1, 'is_null() == 1'; is is_null(\22), 0, 'is_null(22) == 0'; is_deeply static_array(), [-1,2,-3,4,-5,6,-7,8,-9,10], 'static_array = [-1,2,-3,4,-5,6,-7,8,-9,10]'; is null2(), undef, 'null2() == undef'; my $closure = closure { $_[0]-2 }; attach [sint8_set_closure => 'set_closure'] => [sint8_c] => void; attach [sint8_call_closure => 'call_closure'] => [sint8] => sint8; set_closure($closure); is call_closure(-2), -4, 'call_closure(-2) = -4'; $closure = closure { undef }; set_closure($closure); is do { no warnings; call_closure(2) }, 0, 'call_closure(2) = 0'; subtest 'custom type input' => sub { plan tests => 2; custom_type type1 => { native_type => 'uint8', perl_to_native => sub { is $_[0], -2; $_[0]*2 } }; attach [sint8_add => 'custom_add'] => ['type1',sint8] => sint8; is custom_add(-2,-1), -5, 'custom_add(-2,-1) = -5'; }; subtest 'custom type output' => sub { plan tests => 2; custom_type type2 => { native_type => 'sint8', native_to_perl => sub { is $_[0], -3; $_[0]*2 } }; attach [sint8_add => 'custom_add2'] => [sint8,sint8] => 'type2'; is custom_add2(-2,-1), -6, 'custom_add2(-2,-1) = -6'; }; attach [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => int; is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; type_float.t100644001750001750 536013065045605 16523 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 19; use FFI::CheckLib; use FFI::Platypus::Declare 'float', 'void', 'int', 'size_t', ['float *' => 'float_p'], ['float [10]' => 'float_a'], ['float []' => 'float_a2'], ['(float)->float' => 'float_c']; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach [float_add => 'add'] => [float, float] => float; attach [float_inc => 'inc'] => [float_p, float] => float_p; attach [float_sum => 'sum'] => [float_a] => float; attach [float_sum2 => 'sum2'] => [float_a2,size_t] => float; attach [float_array_inc => 'array_inc'] => [float_a] => void; attach [pointer_null => 'null'] => [] => float_p; attach [pointer_is_null => 'is_null'] => [float_p] => int; attach [float_static_array => 'static_array'] => [] => float_a; attach [pointer_null => 'null2'] => [] => float_a; is add(1.5,2.5), 4, 'add(1.5,2.5) = 4'; is eval { no warnings; add() }, 0.0, 'add() = 0.0'; my $i = 3.5; is ${inc(\$i, 4.25)}, 7.75, 'inc(\$i,4.25) = \7.75'; is $i, 3.5+4.25, "i=3.5+4.25"; is ${inc(\3,4)}, 7, 'inc(\3,4) = \7'; my @list = (1,2,3,4,5,6,7,8,9,10); is sum(\@list), 55, 'sum([1..10]) = 55'; is sum2(\@list,scalar @list), 55, 'sum2([1..10],10) = 55'; array_inc(\@list); do { local $SIG{__WARN__} = sub {}; array_inc(); }; is_deeply \@list, [2,3,4,5,6,7,8,9,10,11], 'array increment'; is null(), undef, 'null() == undef'; is is_null(undef), 1, 'is_null(undef) == 1'; is is_null(), 1, 'is_null() == 1'; is is_null(\22), 0, 'is_null(22) == 0'; is_deeply static_array(), [-5.5, 5.5, -10, 10, -15.5, 15.5, 20, -20, 25.5, -25.5], 'static_array = [-5.5, 5.5, -10, 10, -15.5, 15.5, 20, -20, 25.5, -25.5]'; is null2(), undef, 'null2() == undef'; my $closure = closure { $_[0]+2.25 }; attach [float_set_closure => 'set_closure'] => [float_c] => void; attach [float_call_closure => 'call_closure'] => [float] => float; set_closure($closure); is call_closure(2.5), 4.75, 'call_closure(2.5) = 4.75'; $closure = closure { undef }; set_closure($closure); is do { no warnings; call_closure(2.5) }, 0, 'call_closure(2.5) = 0'; subtest 'custom type input' => sub { plan tests => 2; custom_type type1 => { native_type => 'float', perl_to_native => sub { is $_[0], 1.25; $_[0]+0.25 } }; attach [float_add => 'custom_add'] => ['type1',float] => float; is custom_add(1.25,2.5), 4, 'custom_add(1.25,2.5) = 4'; }; subtest 'custom type output' => sub { plan tests => 2; custom_type type2 => { native_type => 'float', native_to_perl => sub { is $_[0], 2.0; $_[0]+0.25 } }; attach [float_add => 'custom_add2'] => [float,float] => 'type2'; is custom_add2(1,1), 2.25, 'custom_add2(1,1) = 2.25'; }; attach [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => int; is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; type_uint8.t100644001750001750 556413065045605 16473 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 20; use FFI::CheckLib; use FFI::Platypus::Declare 'uint8', 'void', 'int', 'size_t', ['uint8 *' => 'uint8_p'], ['uint8 [10]' => 'uint8_a'], ['uint8 []' => 'uint8_a2'], ['(uint8)->uint8' => 'uint8_c']; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach [uint8_add => 'add'] => [uint8, uint8] => uint8; attach [uint8_inc => 'inc'] => [uint8_p, uint8] => uint8_p; attach [uint8_sum => 'sum'] => [uint8_a] => uint8; attach [uint8_sum2 => 'sum2'] => [uint8_a2,size_t] => uint8; attach [uint8_array_inc => 'array_inc'] => [uint8_a] => void; attach [pointer_null => 'null'] => [] => uint8_p; attach [pointer_is_null => 'is_null'] => [uint8_p] => int; attach [uint8_static_array => 'static_array'] => [] => uint8_a; attach [pointer_null => 'null2'] => [] => uint8_a; is add(1,2), 3, 'add(1,2) = 3'; is do { no warnings; add() }, 0, 'add() = 0'; my $i = 3; is ${inc(\$i, 4)}, 7, 'inc(\$i,4) = \7'; is $i, 3+4, "i=3+4"; is ${inc(\3,4)}, 7, 'inc(\3,4) = \7'; my @list = (1,2,3,4,5,6,7,8,9,10); is sum(\@list), 55, 'sum([1..10]) = 55'; is sum2(\@list, scalar @list), 55, 'sum2([1..10],10) = 55'; array_inc(\@list); do { local $SIG{__WARN__} = sub {}; array_inc() }; is_deeply \@list, [2,3,4,5,6,7,8,9,10,11], 'array increment'; is null(), undef, 'null() == undef'; is is_null(undef), 1, 'is_null(undef) == 1'; is is_null(), 1, 'is_null() == 1'; is is_null(\22), 0, 'is_null(22) == 0'; is_deeply static_array(), [1,4,6,8,10,12,14,16,18,20], 'static_array = [1,4,6,8,10,12,14,16,18,20]'; is null2(), undef, 'null2() == undef'; my $closure = closure { $_[0]+2 }; attach [uint8_set_closure => 'set_closure'] => [uint8_c] => void; attach [uint8_call_closure => 'call_closure'] => [uint8] => uint8; set_closure($closure); is call_closure(2), 4, 'call_closure(2) = 4'; $closure = closure { undef }; set_closure($closure); is do { no warnings; call_closure(2) }, 0, 'call_closure(2) = 0'; subtest 'custom type input' => sub { plan tests => 2; custom_type type1 => { native_type => 'uint8', perl_to_native => sub { is $_[0], 2; $_[0]*2 } }; attach [uint8_add => 'custom_add'] => ['type1',uint8] => uint8; is custom_add(2,1), 5, 'custom_add(2,1) = 5'; }; subtest 'custom type output' => sub { plan tests => 2; custom_type type2 => { native_type => 'uint8', native_to_perl => sub { is $_[0], 2; $_[0]*2 } }; attach [uint8_add => 'custom_add2'] => [uint8,uint8] => 'type2'; is custom_add2(1,1), 4, 'custom_add2(1,1) = 4'; }; subtest 'custom type post' => sub { plan tests => 2; custom_type type3 => { native_type => 'uint8', perl_to_native_post => sub { is $_[0], 1 } }; attach [uint8_add => 'custom_add3'] => ['type3',uint8] => uint8; is custom_add3(1,2), 3, 'custom_add3(1,2) = 3'; }; attach [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => int; is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; eg000755001750001750 013065045605 14725 5ustar00ollisgollisg000000000000FFI-Platypus-0.47/incsmall.c100644001750001750 156313065045605 16346 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/eg#include #include /* * experiment with libffi and 8 and 16 bit integer * return types */ unsigned char my_foo(void) { return 0xaa; } unsigned short my_bar(void) { return 0xbeef; } int main(int argc, char *argv[]) { ffi_cif ffi_cif; ffi_type *args[1]; int i; void *values[1]; unsigned char bytes[4] = { 0x00, 0x00, 0x00, 0x00 }; unsigned short shorts[2] = { 0x0000, 0x0000 }; if(ffi_prep_cif(&ffi_cif, FFI_DEFAULT_ABI, 0, &ffi_type_uint8, args) == FFI_OK) { ffi_call(&ffi_cif, my_foo, &bytes, values); for(i=0; i<4; i++) { printf("bytes[%d] = %02x\n", i, bytes[i]); } } if(ffi_prep_cif(&ffi_cif, FFI_DEFAULT_ABI, 0, &ffi_type_uint16, args) == FFI_OK) { ffi_call(&ffi_cif, my_bar, &shorts, values); for(i=0; i<2; i++) { printf("shorts[%d] = %04x\n", i, shorts[i]); } } return 0; } Function.xs100644001750001750 1146113065045605 16537 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xsMODULE = FFI::Platypus PACKAGE = FFI::Platypus::Function ffi_pl_function * new(class, platypus, address, abi, return_type, ...) const char *class SV *platypus void *address int abi ffi_pl_type *return_type PREINIT: ffi_pl_function *self; int i,n,j; SV* arg; void *buffer; ffi_type *ffi_return_type; ffi_type **ffi_argument_types; ffi_status ffi_status; ffi_pl_type *tmp; ffi_abi ffi_abi; int extra_arguments; CODE: ffi_abi = abi == -1 ? FFI_DEFAULT_ABI : abi; for(i=0,extra_arguments=0; i<(items-5); i++) { arg = ST(i+5); if(!(sv_isobject(arg) && sv_derived_from(arg, "FFI::Platypus::Type"))) { croak("non-type parameter passed in as type"); } tmp = INT2PTR(ffi_pl_type*, SvIV((SV*) SvRV(arg))); if(tmp->platypus_type == FFI_PL_CUSTOM_PERL) extra_arguments += tmp->extra[0].custom_perl.argument_count; } Newx(buffer, (sizeof(ffi_pl_function) + sizeof(ffi_pl_type*)*(items-5+extra_arguments)), char); self = (ffi_pl_function*)buffer; Newx(ffi_argument_types, items-5+extra_arguments, ffi_type*); self->address = address; self->return_type = return_type; if(return_type->platypus_type == FFI_PL_NATIVE || return_type->platypus_type == FFI_PL_CUSTOM_PERL || return_type->platypus_type == FFI_PL_EXOTIC_FLOAT) { ffi_return_type = return_type->ffi_type; } else { ffi_return_type = &ffi_type_pointer; } for(i=0,n=0; i<(items-5); i++,n++) { arg = ST(i+5); self->argument_types[n] = INT2PTR(ffi_pl_type*, SvIV((SV*) SvRV(arg))); if(self->argument_types[n]->platypus_type == FFI_PL_NATIVE || self->argument_types[n]->platypus_type == FFI_PL_CUSTOM_PERL || self->argument_types[n]->platypus_type == FFI_PL_EXOTIC_FLOAT) { ffi_argument_types[n] = self->argument_types[n]->ffi_type; } else { ffi_argument_types[n] = &ffi_type_pointer; } if(self->argument_types[n]->platypus_type == FFI_PL_CUSTOM_PERL && self->argument_types[n]->extra[0].custom_perl.argument_count > 0) { for(j=1; j-1 < self->argument_types[n]->extra[0].custom_perl.argument_count; j++) { self->argument_types[n+j] = self->argument_types[n]; ffi_argument_types[n+j] = self->argument_types[n]->ffi_type; } n += self->argument_types[n]->extra[0].custom_perl.argument_count; } } ffi_status = ffi_prep_cif( &self->ffi_cif, /* ffi_cif | */ ffi_abi, /* ffi_abi | */ items-5+extra_arguments, /* int | argument count */ ffi_return_type, /* ffi_type * | return type */ ffi_argument_types /* ffi_type ** | argument types */ ); if(ffi_status != FFI_OK) { if(!PL_dirty) { Safefree(self); Safefree(ffi_argument_types); } if(ffi_status == FFI_BAD_TYPEDEF) croak("bad typedef"); else if(ffi_status == FFI_BAD_ABI) croak("bad abi"); else croak("unknown error with ffi_prep_cif"); } self->platypus_sv = SvREFCNT_inc(platypus); RETVAL = self; OUTPUT: RETVAL void call(self, ...) ffi_pl_function *self PREINIT: char *buffer; size_t buffer_size; int i, n, perl_arg_index; SV *arg; ffi_pl_result result; ffi_pl_arguments *arguments; void **argument_pointers; dMY_CXT; CODE: #define EXTRA_ARGS 1 #include "ffi_platypus_call.h" void attach(self, perl_name, path_name, proto) SV *self const char *perl_name ffi_pl_string path_name ffi_pl_string proto PREINIT: CV* cv; CODE: if(!(sv_isobject(self) && sv_derived_from(self, "FFI::Platypus::Function"))) croak("self is not of type FFI::Platypus::Function"); if(path_name == NULL) path_name = "unknown"; if(proto == NULL) cv = newXS(perl_name, ffi_pl_sub_call, path_name); else { /* * this ifdef is needed for Perl 5.8.8 support. * once we don't need to support 5.8.8 we can * remove this workaround (the ndef'd branch) */ #ifdef newXS_flags cv = newXSproto(perl_name, ffi_pl_sub_call, path_name, proto); #else newXSproto(perl_name, ffi_pl_sub_call, path_name, proto); cv = get_cv(perl_name,0); #endif } CvXSUBANY(cv).any_ptr = (void *) INT2PTR(ffi_pl_function*, SvIV((SV*) SvRV(self))); /* * No coresponding decrement !! * once attached, you can never free the function object, or the FFI::Platypus * it was created from. */ SvREFCNT_inc(self); void DESTROY(self) ffi_pl_function *self CODE: SvREFCNT_dec(self->platypus_sv); if(!PL_dirty) { Safefree(self->ffi_cif.arg_types); Safefree(self); } type_opaque.t100644001750001750 1005113065045605 16721 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More; use FFI::CheckLib; use FFI::Platypus::Declare qw( opaque int void string ); use FFI::Platypus::Memory qw( malloc free ); lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach [pointer_null => 'null'] => [] => opaque; attach [pointer_is_null => 'is_null'] => [opaque] => int; attach [pointer_set_my_pointer => 'setp'] => [opaque] => void; attach [pointer_get_my_pointer => 'getp'] => [] => opaque; attach [pointer_get_my_pointer_arg => 'geta'] => ['opaque*'] => void; is null(), undef, 'null = undef'; is is_null(undef), 1, 'is_null(undef) == 1'; is is_null(), 1, 'is_null() == 1'; my $ptr = malloc 32; is is_null($ptr), 0, 'is_null($ptr) = 0'; setp($ptr); is getp(), $ptr, "setp($ptr); getp() = $ptr"; do { my $tmp; geta(\$tmp); is $tmp, $ptr, "get(\$tmp); tmp = $ptr"; }; do { my $tmp = malloc 32; my $tmp2 = $tmp; setp(undef); geta(\$tmp); is $tmp, undef, "get(\\\$tmp); \\\$tmp = undef"; free $tmp2; }; free $ptr; attach [pointer_arg_array_in => 'aa_in'] => ['opaque[3]'] => int; attach [pointer_arg_array_null_in => 'aa_null_in'] => ['opaque[3]'] => int; attach [pointer_arg_array_out => 'aa_out'] => ['opaque[3]'] => void; attach [pointer_arg_array_null_out => 'aa_null_out'] => ['opaque[3]'] => void; do { my @stuff = map { perl_to_c_string_copy($_) } qw( one two three ); is aa_in([@stuff]), 1, "aa_in([one two three])"; free $_ for @stuff; }; is aa_null_in([undef,undef,undef]), 1, "aa_null_in([undef,undef,undef])"; do { my @list = (undef,undef,undef); aa_out(\@list); is_deeply [map { cast opaque => string, $_ } @list], [qw( four five six )], 'aa_out()'; }; do { my @list1 = (malloc 32, malloc 32, malloc 32); my @list2 = @list1; aa_null_out(\@list2); is_deeply [@list2], [undef,undef,undef], 'aa_null_out()'; free $_ for @list1; }; attach [pointer_ret_array_out => 'ra_out'] => [] => 'opaque[3]'; attach [pointer_ret_array_null_out => 'ra_null_out'] => [] => 'opaque[3]'; is_deeply [map { cast opaque => string, $_ } @{ ra_out() } ], [qw( seven eight nine )], "ra_out()"; is_deeply ra_null_out(), [undef,undef,undef], 'ra_null_out'; attach [pointer_pointer_pointer_to_pointer => 'pp2p'] => ['opaque*'] => opaque; attach [pointer_pointer_to_pointer_pointer => 'p2pp'] => [opaque] => 'opaque*'; is pp2p(\undef), undef, 'pp2p(\undef) = undef'; do { my $ptr = malloc 32; is pp2p(\$ptr), $ptr, "pp2p(\\$ptr) = $ptr"; free $ptr; }; is p2pp(undef), \undef, 'p2pp(undef) = \undef'; do { my $ptr = malloc 32; is ${p2pp($ptr)}, $ptr, "pp2p($ptr) = \\$ptr"; free $ptr; }; attach [pointer_set_closure => 'set_closure'] => ['(opaque)->opaque'] => void; attach [pointer_call_closure => 'call_closure'] => [opaque] => opaque; my $save = 1; my $closure = closure { $save = $_[0] }; set_closure($closure); is call_closure(undef), undef, "call_closure(undef) = undef"; is $save, undef, "save = undef"; do { my $ptr = malloc 32; is call_closure($ptr), $ptr, "call_closure(\\$ptr) = $ptr"; is $save, $ptr, "save = $ptr"; free $ptr; }; subtest 'custom type input' => sub { custom_type type1 => { perl_to_native => sub { is cast(opaque=>string,$_[0]), "abc"; free $_[0]; perl_to_c_string_copy("def"); } }; attach [pointer_set_my_pointer => 'custom1_setp'] => ['type1'] => void; custom1_setp(perl_to_c_string_copy("abc")); my $ptr = getp(); is cast(opaque=>string,$ptr), "def"; free $ptr; }; subtest 'custom type output' => sub { setp(perl_to_c_string_copy("ABC")); custom_type type2 => { native_to_perl => sub { is cast(opaque=>string,$_[0]), "ABC"; free $_[0]; "DEF"; } }; attach [pointer_get_my_pointer => 'custom2_getp'] => [] => 'type2'; is custom2_getp(), "DEF"; setp(undef); }; done_testing; package MyPerlStrDup; use FFI::Platypus::Declare; use FFI::Platypus::Memory qw( malloc memcpy ); sub main::perl_to_c_string_copy { my($string) = @_; my $ptr = malloc(length($string)+1); memcpy($ptr, cast('string' => 'opaque', $string), length($string)+1); $ptr; }; type_sint32.t100644001750001750 546513065045605 16546 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/t# # DO NOT MODIFY THIS FILE. # Thisfile generated from similar file t/type_sint8.t # all instances of "int8" have been changed to "int32" # use strict; use warnings; use Test::More tests => 19; use FFI::CheckLib; use FFI::Platypus::Declare 'sint32', 'void', 'int', 'size_t', ['sint32 *' => 'sint32_p'], ['sint32 [10]' => 'sint32_a'], ['sint32 []' => 'sint32_a2'], ['(sint32)->sint32' => 'sint32_c']; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach [sint32_add => 'add'] => [sint32, sint32] => sint32; attach [sint32_inc => 'inc'] => [sint32_p, sint32] => sint32_p; attach [sint32_sum => 'sum'] => [sint32_a] => sint32; attach [sint32_sum2 => 'sum2'] => [sint32_a2,size_t] => sint32; attach [sint32_array_inc => 'array_inc'] => [sint32_a] => void; attach [pointer_null => 'null'] => [] => sint32_p; attach [pointer_is_null => 'is_null'] => [sint32_p] => int; attach [sint32_static_array => 'static_array'] => [] => sint32_a; attach [pointer_null => 'null2'] => [] => sint32_a; is add(-1,2), 1, 'add(-1,2) = 1'; is do { no warnings; add() }, 0, 'add() = 0'; my $i = -3; is ${inc(\$i, 4)}, 1, 'inc(\$i,4) = \1'; is $i, 1, "i=1"; is ${inc(\-3,4)}, 1, 'inc(\-3,4) = \1'; my @list = (-5,-4,-3,-2,-1,0,1,2,3,4); is sum(\@list), -5, 'sum([-5..4]) = -5'; is sum2(\@list,scalar @list), -5, 'sum([-5..4],10) = -5'; array_inc(\@list); do { local $SIG{__WARN__} = sub {}; array_inc() }; is_deeply \@list, [-4,-3,-2,-1,0,1,2,3,4,5], 'array increment'; is null(), undef, 'null() == undef'; is is_null(undef), 1, 'is_null(undef) == 1'; is is_null(), 1, 'is_null() == 1'; is is_null(\22), 0, 'is_null(22) == 0'; is_deeply static_array(), [-1,2,-3,4,-5,6,-7,8,-9,10], 'static_array = [-1,2,-3,4,-5,6,-7,8,-9,10]'; is null2(), undef, 'null2() == undef'; my $closure = closure { $_[0]-2 }; attach [sint32_set_closure => 'set_closure'] => [sint32_c] => void; attach [sint32_call_closure => 'call_closure'] => [sint32] => sint32; set_closure($closure); is call_closure(-2), -4, 'call_closure(-2) = -4'; $closure = closure { undef }; set_closure($closure); is do { no warnings; call_closure(2) }, 0, 'call_closure(2) = 0'; subtest 'custom type input' => sub { plan tests => 2; custom_type type1 => { native_type => 'uint32', perl_to_native => sub { is $_[0], -2; $_[0]*2 } }; attach [sint32_add => 'custom_add'] => ['type1',sint32] => sint32; is custom_add(-2,-1), -5, 'custom_add(-2,-1) = -5'; }; subtest 'custom type output' => sub { plan tests => 2; custom_type type2 => { native_type => 'sint32', native_to_perl => sub { is $_[0], -3; $_[0]*2 } }; attach [sint32_add => 'custom_add2'] => [sint32,sint32] => 'type2'; is custom_add2(-2,-1), -6, 'custom_add2(-2,-1) = -6'; }; attach [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => int; is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; closure_die.t100644001750001750 114713065045605 16651 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 2; use FFI::CheckLib; use FFI::Platypus::Declare qw( void opaque ); lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; my $closure = closure { die "omg i don't want to die!"; }; attach [pointer_set_closure => 'set_closure'] => ['(opaque)->opaque'] => void; attach [pointer_call_closure => 'call_closure'] => [opaque] => opaque; set_closure($closure); my $warning; do { local $SIG{__WARN__} = sub { $warning = $_[0] }; call_closure(undef); }; like $warning, qr{omg i don't want to die}; pass 'does not exit'; note "warning = '$warning'"; type_sint16.t100644001750001750 546513065045605 16550 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/t# # DO NOT MODIFY THIS FILE. # Thisfile generated from similar file t/type_sint8.t # all instances of "int8" have been changed to "int16" # use strict; use warnings; use Test::More tests => 19; use FFI::CheckLib; use FFI::Platypus::Declare 'sint16', 'void', 'int', 'size_t', ['sint16 *' => 'sint16_p'], ['sint16 [10]' => 'sint16_a'], ['sint16 []' => 'sint16_a2'], ['(sint16)->sint16' => 'sint16_c']; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach [sint16_add => 'add'] => [sint16, sint16] => sint16; attach [sint16_inc => 'inc'] => [sint16_p, sint16] => sint16_p; attach [sint16_sum => 'sum'] => [sint16_a] => sint16; attach [sint16_sum2 => 'sum2'] => [sint16_a2,size_t] => sint16; attach [sint16_array_inc => 'array_inc'] => [sint16_a] => void; attach [pointer_null => 'null'] => [] => sint16_p; attach [pointer_is_null => 'is_null'] => [sint16_p] => int; attach [sint16_static_array => 'static_array'] => [] => sint16_a; attach [pointer_null => 'null2'] => [] => sint16_a; is add(-1,2), 1, 'add(-1,2) = 1'; is do { no warnings; add() }, 0, 'add() = 0'; my $i = -3; is ${inc(\$i, 4)}, 1, 'inc(\$i,4) = \1'; is $i, 1, "i=1"; is ${inc(\-3,4)}, 1, 'inc(\-3,4) = \1'; my @list = (-5,-4,-3,-2,-1,0,1,2,3,4); is sum(\@list), -5, 'sum([-5..4]) = -5'; is sum2(\@list,scalar @list), -5, 'sum([-5..4],10) = -5'; array_inc(\@list); do { local $SIG{__WARN__} = sub {}; array_inc() }; is_deeply \@list, [-4,-3,-2,-1,0,1,2,3,4,5], 'array increment'; is null(), undef, 'null() == undef'; is is_null(undef), 1, 'is_null(undef) == 1'; is is_null(), 1, 'is_null() == 1'; is is_null(\22), 0, 'is_null(22) == 0'; is_deeply static_array(), [-1,2,-3,4,-5,6,-7,8,-9,10], 'static_array = [-1,2,-3,4,-5,6,-7,8,-9,10]'; is null2(), undef, 'null2() == undef'; my $closure = closure { $_[0]-2 }; attach [sint16_set_closure => 'set_closure'] => [sint16_c] => void; attach [sint16_call_closure => 'call_closure'] => [sint16] => sint16; set_closure($closure); is call_closure(-2), -4, 'call_closure(-2) = -4'; $closure = closure { undef }; set_closure($closure); is do { no warnings; call_closure(2) }, 0, 'call_closure(2) = 0'; subtest 'custom type input' => sub { plan tests => 2; custom_type type1 => { native_type => 'uint16', perl_to_native => sub { is $_[0], -2; $_[0]*2 } }; attach [sint16_add => 'custom_add'] => ['type1',sint16] => sint16; is custom_add(-2,-1), -5, 'custom_add(-2,-1) = -5'; }; subtest 'custom type output' => sub { plan tests => 2; custom_type type2 => { native_type => 'sint16', native_to_perl => sub { is $_[0], -3; $_[0]*2 } }; attach [sint16_add => 'custom_add2'] => [sint16,sint16] => 'type2'; is custom_add2(-2,-1), -6, 'custom_add2(-2,-1) = -6'; }; attach [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => int; is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; type_uint16.t100644001750001750 606013065045605 16542 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/t# # DO NOT MODIFY THIS FILE. # Thisfile generated from similar file t/type_uint8.t # all instances of "int8" have been changed to "int16" # use strict; use warnings; use Test::More tests => 20; use FFI::CheckLib; use FFI::Platypus::Declare 'uint16', 'void', 'int', 'size_t', ['uint16 *' => 'uint16_p'], ['uint16 [10]' => 'uint16_a'], ['uint16 []' => 'uint16_a2'], ['(uint16)->uint16' => 'uint16_c']; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach [uint16_add => 'add'] => [uint16, uint16] => uint16; attach [uint16_inc => 'inc'] => [uint16_p, uint16] => uint16_p; attach [uint16_sum => 'sum'] => [uint16_a] => uint16; attach [uint16_sum2 => 'sum2'] => [uint16_a2,size_t] => uint16; attach [uint16_array_inc => 'array_inc'] => [uint16_a] => void; attach [pointer_null => 'null'] => [] => uint16_p; attach [pointer_is_null => 'is_null'] => [uint16_p] => int; attach [uint16_static_array => 'static_array'] => [] => uint16_a; attach [pointer_null => 'null2'] => [] => uint16_a; is add(1,2), 3, 'add(1,2) = 3'; is do { no warnings; add() }, 0, 'add() = 0'; my $i = 3; is ${inc(\$i, 4)}, 7, 'inc(\$i,4) = \7'; is $i, 3+4, "i=3+4"; is ${inc(\3,4)}, 7, 'inc(\3,4) = \7'; my @list = (1,2,3,4,5,6,7,8,9,10); is sum(\@list), 55, 'sum([1..10]) = 55'; is sum2(\@list, scalar @list), 55, 'sum2([1..10],10) = 55'; array_inc(\@list); do { local $SIG{__WARN__} = sub {}; array_inc() }; is_deeply \@list, [2,3,4,5,6,7,8,9,10,11], 'array increment'; is null(), undef, 'null() == undef'; is is_null(undef), 1, 'is_null(undef) == 1'; is is_null(), 1, 'is_null() == 1'; is is_null(\22), 0, 'is_null(22) == 0'; is_deeply static_array(), [1,4,6,8,10,12,14,16,18,20], 'static_array = [1,4,6,8,10,12,14,16,18,20]'; is null2(), undef, 'null2() == undef'; my $closure = closure { $_[0]+2 }; attach [uint16_set_closure => 'set_closure'] => [uint16_c] => void; attach [uint16_call_closure => 'call_closure'] => [uint16] => uint16; set_closure($closure); is call_closure(2), 4, 'call_closure(2) = 4'; $closure = closure { undef }; set_closure($closure); is do { no warnings; call_closure(2) }, 0, 'call_closure(2) = 0'; subtest 'custom type input' => sub { plan tests => 2; custom_type type1 => { native_type => 'uint16', perl_to_native => sub { is $_[0], 2; $_[0]*2 } }; attach [uint16_add => 'custom_add'] => ['type1',uint16] => uint16; is custom_add(2,1), 5, 'custom_add(2,1) = 5'; }; subtest 'custom type output' => sub { plan tests => 2; custom_type type2 => { native_type => 'uint16', native_to_perl => sub { is $_[0], 2; $_[0]*2 } }; attach [uint16_add => 'custom_add2'] => [uint16,uint16] => 'type2'; is custom_add2(1,1), 4, 'custom_add2(1,1) = 4'; }; subtest 'custom type post' => sub { plan tests => 2; custom_type type3 => { native_type => 'uint16', perl_to_native_post => sub { is $_[0], 1 } }; attach [uint16_add => 'custom_add3'] => ['type3',uint16] => uint16; is custom_add3(1,2), 3, 'custom_add3(1,2) = 3'; }; attach [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => int; is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; type_uint32.t100644001750001750 606013065045605 16540 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/t# # DO NOT MODIFY THIS FILE. # Thisfile generated from similar file t/type_uint8.t # all instances of "int8" have been changed to "int32" # use strict; use warnings; use Test::More tests => 20; use FFI::CheckLib; use FFI::Platypus::Declare 'uint32', 'void', 'int', 'size_t', ['uint32 *' => 'uint32_p'], ['uint32 [10]' => 'uint32_a'], ['uint32 []' => 'uint32_a2'], ['(uint32)->uint32' => 'uint32_c']; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach [uint32_add => 'add'] => [uint32, uint32] => uint32; attach [uint32_inc => 'inc'] => [uint32_p, uint32] => uint32_p; attach [uint32_sum => 'sum'] => [uint32_a] => uint32; attach [uint32_sum2 => 'sum2'] => [uint32_a2,size_t] => uint32; attach [uint32_array_inc => 'array_inc'] => [uint32_a] => void; attach [pointer_null => 'null'] => [] => uint32_p; attach [pointer_is_null => 'is_null'] => [uint32_p] => int; attach [uint32_static_array => 'static_array'] => [] => uint32_a; attach [pointer_null => 'null2'] => [] => uint32_a; is add(1,2), 3, 'add(1,2) = 3'; is do { no warnings; add() }, 0, 'add() = 0'; my $i = 3; is ${inc(\$i, 4)}, 7, 'inc(\$i,4) = \7'; is $i, 3+4, "i=3+4"; is ${inc(\3,4)}, 7, 'inc(\3,4) = \7'; my @list = (1,2,3,4,5,6,7,8,9,10); is sum(\@list), 55, 'sum([1..10]) = 55'; is sum2(\@list, scalar @list), 55, 'sum2([1..10],10) = 55'; array_inc(\@list); do { local $SIG{__WARN__} = sub {}; array_inc() }; is_deeply \@list, [2,3,4,5,6,7,8,9,10,11], 'array increment'; is null(), undef, 'null() == undef'; is is_null(undef), 1, 'is_null(undef) == 1'; is is_null(), 1, 'is_null() == 1'; is is_null(\22), 0, 'is_null(22) == 0'; is_deeply static_array(), [1,4,6,8,10,12,14,16,18,20], 'static_array = [1,4,6,8,10,12,14,16,18,20]'; is null2(), undef, 'null2() == undef'; my $closure = closure { $_[0]+2 }; attach [uint32_set_closure => 'set_closure'] => [uint32_c] => void; attach [uint32_call_closure => 'call_closure'] => [uint32] => uint32; set_closure($closure); is call_closure(2), 4, 'call_closure(2) = 4'; $closure = closure { undef }; set_closure($closure); is do { no warnings; call_closure(2) }, 0, 'call_closure(2) = 0'; subtest 'custom type input' => sub { plan tests => 2; custom_type type1 => { native_type => 'uint32', perl_to_native => sub { is $_[0], 2; $_[0]*2 } }; attach [uint32_add => 'custom_add'] => ['type1',uint32] => uint32; is custom_add(2,1), 5, 'custom_add(2,1) = 5'; }; subtest 'custom type output' => sub { plan tests => 2; custom_type type2 => { native_type => 'uint32', native_to_perl => sub { is $_[0], 2; $_[0]*2 } }; attach [uint32_add => 'custom_add2'] => [uint32,uint32] => 'type2'; is custom_add2(1,1), 4, 'custom_add2(1,1) = 4'; }; subtest 'custom type post' => sub { plan tests => 2; custom_type type3 => { native_type => 'uint32', perl_to_native_post => sub { is $_[0], 1 } }; attach [uint32_add => 'custom_add3'] => ['type3',uint32] => uint32; is custom_add3(1,2), 3, 'custom_add3(1,2) = 3'; }; attach [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => int; is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; type_uint64.t100644001750001750 606013065045605 16545 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/t# # DO NOT MODIFY THIS FILE. # Thisfile generated from similar file t/type_uint8.t # all instances of "int8" have been changed to "int64" # use strict; use warnings; use Test::More tests => 20; use FFI::CheckLib; use FFI::Platypus::Declare 'uint64', 'void', 'int', 'size_t', ['uint64 *' => 'uint64_p'], ['uint64 [10]' => 'uint64_a'], ['uint64 []' => 'uint64_a2'], ['(uint64)->uint64' => 'uint64_c']; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach [uint64_add => 'add'] => [uint64, uint64] => uint64; attach [uint64_inc => 'inc'] => [uint64_p, uint64] => uint64_p; attach [uint64_sum => 'sum'] => [uint64_a] => uint64; attach [uint64_sum2 => 'sum2'] => [uint64_a2,size_t] => uint64; attach [uint64_array_inc => 'array_inc'] => [uint64_a] => void; attach [pointer_null => 'null'] => [] => uint64_p; attach [pointer_is_null => 'is_null'] => [uint64_p] => int; attach [uint64_static_array => 'static_array'] => [] => uint64_a; attach [pointer_null => 'null2'] => [] => uint64_a; is add(1,2), 3, 'add(1,2) = 3'; is do { no warnings; add() }, 0, 'add() = 0'; my $i = 3; is ${inc(\$i, 4)}, 7, 'inc(\$i,4) = \7'; is $i, 3+4, "i=3+4"; is ${inc(\3,4)}, 7, 'inc(\3,4) = \7'; my @list = (1,2,3,4,5,6,7,8,9,10); is sum(\@list), 55, 'sum([1..10]) = 55'; is sum2(\@list, scalar @list), 55, 'sum2([1..10],10) = 55'; array_inc(\@list); do { local $SIG{__WARN__} = sub {}; array_inc() }; is_deeply \@list, [2,3,4,5,6,7,8,9,10,11], 'array increment'; is null(), undef, 'null() == undef'; is is_null(undef), 1, 'is_null(undef) == 1'; is is_null(), 1, 'is_null() == 1'; is is_null(\22), 0, 'is_null(22) == 0'; is_deeply static_array(), [1,4,6,8,10,12,14,16,18,20], 'static_array = [1,4,6,8,10,12,14,16,18,20]'; is null2(), undef, 'null2() == undef'; my $closure = closure { $_[0]+2 }; attach [uint64_set_closure => 'set_closure'] => [uint64_c] => void; attach [uint64_call_closure => 'call_closure'] => [uint64] => uint64; set_closure($closure); is call_closure(2), 4, 'call_closure(2) = 4'; $closure = closure { undef }; set_closure($closure); is do { no warnings; call_closure(2) }, 0, 'call_closure(2) = 0'; subtest 'custom type input' => sub { plan tests => 2; custom_type type1 => { native_type => 'uint64', perl_to_native => sub { is $_[0], 2; $_[0]*2 } }; attach [uint64_add => 'custom_add'] => ['type1',uint64] => uint64; is custom_add(2,1), 5, 'custom_add(2,1) = 5'; }; subtest 'custom type output' => sub { plan tests => 2; custom_type type2 => { native_type => 'uint64', native_to_perl => sub { is $_[0], 2; $_[0]*2 } }; attach [uint64_add => 'custom_add2'] => [uint64,uint64] => 'type2'; is custom_add2(1,1), 4, 'custom_add2(1,1) = 4'; }; subtest 'custom type post' => sub { plan tests => 2; custom_type type3 => { native_type => 'uint64', perl_to_native_post => sub { is $_[0], 1 } }; attach [uint64_add => 'custom_add3'] => ['type3',uint64] => uint64; is custom_add3(1,2), 3, 'custom_add3(1,2) = 3'; }; attach [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => int; is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; type_record.t100644001750001750 600513065045605 16671 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 2; use FFI::Platypus; use FFI::CheckLib qw( find_lib ); my $lib = find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; my $record_size = My::FooRecord->ffi_record_size; note "record size = $record_size"; subtest 'not a reference' => sub { plan tests => 2; my $ffi = FFI::Platypus->new; $ffi->lib($lib); $ffi->type("record($record_size)" => 'foo_record_t'); my $get_name = $ffi->function( foo_get_name => [ 'foo_record_t' ] => 'string' ); my $get_value = $ffi->function( foo_get_value => [ 'foo_record_t' ] => 'sint32' ); my $is_null = $ffi->function( pointer_is_null => [ 'foo_record_t' ] => 'int' ); my $create = $ffi->function( foo_create => [ 'string', 'sint32' ] => 'foo_record_t' ); my $null = $ffi->function( pointer_null => [] => 'foo_record_t' ); subtest in => sub { plan tests => 3; my $packed = pack('A16l', "hi there\0", 42); note "packed size = ", length $packed; is $get_value->($packed), 42, "get_value(\$packed) = 42"; is $get_name->($packed), "hi there", "get_name(\$packed) = hi there"; is $is_null->(undef), 1, "is_null(undef)"; }; subtest out => sub { plan tests => 3; my $packed = $create->("platypus", 47); note "packed size = ", length $packed; is $get_value->($packed), 47, "get_value(\$packed) = 47"; is $get_name->($packed), 'platypus', "get_value(\$packed) = platypus"; is $null->(), undef, 'null() = undef'; }; }; subtest 'is a reference' => sub { plan tests => 2; my $ffi = FFI::Platypus->new; $ffi->lib($lib); $ffi->type("record(My::FooRecord)" => 'foo_record_t'); my $get_name = $ffi->function( foo_get_name => [ 'foo_record_t' ] => 'string' ); my $get_value = $ffi->function( foo_get_value => [ 'foo_record_t' ] => 'sint32' ); my $is_null = $ffi->function( pointer_is_null => [ 'foo_record_t' ] => 'int' ); my $create = $ffi->function( foo_create => [ 'string', 'sint32' ] => 'foo_record_t' ); my $null = $ffi->function( pointer_null => [] => 'foo_record_t' ); subtest in => sub { plan tests => 3; my $packed = pack('A16l', "hi there\0", 42); note "packed size = ", length $packed; is $get_value->(\$packed), 42, "get_value(\\\$packed) = 42"; is $get_name->(\$packed), "hi there", "get_name(\\\$packed) = hi there"; is $is_null->(\undef), 1, "is_null(\\undef)"; }; subtest out => sub { plan tests => 5; my $packed = $create->("platypus", 47); note "packed size = ", length $packed; isa_ok $packed, 'My::FooRecord'; is $packed->my_method, "starscream", "packed.my_method = starscream"; is $get_value->($packed), 47, "get_value(\$packed) = 47"; is $get_name->($packed), 'platypus', "get_value(\$packed) = platypus"; is $null->(), undef, 'null() = \undef'; }; }; package My::FooRecord; use constant ffi_record_size => do { my $ffi = FFI::Platypus->new; $ffi->sizeof('char[16]') + $ffi->sizeof('sint32'); }; sub my_method { "starscream" } type_string.t100644001750001750 430713065045605 16724 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 17; use FFI::CheckLib; use FFI::Platypus::Declare 'string', 'int', 'void', ['string(10)' => 'string_10'], ['string(5)' => 'string_5']; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach 'string_matches_foobarbaz' => [string] => int; attach 'string_return_foobarbaz' => [] => string; attach [pointer_null => 'null'] => [] => string; attach [pointer_is_null => 'is_null'] => [string] => int; ok string_matches_foobarbaz("foobarbaz"), "string_matches_foobarbaz(foobarbaz) = true"; ok !string_matches_foobarbaz("x"), "string_matches_foobarbaz(foobarbaz) = false"; is string_return_foobarbaz(), "foobarbaz", "string_return_foobarbaz() = foobarbaz"; is null(), undef, 'null() = undef'; is is_null(undef), 1, 'is_null(undef) = 1'; is is_null(), 1, 'is_null() = 1'; is is_null("foo"), 0, 'is_null("foo") = 0'; attach [string_set_closure => 'set_closure'] => ['(string)->void'] => void; attach [string_call_closure => 'call_closure'] => [string]=>void; my $save = 1; my $closure = closure { $save = $_[0] }; set_closure($closure); call_closure("hey there"); is $save, "hey there", "\$save = hey there"; call_closure(undef); is $save, undef, "\$save = undef"; attach ['string_matches_foobarbaz' => 'fixed_input_test'] => ['string_10'] => int; attach ['pointer_is_null' => 'fixed_input_is_null'] => ['string_10'] => int; is fixed_input_test("foobarbaz\0"), 1, "fixed_input_test(foobarbaz\\0)"; is fixed_input_is_null(undef), 1, "fixed_input_is_null(undef)"; attach string_fixed_test => [int] => 'string_5'; is string_fixed_test(0), "zero ", "string_fixed_text(0) = zero"; is string_fixed_test(1), "one ", "string_fixed_text(1) = one"; is string_fixed_test(2), "two ", "string_fixed_text(2) = two"; is string_fixed_test(3), "three", "string_fixed_text(3) = three"; attach [pointer_null => 'fixed_output_null'] => [] => 'string_5'; is fixed_output_null(), undef, 'fixed_output_null()'; attach [string_set_closure => 'set_closure_fixed'] => ['(string_5)->void'] => void; my $closure_fixed = closure { $save = $_[0] }; set_closure_fixed($closure_fixed); call_closure("zero one two three"); is $save, "zero ", "save=zero "; type_double.t100644001750001750 565213065045605 16674 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/t# # DO NOT MODIFY THIS FILE. # Thisfile generated from similar file t/type_float.t # all instances of "float" have been changed to "double" # use strict; use warnings; use Test::More tests => 19; use FFI::CheckLib; use FFI::Platypus::Declare 'double', 'void', 'int', 'size_t', ['double *' => 'double_p'], ['double [10]' => 'double_a'], ['double []' => 'double_a2'], ['(double)->double' => 'double_c']; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach [double_add => 'add'] => [double, double] => double; attach [double_inc => 'inc'] => [double_p, double] => double_p; attach [double_sum => 'sum'] => [double_a] => double; attach [double_sum2 => 'sum2'] => [double_a2,size_t] => double; attach [double_array_inc => 'array_inc'] => [double_a] => void; attach [pointer_null => 'null'] => [] => double_p; attach [pointer_is_null => 'is_null'] => [double_p] => int; attach [double_static_array => 'static_array'] => [] => double_a; attach [pointer_null => 'null2'] => [] => double_a; is add(1.5,2.5), 4, 'add(1.5,2.5) = 4'; is eval { no warnings; add() }, 0.0, 'add() = 0.0'; my $i = 3.5; is ${inc(\$i, 4.25)}, 7.75, 'inc(\$i,4.25) = \7.75'; is $i, 3.5+4.25, "i=3.5+4.25"; is ${inc(\3,4)}, 7, 'inc(\3,4) = \7'; my @list = (1,2,3,4,5,6,7,8,9,10); is sum(\@list), 55, 'sum([1..10]) = 55'; is sum2(\@list,scalar @list), 55, 'sum2([1..10],10) = 55'; array_inc(\@list); do { local $SIG{__WARN__} = sub {}; array_inc(); }; is_deeply \@list, [2,3,4,5,6,7,8,9,10,11], 'array increment'; is null(), undef, 'null() == undef'; is is_null(undef), 1, 'is_null(undef) == 1'; is is_null(), 1, 'is_null() == 1'; is is_null(\22), 0, 'is_null(22) == 0'; is_deeply static_array(), [-5.5, 5.5, -10, 10, -15.5, 15.5, 20, -20, 25.5, -25.5], 'static_array = [-5.5, 5.5, -10, 10, -15.5, 15.5, 20, -20, 25.5, -25.5]'; is null2(), undef, 'null2() == undef'; my $closure = closure { $_[0]+2.25 }; attach [double_set_closure => 'set_closure'] => [double_c] => void; attach [double_call_closure => 'call_closure'] => [double] => double; set_closure($closure); is call_closure(2.5), 4.75, 'call_closure(2.5) = 4.75'; $closure = closure { undef }; set_closure($closure); is do { no warnings; call_closure(2.5) }, 0, 'call_closure(2.5) = 0'; subtest 'custom type input' => sub { plan tests => 2; custom_type type1 => { native_type => 'double', perl_to_native => sub { is $_[0], 1.25; $_[0]+0.25 } }; attach [double_add => 'custom_add'] => ['type1',double] => double; is custom_add(1.25,2.5), 4, 'custom_add(1.25,2.5) = 4'; }; subtest 'custom type output' => sub { plan tests => 2; custom_type type2 => { native_type => 'double', native_to_perl => sub { is $_[0], 2.0; $_[0]+0.25 } }; attach [double_add => 'custom_add2'] => [double,double] => 'type2'; is custom_add2(1,1), 2.25, 'custom_add2(1,1) = 2.25'; }; attach [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => int; is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; type_sint64.t100644001750001750 546513065045605 16553 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/t# # DO NOT MODIFY THIS FILE. # Thisfile generated from similar file t/type_sint8.t # all instances of "int8" have been changed to "int64" # use strict; use warnings; use Test::More tests => 19; use FFI::CheckLib; use FFI::Platypus::Declare 'sint64', 'void', 'int', 'size_t', ['sint64 *' => 'sint64_p'], ['sint64 [10]' => 'sint64_a'], ['sint64 []' => 'sint64_a2'], ['(sint64)->sint64' => 'sint64_c']; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach [sint64_add => 'add'] => [sint64, sint64] => sint64; attach [sint64_inc => 'inc'] => [sint64_p, sint64] => sint64_p; attach [sint64_sum => 'sum'] => [sint64_a] => sint64; attach [sint64_sum2 => 'sum2'] => [sint64_a2,size_t] => sint64; attach [sint64_array_inc => 'array_inc'] => [sint64_a] => void; attach [pointer_null => 'null'] => [] => sint64_p; attach [pointer_is_null => 'is_null'] => [sint64_p] => int; attach [sint64_static_array => 'static_array'] => [] => sint64_a; attach [pointer_null => 'null2'] => [] => sint64_a; is add(-1,2), 1, 'add(-1,2) = 1'; is do { no warnings; add() }, 0, 'add() = 0'; my $i = -3; is ${inc(\$i, 4)}, 1, 'inc(\$i,4) = \1'; is $i, 1, "i=1"; is ${inc(\-3,4)}, 1, 'inc(\-3,4) = \1'; my @list = (-5,-4,-3,-2,-1,0,1,2,3,4); is sum(\@list), -5, 'sum([-5..4]) = -5'; is sum2(\@list,scalar @list), -5, 'sum([-5..4],10) = -5'; array_inc(\@list); do { local $SIG{__WARN__} = sub {}; array_inc() }; is_deeply \@list, [-4,-3,-2,-1,0,1,2,3,4,5], 'array increment'; is null(), undef, 'null() == undef'; is is_null(undef), 1, 'is_null(undef) == 1'; is is_null(), 1, 'is_null() == 1'; is is_null(\22), 0, 'is_null(22) == 0'; is_deeply static_array(), [-1,2,-3,4,-5,6,-7,8,-9,10], 'static_array = [-1,2,-3,4,-5,6,-7,8,-9,10]'; is null2(), undef, 'null2() == undef'; my $closure = closure { $_[0]-2 }; attach [sint64_set_closure => 'set_closure'] => [sint64_c] => void; attach [sint64_call_closure => 'call_closure'] => [sint64] => sint64; set_closure($closure); is call_closure(-2), -4, 'call_closure(-2) = -4'; $closure = closure { undef }; set_closure($closure); is do { no warnings; call_closure(2) }, 0, 'call_closure(2) = 0'; subtest 'custom type input' => sub { plan tests => 2; custom_type type1 => { native_type => 'uint64', perl_to_native => sub { is $_[0], -2; $_[0]*2 } }; attach [sint64_add => 'custom_add'] => ['type1',sint64] => sint64; is custom_add(-2,-1), -5, 'custom_add(-2,-1) = -5'; }; subtest 'custom type output' => sub { plan tests => 2; custom_type type2 => { native_type => 'sint64', native_to_perl => sub { is $_[0], -3; $_[0]*2 } }; attach [sint64_add => 'custom_add2'] => [sint64,sint64] => 'type2'; is custom_add2(-2,-1), -6, 'custom_add2(-2,-1) = -6'; }; attach [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => int; is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; Probe.pm100644001750001750 1275113065045605 16512 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/Mypackage My::Probe; use strict; use warnings; use if $^O eq 'MSWin32', 'Win32::ErrorMode'; use File::Glob qw( bsd_glob ); use File::Spec; use Config; use File::Temp qw( tempdir ); use File::Copy qw( copy ); use File::Path qw( rmtree ); use My::ShareConfig; sub probe { my($class, $mb) = @_; my $probe_include = File::Spec->catfile('include', 'ffi_platypus_probe.h'); return if -e $probe_include && My::ShareConfig->new->get('probe'); $mb->add_to_cleanup($probe_include); do { my $fh; open $fh, '>', $probe_include; close $fh; }; my $b = $mb->cbuilder; my %probe; foreach my $cfile (bsd_glob 'inc/probe/*.c') { my $name = (File::Spec->splitpath($cfile))[2]; $name =~ s{\.c$}{}; my $obj = eval { $b->compile( source => $cfile, include_dirs => [ 'include' ], extra_compiler_flags => $mb->extra_compiler_flags, ) }; next if $@; $mb->add_to_cleanup($obj) if $mb; my($exe,@rest) = eval { $b->link_executable( objects => $obj, extra_linker_flags => $mb->extra_linker_flags, ) }; next if $@; $mb->add_to_cleanup($exe,@rest) if $mb; my $ret = run($exe, '--test'); $probe{$name} = 1 if $ret == 0; } do { my $fh; open $fh, '>', $probe_include; print $fh "#ifndef FFI_PLATYPUS_PROBE_H\n"; print $fh "#define FFI_PLATYPUS_PROBE_H\n"; foreach my $key (sort keys %probe) { print $fh "#define FFI_PL_PROBE_", uc($key), " 1\n"; } print $fh "#endif\n"; close $fh; }; $class->probe_abi($mb); My::ShareConfig->new->set( probe => \%probe ); return; } sub run { my @cmd = @_; # 1. annoyance the first: # Strawberry Perl 5.20.0 and better comes with libffi # unfortunately it is distributed as a .dll and to make # things a little worse the .exe files generated for some # reason link to a .dll with a different name. if($^O eq 'MSWin32' && $Config{myuname} =~ /strawberry-perl/ && $] >= 5.020) { my($vol, $dir, $file) = File::Spec->splitpath($^X); my @dirs = File::Spec->splitdir($dir); splice @dirs, -3; my $path = (File::Spec->catdir($vol, @dirs, qw( c bin ))); $path =~ s{\\}{/}g; my($dll) = bsd_glob("$path/libffi*.dll"); my @cleanup; foreach my $line (`objdump -p $cmd[0]`) { next unless $line =~ /^\s+DLL Name: (libffi.*\.dll)/; my $want = $1; next if $dll eq $want; copy($dll, $want); push @cleanup, $want; } } # 2. annoyance the second # If there isa problem with the .exe generated it may pop up a # dialog, but we don't want to stop the build, as this may be # normal if the probe is supposed to fail. local $Win32::ErrorMode::ErrorMode = 0x3; print "@cmd\n"; system @cmd; my $ret = $?; if($ret == -1) { print "FAILED TO EXECUTE $!\n" } elsif($ret & 127) { print "DIED with signal ", ($ret & 127), "\n" } else { print "exit = ", $ret >> 8, "\n" } $ret; } sub probe_abi { my($class, $mb) = @_; print "probing for ABIs...\n"; mkdir '.abi-probe-test'; my $dir = tempdir( CLEANUP => 1, DIR => '.abi-probe-test' ); my $file_c = File::Spec->catfile($dir, "ffitest.c"); if($^O eq 'MSWin32' && $file_c =~ /\s/) { $file_c = Win32::GetShortPathName($file_c); } do { my $fh; open $fh, '>', $file_c; print $fh "#include \n"; close $fh; }; my @cpp_flags = grep /^-[DI]/, @{ $mb->extra_compiler_flags }; print "$Config{cpprun} @cpp_flags $file_c\n"; my $text = join '', grep !/^#/, `$Config{cpprun} @cpp_flags $file_c`; if($?) { print "C pre-processor failed...\n"; print "only default will be available.\n"; return; } my %abi; if($text =~ m/typedef\s+enum\s+ffi_abi\s+{(.*?)}/s) { my $enum = $1; #print "[enum]\n"; #print "$enum\n"; while($enum =~ s/FFI_([A-Z_0-9]+)//) { my $abi = $1; next if $abi =~ /^(FIRST|LAST)_ABI$/; $abi{lc $abi} = -1; } } my $template_c = File::Spec->catfile(qw( inc template abi.c )); my $b = $mb->cbuilder; foreach my $abi (sort keys %abi) { my $file_c = File::Spec->catfile($dir, "$abi.c"); do { my $in; my $out; open $in, '<', $template_c; open $out, '>', $file_c; my $line; while(1) { $line = <$in>; last unless defined $line; $line =~ s/##ARG##/"FFI_".uc($abi)/eg; print $out $line; } close $out; close $in; }; my $obj = eval { $b->compile( source => $file_c, include_dirs => [ 'include' ], extra_compiler_flags => [ @{ $mb->extra_compiler_flags }, '-DTRY_FFI_ABI=FFI_'.uc $abi ], ) }; next if $@; my $exe = eval { $b->link_executable( objects => $obj, extra_linker_flags => $mb->extra_linker_flags, ) }; next if $@; local $Win32::ErrorMode::ErrorMode = 0x3; if($^O eq 'MSWin32' && $file_c =~ /\s/) { $exe = Win32::GetShortPathName($exe); } my $out = `$exe`; if($? == -1) { die "unable to execute: $exe"; } elsif($? == 0 && $out =~ /\|value=([0-9]+)\|/) { $abi{$abi} = $1; } } foreach my $abi (sort keys %abi) { if($abi{$abi} == -1) { delete $abi{$abi}; next; } print " found abi: $abi = $abi{$abi}\n"; } My::ShareConfig->new->set( abi => \%abi ); rmtree('.abi-probe-test', { verbose => 0 }); return; } 1; probe000755001750001750 013065045605 15441 5ustar00ollisgollisg000000000000FFI-Platypus-0.47/incabi.c100644001750001750 36413065045605 16463 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/probe#include "ffi_platypus.h" int main(int argc, char *argv[]) { ffi_cif cif; ffi_type *args[1]; ffi_abi abi; abi = FFI_DEFAULT_ABI; if(ffi_prep_cif(&cif, abi, 0, &ffi_type_void, args) == FFI_OK) { return 0; } return 2; } libtest000755001750001750 013065045605 15227 5ustar00ollisgollisg000000000000FFI-Platypus-0.47float.c100644001750001750 167613065045605 16652 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/libtest#include "libtest.h" EXTERN float float_add(float a, float b) { return a + b; } EXTERN float* float_inc(float *a, float b) { static float keeper; keeper = *a += b; return &keeper; } EXTERN float float_sum(float list[10]) { int i; float total; for(i=0,total=0; i<10; i++) { total += list[i]; } return total; } EXTERN float float_sum2(float *list, size_t size) { int i; float total; for(i=0,total=0; imy_uint64; } EXTERN uint32_t align_get_uint32(my_struct *my_struct) { return my_struct->my_uint32; } EXTERN uint16_t align_get_uint16(my_struct *my_struct) { return my_struct->my_uint16; } EXTERN uint8_t align_get_uint8(my_struct *my_struct) { return my_struct->my_uint8; } EXTERN int64_t align_get_sint64(my_struct *my_struct) { return my_struct->my_sint64; } EXTERN int32_t align_get_sint32(my_struct *my_struct) { return my_struct->my_sint32; } EXTERN int16_t align_get_sint16(my_struct *my_struct) { return my_struct->my_sint16; } EXTERN int8_t align_get_sint8(my_struct *my_struct) { return my_struct->my_sint8; } EXTERN float align_get_float(my_struct *my_struct) { return my_struct->my_float; } EXTERN double align_get_double(my_struct *my_struct) { return my_struct->my_double; } EXTERN void * align_get_opaque(my_struct *my_struct) { return my_struct->my_opaque; } sint8.c100644001750001750 166613065045605 16611 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/libtest#include "libtest.h" EXTERN int8_t sint8_add(int8_t a, int8_t b) { return a + b; } EXTERN int8_t* sint8_inc(int8_t *a, int8_t b) { static int8_t keeper; keeper = *a += b; return &keeper; } EXTERN int8_t sint8_sum(int8_t list[10]) { int i; int8_t total; for(i=0,total=0; i<10; i++) { total += list[i]; } return total; } EXTERN int8_t sint8_sum2(int8_t *list, size_t size) { int i; int8_t total; for(i=0,total=0; ired = red; self->green = green; self->blue = blue; return self; } EXTERN int color_get_red(color *self) { return self->red; } EXTERN void color_set_red(color *self, int value) { self->red = value; } EXTERN int color_get_green(color *self) { return self->green; } EXTERN void color_set_green(color *self, int value) { self->green = value; } EXTERN int color_get_blue(color *self) { return self->blue; } EXTERN void color_set_blue(color *self, int value) { self->blue = value; } EXTERN void color_DESTROY(color *self) { free(self); } EXTERN size_t color_ffi_record_size() { return sizeof(color); } uint8.c100644001750001750 171213065045605 16603 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/libtest#include "libtest.h" EXTERN uint8_t uint8_add(uint8_t a, uint8_t b) { return a + b; } EXTERN uint8_t* uint8_inc(uint8_t *a, uint8_t b) { static uint8_t keeper; keeper = *a += b; return &keeper; } EXTERN uint8_t uint8_sum(uint8_t list[10]) { int i; uint8_t total; for(i=0,total=0; i<10; i++) { total += list[i]; } return total; } EXTERN uint8_t uint8_sum2(uint8_t *list, size_t size) { int i; uint8_t total; for(i=0,total=0; i 'test requires Test::EOL' unless eval q{ use Test::EOL; 1 }; }; use Test::EOL; use FindBin; use File::Spec; chdir(File::Spec->catdir($FindBin::Bin, File::Spec->updir, File::Spec->updir)); all_perl_files_ok(grep { -e $_ } qw( bin lib t Makefile.PL )); pod.t100644001750001750 47413065045605 16612 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xt/authoruse strict; use warnings; use Test::More; BEGIN { plan skip_all => 'test requires Test::Pod' unless eval q{ use Test::Pod; 1 }; }; use Test::Pod; use FindBin; use File::Spec; chdir(File::Spec->catdir($FindBin::Bin, File::Spec->updir, File::Spec->updir)); all_pod_files_ok( grep { -e $_ } qw( bin lib )); share000755001750001750 013065045605 14663 5ustar00ollisgollisg000000000000FFI-Platypus-0.47README.txt100644001750001750 10013065045605 16470 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/shareThis readme is a placeholder so the directory won't be removed. examples000755001750001750 013065045605 15377 5ustar00ollisgollisg000000000000FFI-Platypus-0.47char.pl100644001750001750 62713065045605 16776 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->type('int' => 'character'); my @list = qw( alnum alpha ascii blank cntrl digit lower print punct space upper xdigit ); $ffi->attach("is$_" => ['character'] => 'int') for @list; my $char = shift(@ARGV) || 'a'; no strict 'refs'; printf "'%s' is %s %s\n", $char, $_, &{'is'.$_}(ord $char) for @list; time.pl100644001750001750 340313065045605 17032 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use Convert::Binary::C; use FFI::Platypus; use Data::Dumper qw( Dumper ); my $c = Convert::Binary::C->new; # Alignment of zero (0) means use # the alignment of your CPU $c->configure( Alignment => 0 ); # parse the tm record structure so # that Convert::Binary::C knows # what to spit out and suck in $c->parse(<sizeof("tm"); # create the Platypus instance and create the appropriate # types and functions my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->type("record($tm_size)" => 'tm'); $ffi->attach( [ localtime => 'my_localtime' ] => ['time_t*'] => 'tm' ); $ffi->attach( [ time => 'my_time' ] => ['tm'] => 'time_t' ); # =============================================== # get the tm struct from the C localtime function # note that we pass in a reference to the value that time # returns because localtime takes a pointer to time_t # for some reason. my $time_hashref = $c->unpack( tm => my_localtime(\time) ); # tm_zone comes back from Convert::Binary::C as an opaque, # cast it into a string. We localize it to just this do # block so that it will be a pointer when we pass it back # to C land below. do { local $time_hashref->{tm_zone} = $ffi->cast(opaque => string => $time_hashref->{tm_zone}); print Dumper($time_hashref); }; # =============================================== # convert the tm struct back into an epoch value my $time = my_time( $c->pack( tm => $time_hashref ) ); print "time = $time\n"; print "perl time = ", time, "\n"; uuid.pl100644001750001750 112213065045605 17036 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use FFI::CheckLib; use FFI::Platypus; use FFI::Platypus::Memory qw( malloc free ); my $ffi = FFI::Platypus->new; $ffi->lib(find_lib_or_exit lib => 'uuid'); $ffi->type('string(37)' => 'uuid_string'); $ffi->type('record(16)' => 'uuid_t'); $ffi->attach(uuid_generate => ['uuid_t'] => 'void'); $ffi->attach(uuid_unparse => ['uuid_t','uuid_string'] => 'void'); my $uuid = "\0" x 16; # uuid_t uuid_generate($uuid); my $string = "\0" x 37; # 36 bytes to store a UUID string # + NUL termination uuid_unparse($uuid, $string); print "$string\n"; math.pl100644001750001750 57013065045605 17007 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use FFI::Platypus; use FFI::CheckLib; my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->attach(puts => ['string'] => 'int'); $ffi->attach(fdim => ['double','double'] => 'double'); puts(fdim(7.0, 2.0)); $ffi->attach(cos => ['double'] => 'double'); puts(cos(2.0)); $ffi->attach(fmax => ['double', 'double'] => 'double'); puts(fmax(2.0,3.0)); zmq3.pl100644001750001750 440313065045605 16767 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use constant ZMQ_IO_THREADS => 1; use constant ZMQ_MAX_SOCKETS => 2; use constant ZMQ_REQ => 3; use constant ZMQ_REP => 4; use FFI::CheckLib qw( find_lib_or_exit ); use FFI::Platypus; use FFI::Platypus::Memory qw( malloc ); use FFI::Platypus::Buffer qw( scalar_to_buffer buffer_to_scalar ); my $endpoint = "ipc://zmq-ffi-$$"; my $ffi = FFI::Platypus->new; $ffi->lib(undef); # for puts $ffi->attach(puts => ['string'] => 'int'); $ffi->lib(find_lib_or_exit lib => 'zmq'); $ffi->attach(zmq_version => ['int*', 'int*', 'int*'] => 'void'); my($major,$minor,$patch); zmq_version(\$major, \$minor, \$patch); puts("libzmq version $major.$minor.$patch"); die "this script only works with libzmq 3 or better" unless $major >= 3; $ffi->type('opaque' => 'zmq_context'); $ffi->type('opaque' => 'zmq_socket'); $ffi->type('opaque' => 'zmq_msg_t'); $ffi->attach(zmq_ctx_new => [] => 'zmq_context'); $ffi->attach(zmq_ctx_set => ['zmq_context', 'int', 'int'] => 'int'); $ffi->attach(zmq_socket => ['zmq_context', 'int'] => 'zmq_socket'); $ffi->attach(zmq_connect => ['opaque', 'string'] => 'int'); $ffi->attach(zmq_bind => ['zmq_socket', 'string'] => 'int'); $ffi->attach(zmq_send => ['zmq_socket', 'opaque', 'size_t', 'int'] => 'int'); $ffi->attach(zmq_msg_init => ['zmq_msg_t'] => 'int'); $ffi->attach(zmq_msg_recv => ['zmq_msg_t', 'zmq_socket', 'int'] => 'int'); $ffi->attach(zmq_msg_data => ['zmq_msg_t'] => 'opaque'); $ffi->attach(zmq_errno => [] => 'int'); $ffi->attach(zmq_strerror => ['int'] => 'string'); my $context = zmq_ctx_new(); zmq_ctx_set($context, ZMQ_IO_THREADS, 1); my $socket1 = zmq_socket($context, ZMQ_REQ); zmq_connect($socket1, $endpoint); my $socket2 = zmq_socket($context, ZMQ_REP); zmq_bind($socket2, $endpoint); do { # send our $sent_message = "hello there"; my($pointer, $size) = scalar_to_buffer $sent_message; my $r = zmq_send($socket1, $pointer, $size, 0); die zmq_strerror(zmq_errno()) if $r == -1; }; do { # recv my $msg_ptr = malloc 100; zmq_msg_init($msg_ptr); my $size = zmq_msg_recv($msg_ptr, $socket2, 0); die zmq_strerror(zmq_errno()) if $size == -1; my $data_ptr = zmq_msg_data($msg_ptr); my $recv_message = buffer_to_scalar $data_ptr, $size; print "recv_message = $recv_message\n"; }; pipe.pl100644001750001750 33713065045605 17014 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->attach([pipe=>'mypipe'] => ['int[2]'] => 'int'); my @fd = (0,0); mypipe(\@fd); my($fd1,$fd2) = @fd; print "$fd1 $fd2\n"; complex.c100644001750001750 241413065045605 16701 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/eg#include #include #include /* * experiment with libffi and complex types */ float my_float_real(float complex c) { return crealf(c); } float my_float_imag(float complex c) { return cimagf(c); } double my_double_real(double complex c) { return creal(c); } double my_double_imag(double complex c) { return cimag(c); } int main(int argc, char *argv[]) { ffi_cif ffi_cif; ffi_type *args[1]; void *values[1]; args[0] = &ffi_type_complex_float; if(ffi_prep_cif(&ffi_cif, FFI_DEFAULT_ABI, 1, &ffi_type_float, args) == FFI_OK) { float answer; float complex input; input = 1.0 + 2.0 * I; values[0] = &input; ffi_call(&ffi_cif, &my_float_real, &answer, values); printf("crealf = %g\n", answer); ffi_call(&ffi_cif, &my_float_imag, &answer, values); printf("cimagf = %g\n", answer); } args[0] = &ffi_type_complex_double; if(ffi_prep_cif(&ffi_cif, FFI_DEFAULT_ABI, 1, &ffi_type_double, args) == FFI_OK) { double answer; double complex input; input = 1.0 + 2.0 * I; values[0] = &input; ffi_call(&ffi_cif, &my_double_real, &answer, values); printf("crealf = %g\n", answer); ffi_call(&ffi_cif, &my_double_imag, &answer, values); printf("cimagf = %g\n", answer); } } uint64.c100644001750001750 217113065045605 16665 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/libtest/* * DO NOT MODIFY THIS FILE. * Thisfile generated from similar file libtest/uint8.c * all instances of "int8" have been changed to "int64" */ #include "libtest.h" EXTERN uint64_t uint64_add(uint64_t a, uint64_t b) { return a + b; } EXTERN uint64_t* uint64_inc(uint64_t *a, uint64_t b) { static uint64_t keeper; keeper = *a += b; return &keeper; } EXTERN uint64_t uint64_sum(uint64_t list[10]) { int i; uint64_t total; for(i=0,total=0; i<10; i++) { total += list[i]; } return total; } EXTERN uint64_t uint64_sum2(uint64_t *list, size_t size) { int i; uint64_t total; for(i=0,total=0; iname; } EXTERN int32_t foo_get_value(foo_record_t *self) { if(self == NULL) return 0; return self->value; } EXTERN foo_record_t * foo_create(const char *name, int32_t value) { static foo_record_t myfoo; strcpy((char*)myfoo.name, name); myfoo.value = value; return &myfoo; } double.c100644001750001750 215713065045605 17012 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/libtest/* * DO NOT MODIFY THIS FILE. * Thisfile generated from similar file libtest/float.c * all instances of "float" have been changed to "double" */ #include "libtest.h" EXTERN double double_add(double a, double b) { return a + b; } EXTERN double* double_inc(double *a, double b) { static double keeper; keeper = *a += b; return &keeper; } EXTERN double double_sum(double list[10]) { int i; double total; for(i=0,total=0; i<10; i++) { total += list[i]; } return total; } EXTERN double double_sum2(double *list, size_t size) { int i; double total; for(i=0,total=0; i is designed to support operation with Perl installations back to 5.003, and has been tested up to 5.20. =head1 OPTIONS =head2 --help Display a brief usage summary. =head2 --version Display the version of F. =head2 --patch=I If this option is given, a single patch file will be created if any changes are suggested. This requires a working diff program to be installed on your system. =head2 --copy=I If this option is given, a copy of each file will be saved with the given suffix that contains the suggested changes. This does not require any external programs. Note that this does not automagically add a dot between the original filename and the suffix. If you want the dot, you have to include it in the option argument. If neither C<--patch> or C<--copy> are given, the default is to simply print the diffs for each file. This requires either C or a C program to be installed. =head2 --diff=I Manually set the diff program and options to use. The default is to use C, when installed, and output unified context diffs. =head2 --compat-version=I Tell F to check for compatibility with the given Perl version. The default is to check for compatibility with Perl version 5.003. You can use this option to reduce the output of F if you intend to be backward compatible only down to a certain Perl version. =head2 --cplusplus Usually, F will detect C++ style comments and replace them with C style comments for portability reasons. Using this option instructs F to leave C++ comments untouched. =head2 --quiet Be quiet. Don't print anything except fatal errors. =head2 --nodiag Don't output any diagnostic messages. Only portability alerts will be printed. =head2 --nohints Don't output any hints. Hints often contain useful portability notes. Warnings will still be displayed. =head2 --nochanges Don't suggest any changes. Only give diagnostic output and hints unless these are also deactivated. =head2 --nofilter Don't filter the list of input files. By default, files not looking like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. =head2 --strip Strip all script and documentation functionality from F. This reduces the size of F dramatically and may be useful if you want to include F in smaller modules without increasing their distribution size too much. The stripped F will have a C<--unstrip> option that allows you to undo the stripping, but only if an appropriate C module is installed. =head2 --list-provided Lists the API elements for which compatibility is provided by F. Also lists if it must be explicitly requested, if it has dependencies, and if there are hints or warnings for it. =head2 --list-unsupported Lists the API elements that are known not to be supported by F and below which version of Perl they probably won't be available or work. =head2 --api-info=I Show portability information for API elements matching I. If I is surrounded by slashes, it is interpreted as a regular expression. =head1 DESCRIPTION In order for a Perl extension (XS) module to be as portable as possible across differing versions of Perl itself, certain steps need to be taken. =over 4 =item * Including this header is the first major one. This alone will give you access to a large part of the Perl API that hasn't been available in earlier Perl releases. Use perl include/ppport.h --list-provided to see which API elements are provided by include/ppport.h. =item * You should avoid using deprecated parts of the API. For example, using global Perl variables without the C prefix is deprecated. Also, some API functions used to have a C prefix. Using this form is also deprecated. You can safely use the supported API, as F will provide wrappers for older Perl versions. =item * If you use one of a few functions or variables that were not present in earlier versions of Perl, and that can't be provided using a macro, you have to explicitly request support for these functions by adding one or more C<#define>s in your source code before the inclusion of F. These functions or variables will be marked C in the list shown by C<--list-provided>. Depending on whether you module has a single or multiple files that use such functions or variables, you want either C or global variants. For a C function or variable (used only in a single source file), use: #define NEED_function #define NEED_variable For a global function or variable (used in multiple source files), use: #define NEED_function_GLOBAL #define NEED_variable_GLOBAL Note that you mustn't have more than one global request for the same function or variable in your project. Function / Variable Static Request Global Request ----------------------------------------------------------------------------------------- PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL SvRX() NEED_SvRX NEED_SvRX_GLOBAL caller_cx() NEED_caller_cx NEED_caller_cx_GLOBAL eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL grok_number() NEED_grok_number NEED_grok_number_GLOBAL grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL gv_fetchpvn_flags() NEED_gv_fetchpvn_flags NEED_gv_fetchpvn_flags_GLOBAL load_module() NEED_load_module NEED_load_module_GLOBAL mg_findext() NEED_mg_findext NEED_mg_findext_GLOBAL my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL pv_display() NEED_pv_display NEED_pv_display_GLOBAL pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL sv_unmagicext() NEED_sv_unmagicext NEED_sv_unmagicext_GLOBAL vload_module() NEED_vload_module NEED_vload_module_GLOBAL vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL warner() NEED_warner NEED_warner_GLOBAL To avoid namespace conflicts, you can change the namespace of the explicitly exported functions / variables using the C macro. Just C<#define> the macro before including C: #define DPPP_NAMESPACE MyOwnNamespace_ #include "include/ppport.h" The default namespace is C. =back The good thing is that most of the above can be checked by running F on your source code. See the next section for details. =head1 EXAMPLES To verify whether F is needed for your module, whether you should make any changes to your code, and whether any special defines should be used, F can be run as a Perl script to check your source code. Simply say: perl include/ppport.h The result will usually be a list of patches suggesting changes that should at least be acceptable, if not necessarily the most efficient solution, or a fix for all possible problems. If you know that your XS module uses features only available in newer Perl releases, if you're aware that it uses C++ comments, and if you want all suggestions as a single patch file, you could use something like this: perl include/ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff If you only want your code to be scanned without any suggestions for changes, use: perl include/ppport.h --nochanges You can specify a different C program or options, using the C<--diff> option: perl include/ppport.h --diff='diff -C 10' This would output context diffs with 10 lines of context. If you want to create patched copies of your files instead, use: perl include/ppport.h --copy=.new To display portability information for the C function, use: perl include/ppport.h --api-info=newSVpvn Since the argument to C<--api-info> can be a regular expression, you can use perl include/ppport.h --api-info=/_nomg$/ to display portability information for all C<_nomg> functions or perl include/ppport.h --api-info=/./ to display information for all known API elements. =head1 BUGS If this version of F is causing failure during the compilation of this module, please check if newer versions of either this module or C are available on CPAN before sending a bug report. If F was generated using the latest version of C and is causing failure of this module, please file a bug report here: L Please include the following information: =over 4 =item 1. The complete output from running "perl -V" =item 2. This file. =item 3. The name and version of the module you were trying to build. =item 4. A full log of the build that failed. =item 5. Any other information that you think could be relevant. =back For the latest version of this code, please get the C module from CPAN. =head1 COPYRIGHT Version 3.x, Copyright (c) 2004-2013, Marcus Holland-Moritz. Version 2.x, Copyright (C) 2001, Paul Marquess. Version 1.x, Copyright (C) 1999, Kenneth Albanowski. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO See L. =cut use strict; # Disable broken TRIE-optimization BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } my $VERSION = 3.35; my %opt = ( quiet => 0, diag => 1, hints => 1, changes => 1, cplusplus => 0, filter => 1, strip => 0, version => 0, ); my($ppport) = $0 =~ /([\w.]+)$/; my $LF = '(?:\r\n|[\r\n])'; # line feed my $HS = "[ \t]"; # horizontal whitespace # Never use C comments in this file! my $ccs = '/'.'*'; my $cce = '*'.'/'; my $rccs = quotemeta $ccs; my $rcce = quotemeta $cce; eval { require Getopt::Long; Getopt::Long::GetOptions(\%opt, qw( help quiet diag! filter! hints! changes! cplusplus strip version patch=s copy=s diff=s compat-version=s list-provided list-unsupported api-info=s )) or usage(); }; if ($@ and grep /^-/, @ARGV) { usage() if "@ARGV" =~ /^--?h(?:elp)?$/; die "Getopt::Long not found. Please don't use any options.\n"; } if ($opt{version}) { print "This is $0 $VERSION.\n"; exit 0; } usage() if $opt{help}; strip() if $opt{strip}; if (exists $opt{'compat-version'}) { my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; if ($@) { die "Invalid version number format: '$opt{'compat-version'}'\n"; } die "Only Perl 5 is supported\n" if $r != 5; die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; } else { $opt{'compat-version'} = 5; } my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ ? ( $1 => { ($2 ? ( base => $2 ) : ()), ($3 ? ( todo => $3 ) : ()), (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), } ) : die "invalid spec: $_" } qw( ASCII_TO_NEED||5.007001|n AvFILLp|5.004050||p AvFILL||| BhkDISABLE||5.024000| BhkENABLE||5.024000| BhkENTRY_set||5.024000| BhkENTRY||| BhkFLAGS||| CALL_BLOCK_HOOKS||| CLASS|||n CPERLscope|5.005000||p CX_CURPAD_SAVE||| CX_CURPAD_SV||| C_ARRAY_END|5.013002||p C_ARRAY_LENGTH|5.008001||p CopFILEAV|5.006000||p CopFILEGV_set|5.006000||p CopFILEGV|5.006000||p CopFILESV|5.006000||p CopFILE_set|5.006000||p CopFILE|5.006000||p CopSTASHPV_set|5.006000||p CopSTASHPV|5.006000||p CopSTASH_eq|5.006000||p CopSTASH_set|5.006000||p CopSTASH|5.006000||p CopyD|5.009002|5.004050|p Copy||| CvPADLIST||5.008001| CvSTASH||| CvWEAKOUTSIDE||| DECLARATION_FOR_LC_NUMERIC_MANIPULATION||5.021010|n DEFSV_set|5.010001||p DEFSV|5.004050||p DO_UTF8||5.006000| END_EXTERN_C|5.005000||p ENTER||| ERRSV|5.004050||p EXTEND||| EXTERN_C|5.005000||p F0convert|||n FREETMPS||| GIMME_V||5.004000|n GIMME|||n GROK_NUMERIC_RADIX|5.007002||p G_ARRAY||| G_DISCARD||| G_EVAL||| G_METHOD|5.006001||p G_NOARGS||| G_SCALAR||| G_VOID||5.004000| GetVars||| GvAV||| GvCV||| GvHV||| GvSV||| Gv_AMupdate||5.011000| HEf_SVKEY|5.003070||p HeHASH||5.003070| HeKEY||5.003070| HeKLEN||5.003070| HePV||5.004000| HeSVKEY_force||5.003070| HeSVKEY_set||5.004000| HeSVKEY||5.003070| HeUTF8|5.010001|5.008000|p HeVAL||5.003070| HvENAMELEN||5.015004| HvENAMEUTF8||5.015004| HvENAME||5.013007| HvNAMELEN_get|5.009003||p HvNAMELEN||5.015004| HvNAMEUTF8||5.015004| HvNAME_get|5.009003||p HvNAME||| INT2PTR|5.006000||p IN_LOCALE_COMPILETIME|5.007002||p IN_LOCALE_RUNTIME|5.007002||p IN_LOCALE|5.007002||p IN_PERL_COMPILETIME|5.008001||p IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p IS_NUMBER_INFINITY|5.007002||p IS_NUMBER_IN_UV|5.007002||p IS_NUMBER_NAN|5.007003||p IS_NUMBER_NEG|5.007002||p IS_NUMBER_NOT_INT|5.007002||p IVSIZE|5.006000||p IVTYPE|5.006000||p IVdf|5.006000||p LEAVE||| LINKLIST||5.013006| LVRET||| MARK||| MULTICALL||5.024000| MUTABLE_PTR|5.010001||p MUTABLE_SV|5.010001||p MY_CXT_CLONE|5.009002||p MY_CXT_INIT|5.007003||p MY_CXT|5.007003||p MoveD|5.009002|5.004050|p Move||| NATIVE_TO_NEED||5.007001|n NOOP|5.005000||p NUM2PTR|5.006000||p NVTYPE|5.006000||p NVef|5.006001||p NVff|5.006001||p NVgf|5.006001||p Newxc|5.009003||p Newxz|5.009003||p Newx|5.009003||p Nullav||| Nullch||| Nullcv||| Nullhv||| Nullsv||| OP_CLASS||5.013007| OP_DESC||5.007003| OP_NAME||5.007003| OP_TYPE_IS_OR_WAS||5.019010| OP_TYPE_IS||5.019007| ORIGMARK||| OpHAS_SIBLING|5.021007||p OpLASTSIB_set|5.021011||p OpMAYBESIB_set|5.021011||p OpMORESIB_set|5.021011||p OpSIBLING|5.021007||p PAD_BASE_SV||| PAD_CLONE_VARS||| PAD_COMPNAME_FLAGS||| PAD_COMPNAME_GEN_set||| PAD_COMPNAME_GEN||| PAD_COMPNAME_OURSTASH||| PAD_COMPNAME_PV||| PAD_COMPNAME_TYPE||| PAD_RESTORE_LOCAL||| PAD_SAVE_LOCAL||| PAD_SAVE_SETNULLPAD||| PAD_SETSV||| PAD_SET_CUR_NOSAVE||| PAD_SET_CUR||| PAD_SVl||| PAD_SV||| PERLIO_FUNCS_CAST|5.009003||p PERLIO_FUNCS_DECL|5.009003||p PERL_ABS|5.008001||p PERL_BCDVERSION|5.024000||p PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p PERL_HASH|5.003070||p PERL_INT_MAX|5.003070||p PERL_INT_MIN|5.003070||p PERL_LONG_MAX|5.003070||p PERL_LONG_MIN|5.003070||p PERL_MAGIC_arylen|5.007002||p PERL_MAGIC_backref|5.007002||p PERL_MAGIC_bm|5.007002||p PERL_MAGIC_collxfrm|5.007002||p PERL_MAGIC_dbfile|5.007002||p PERL_MAGIC_dbline|5.007002||p PERL_MAGIC_defelem|5.007002||p PERL_MAGIC_envelem|5.007002||p PERL_MAGIC_env|5.007002||p PERL_MAGIC_ext|5.007002||p PERL_MAGIC_fm|5.007002||p PERL_MAGIC_glob|5.024000||p PERL_MAGIC_isaelem|5.007002||p PERL_MAGIC_isa|5.007002||p PERL_MAGIC_mutex|5.024000||p PERL_MAGIC_nkeys|5.007002||p PERL_MAGIC_overload_elem|5.024000||p PERL_MAGIC_overload_table|5.007002||p PERL_MAGIC_overload|5.024000||p PERL_MAGIC_pos|5.007002||p PERL_MAGIC_qr|5.007002||p PERL_MAGIC_regdata|5.007002||p PERL_MAGIC_regdatum|5.007002||p PERL_MAGIC_regex_global|5.007002||p PERL_MAGIC_shared_scalar|5.007003||p PERL_MAGIC_shared|5.007003||p PERL_MAGIC_sigelem|5.007002||p PERL_MAGIC_sig|5.007002||p PERL_MAGIC_substr|5.007002||p PERL_MAGIC_sv|5.007002||p PERL_MAGIC_taint|5.007002||p PERL_MAGIC_tiedelem|5.007002||p PERL_MAGIC_tiedscalar|5.007002||p PERL_MAGIC_tied|5.007002||p PERL_MAGIC_utf8|5.008001||p PERL_MAGIC_uvar_elem|5.007003||p PERL_MAGIC_uvar|5.007002||p PERL_MAGIC_vec|5.007002||p PERL_MAGIC_vstring|5.008001||p PERL_PV_ESCAPE_ALL|5.009004||p PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p PERL_PV_ESCAPE_NOCLEAR|5.009004||p PERL_PV_ESCAPE_QUOTE|5.009004||p PERL_PV_ESCAPE_RE|5.009005||p PERL_PV_ESCAPE_UNI_DETECT|5.009004||p PERL_PV_ESCAPE_UNI|5.009004||p PERL_PV_PRETTY_DUMP|5.009004||p PERL_PV_PRETTY_ELLIPSES|5.010000||p PERL_PV_PRETTY_LTGT|5.009004||p PERL_PV_PRETTY_NOCLEAR|5.010000||p PERL_PV_PRETTY_QUOTE|5.009004||p PERL_PV_PRETTY_REGPROP|5.009004||p PERL_QUAD_MAX|5.003070||p PERL_QUAD_MIN|5.003070||p PERL_REVISION|5.006000||p PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p PERL_SCAN_DISALLOW_PREFIX|5.007003||p PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p PERL_SCAN_SILENT_ILLDIGIT|5.008001||p PERL_SHORT_MAX|5.003070||p PERL_SHORT_MIN|5.003070||p PERL_SIGNALS_UNSAFE_FLAG|5.008001||p PERL_SUBVERSION|5.006000||p PERL_SYS_INIT3||5.006000| PERL_SYS_INIT||| PERL_SYS_TERM||5.024000| PERL_UCHAR_MAX|5.003070||p PERL_UCHAR_MIN|5.003070||p PERL_UINT_MAX|5.003070||p PERL_UINT_MIN|5.003070||p PERL_ULONG_MAX|5.003070||p PERL_ULONG_MIN|5.003070||p PERL_UNUSED_ARG|5.009003||p PERL_UNUSED_CONTEXT|5.009004||p PERL_UNUSED_DECL|5.007002||p PERL_UNUSED_RESULT|5.021001||p PERL_UNUSED_VAR|5.007002||p PERL_UQUAD_MAX|5.003070||p PERL_UQUAD_MIN|5.003070||p PERL_USE_GCC_BRACE_GROUPS|5.009004||p PERL_USHORT_MAX|5.003070||p PERL_USHORT_MIN|5.003070||p PERL_VERSION|5.006000||p PL_DBsignal|5.005000||p PL_DBsingle|||pn PL_DBsub|||pn PL_DBtrace|||pn PL_Sv|5.005000||p PL_bufend|5.024000||p PL_bufptr|5.024000||p PL_check||5.006000| PL_compiling|5.004050||p PL_comppad_name||5.017004| PL_comppad||5.008001| PL_copline|5.024000||p PL_curcop|5.004050||p PL_curpad||5.005000| PL_curstash|5.004050||p PL_debstash|5.004050||p PL_defgv|5.004050||p PL_diehook|5.004050||p PL_dirty|5.004050||p PL_dowarn|||pn PL_errgv|5.004050||p PL_error_count|5.024000||p PL_expect|5.024000||p PL_hexdigit|5.005000||p PL_hints|5.005000||p PL_in_my_stash|5.024000||p PL_in_my|5.024000||p PL_keyword_plugin||5.011002| PL_last_in_gv|||n PL_laststatval|5.005000||p PL_lex_state|5.024000||p PL_lex_stuff|5.024000||p PL_linestr|5.024000||p PL_modglobal||5.005000|n PL_na|5.004050||pn PL_no_modify|5.006000||p PL_ofsgv|||n PL_opfreehook||5.011000|n PL_parser|5.009005||p PL_peepp||5.007003|n PL_perl_destruct_level|5.004050||p PL_perldb|5.004050||p PL_ppaddr|5.006000||p PL_rpeepp||5.013005|n PL_rsfp_filters|5.024000||p PL_rsfp|5.024000||p PL_rs|||n PL_signals|5.008001||p PL_stack_base|5.004050||p PL_stack_sp|5.004050||p PL_statcache|5.005000||p PL_stdingv|5.004050||p PL_sv_arenaroot|5.004050||p PL_sv_no|5.004050||pn PL_sv_undef|5.004050||pn PL_sv_yes|5.004050||pn PL_tainted|5.004050||p PL_tainting|5.004050||p PL_tokenbuf|5.024000||p POP_MULTICALL||5.024000| POPi|||n POPl|||n POPn|||n POPpbytex||5.007001|n POPpx||5.005030|n POPp|||n POPs|||n POPul||5.006000|n POPu||5.004000|n PTR2IV|5.006000||p PTR2NV|5.006000||p PTR2UV|5.006000||p PTR2nat|5.009003||p PTR2ul|5.007001||p PTRV|5.006000||p PUSHMARK||| PUSH_MULTICALL||5.024000| PUSHi||| PUSHmortal|5.009002||p PUSHn||| PUSHp||| PUSHs||| PUSHu|5.004000||p PUTBACK||| PadARRAY||5.024000| PadMAX||5.024000| PadlistARRAY||5.024000| PadlistMAX||5.024000| PadlistNAMESARRAY||5.024000| PadlistNAMESMAX||5.024000| PadlistNAMES||5.024000| PadlistREFCNT||5.017004| PadnameIsOUR||| PadnameIsSTATE||| PadnameLEN||5.024000| PadnameOURSTASH||| PadnameOUTER||| PadnamePV||5.024000| PadnameREFCNT_dec||5.024000| PadnameREFCNT||5.024000| PadnameSV||5.024000| PadnameTYPE||| PadnameUTF8||5.021007| PadnamelistARRAY||5.024000| PadnamelistMAX||5.024000| PadnamelistREFCNT_dec||5.024000| PadnamelistREFCNT||5.024000| PerlIO_clearerr||5.007003| PerlIO_close||5.007003| PerlIO_context_layers||5.009004| PerlIO_eof||5.007003| PerlIO_error||5.007003| PerlIO_fileno||5.007003| PerlIO_fill||5.007003| PerlIO_flush||5.007003| PerlIO_get_base||5.007003| PerlIO_get_bufsiz||5.007003| PerlIO_get_cnt||5.007003| PerlIO_get_ptr||5.007003| PerlIO_read||5.007003| PerlIO_restore_errno||| PerlIO_save_errno||| PerlIO_seek||5.007003| PerlIO_set_cnt||5.007003| PerlIO_set_ptrcnt||5.007003| PerlIO_setlinebuf||5.007003| PerlIO_stderr||5.007003| PerlIO_stdin||5.007003| PerlIO_stdout||5.007003| PerlIO_tell||5.007003| PerlIO_unread||5.007003| PerlIO_write||5.007003| Perl_signbit||5.009005|n PoisonFree|5.009004||p PoisonNew|5.009004||p PoisonWith|5.009004||p Poison|5.008000||p READ_XDIGIT||5.017006| RESTORE_LC_NUMERIC||5.024000| RETVAL|||n Renewc||| Renew||| SAVECLEARSV||| SAVECOMPPAD||| SAVEPADSV||| SAVETMPS||| SAVE_DEFSV|5.004050||p SPAGAIN||| SP||| START_EXTERN_C|5.005000||p START_MY_CXT|5.007003||p STMT_END|||p STMT_START|||p STORE_LC_NUMERIC_FORCE_TO_UNDERLYING||5.024000| STORE_LC_NUMERIC_SET_TO_NEEDED||5.024000| STR_WITH_LEN|5.009003||p ST||| SV_CONST_RETURN|5.009003||p SV_COW_DROP_PV|5.008001||p SV_COW_SHARED_HASH_KEYS|5.009005||p SV_GMAGIC|5.007002||p SV_HAS_TRAILING_NUL|5.009004||p SV_IMMEDIATE_UNREF|5.007001||p SV_MUTABLE_RETURN|5.009003||p SV_NOSTEAL|5.009002||p SV_SMAGIC|5.009003||p SV_UTF8_NO_ENCODING|5.008001||p SVfARG|5.009005||p SVf_UTF8|5.006000||p SVf|5.006000||p SVt_INVLIST||5.019002| SVt_IV||| SVt_NULL||| SVt_NV||| SVt_PVAV||| SVt_PVCV||| SVt_PVFM||| SVt_PVGV||| SVt_PVHV||| SVt_PVIO||| SVt_PVIV||| SVt_PVLV||| SVt_PVMG||| SVt_PVNV||| SVt_PV||| SVt_REGEXP||5.011000| Safefree||| Slab_Alloc||| Slab_Free||| Slab_to_ro||| Slab_to_rw||| StructCopy||| SvCUR_set||| SvCUR||| SvEND||| SvGAMAGIC||5.006001| SvGETMAGIC|5.004050||p SvGROW||| SvIOK_UV||5.006000| SvIOK_notUV||5.006000| SvIOK_off||| SvIOK_only_UV||5.006000| SvIOK_only||| SvIOK_on||| SvIOKp||| SvIOK||| SvIVX||| SvIV_nomg|5.009001||p SvIV_set||| SvIVx||| SvIV||| SvIsCOW_shared_hash||5.008003| SvIsCOW||5.008003| SvLEN_set||| SvLEN||| SvLOCK||5.007003| SvMAGIC_set|5.009003||p SvNIOK_off||| SvNIOKp||| SvNIOK||| SvNOK_off||| SvNOK_only||| SvNOK_on||| SvNOKp||| SvNOK||| SvNVX||| SvNV_nomg||5.013002| SvNV_set||| SvNVx||| SvNV||| SvOK||| SvOOK_offset||5.011000| SvOOK||| SvPOK_off||| SvPOK_only_UTF8||5.006000| SvPOK_only||| SvPOK_on||| SvPOKp||| SvPOK||| SvPVX_const|5.009003||p SvPVX_mutable|5.009003||p SvPVX||| SvPV_const|5.009003||p SvPV_flags_const_nolen|5.009003||p SvPV_flags_const|5.009003||p SvPV_flags_mutable|5.009003||p SvPV_flags|5.007002||p SvPV_force_flags_mutable|5.009003||p SvPV_force_flags_nolen|5.009003||p SvPV_force_flags|5.007002||p SvPV_force_mutable|5.009003||p SvPV_force_nolen|5.009003||p SvPV_force_nomg_nolen|5.009003||p SvPV_force_nomg|5.007002||p SvPV_force|||p SvPV_mutable|5.009003||p SvPV_nolen_const|5.009003||p SvPV_nolen|5.006000||p SvPV_nomg_const_nolen|5.009003||p SvPV_nomg_const|5.009003||p SvPV_nomg_nolen|5.013007||p SvPV_nomg|5.007002||p SvPV_renew|5.009003||p SvPV_set||| SvPVbyte_force||5.009002| SvPVbyte_nolen||5.006000| SvPVbytex_force||5.006000| SvPVbytex||5.006000| SvPVbyte|5.006000||p SvPVutf8_force||5.006000| SvPVutf8_nolen||5.006000| SvPVutf8x_force||5.006000| SvPVutf8x||5.006000| SvPVutf8||5.006000| SvPVx||| SvPV||| SvREFCNT_dec_NN||5.017007| SvREFCNT_dec||| SvREFCNT_inc_NN|5.009004||p SvREFCNT_inc_simple_NN|5.009004||p SvREFCNT_inc_simple_void_NN|5.009004||p SvREFCNT_inc_simple_void|5.009004||p SvREFCNT_inc_simple|5.009004||p SvREFCNT_inc_void_NN|5.009004||p SvREFCNT_inc_void|5.009004||p SvREFCNT_inc|||p SvREFCNT||| SvROK_off||| SvROK_on||| SvROK||| SvRV_set|5.009003||p SvRV||| SvRXOK|5.009005||p SvRX|5.009005||p SvSETMAGIC||| SvSHARED_HASH|5.009003||p SvSHARE||5.007003| SvSTASH_set|5.009003||p SvSTASH||| SvSetMagicSV_nosteal||5.004000| SvSetMagicSV||5.004000| SvSetSV_nosteal||5.004000| SvSetSV||| SvTAINTED_off||5.004000| SvTAINTED_on||5.004000| SvTAINTED||5.004000| SvTAINT||| SvTHINKFIRST||| SvTRUE_nomg||5.013006| SvTRUE||| SvTYPE||| SvUNLOCK||5.007003| SvUOK|5.007001|5.006000|p SvUPGRADE||| SvUTF8_off||5.006000| SvUTF8_on||5.006000| SvUTF8||5.006000| SvUVXx|5.004000||p SvUVX|5.004000||p SvUV_nomg|5.009001||p SvUV_set|5.009003||p SvUVx|5.004000||p SvUV|5.004000||p SvVOK||5.008001| SvVSTRING_mg|5.009004||p THIS|||n UNDERBAR|5.009002||p UTF8SKIP||5.006000| UTF8_MAXBYTES|5.009002||p UVCHR_SKIP||5.022000| UVSIZE|5.006000||p UVTYPE|5.006000||p UVXf|5.007001||p UVof|5.006000||p UVuf|5.006000||p UVxf|5.006000||p WARN_ALL|5.006000||p WARN_AMBIGUOUS|5.006000||p WARN_ASSERTIONS|5.024000||p WARN_BAREWORD|5.006000||p WARN_CLOSED|5.006000||p WARN_CLOSURE|5.006000||p WARN_DEBUGGING|5.006000||p WARN_DEPRECATED|5.006000||p WARN_DIGIT|5.006000||p WARN_EXEC|5.006000||p WARN_EXITING|5.006000||p WARN_GLOB|5.006000||p WARN_INPLACE|5.006000||p WARN_INTERNAL|5.006000||p WARN_IO|5.006000||p WARN_LAYER|5.008000||p WARN_MALLOC|5.006000||p WARN_MISC|5.006000||p WARN_NEWLINE|5.006000||p WARN_NUMERIC|5.006000||p WARN_ONCE|5.006000||p WARN_OVERFLOW|5.006000||p WARN_PACK|5.006000||p WARN_PARENTHESIS|5.006000||p WARN_PIPE|5.006000||p WARN_PORTABLE|5.006000||p WARN_PRECEDENCE|5.006000||p WARN_PRINTF|5.006000||p WARN_PROTOTYPE|5.006000||p WARN_QW|5.006000||p WARN_RECURSION|5.006000||p WARN_REDEFINE|5.006000||p WARN_REGEXP|5.006000||p WARN_RESERVED|5.006000||p WARN_SEMICOLON|5.006000||p WARN_SEVERE|5.006000||p WARN_SIGNAL|5.006000||p WARN_SUBSTR|5.006000||p WARN_SYNTAX|5.006000||p WARN_TAINT|5.006000||p WARN_THREADS|5.008000||p WARN_UNINITIALIZED|5.006000||p WARN_UNOPENED|5.006000||p WARN_UNPACK|5.006000||p WARN_UNTIE|5.006000||p WARN_UTF8|5.006000||p WARN_VOID|5.006000||p WIDEST_UTYPE|5.015004||p XCPT_CATCH|5.009002||p XCPT_RETHROW|5.009002||p XCPT_TRY_END|5.009002||p XCPT_TRY_START|5.009002||p XPUSHi||| XPUSHmortal|5.009002||p XPUSHn||| XPUSHp||| XPUSHs||| XPUSHu|5.004000||p XSPROTO|5.010000||p XSRETURN_EMPTY||| XSRETURN_IV||| XSRETURN_NO||| XSRETURN_NV||| XSRETURN_PV||| XSRETURN_UNDEF||| XSRETURN_UV|5.008001||p XSRETURN_YES||| XSRETURN|||p XST_mIV||| XST_mNO||| XST_mNV||| XST_mPV||| XST_mUNDEF||| XST_mUV|5.008001||p XST_mYES||| XS_APIVERSION_BOOTCHECK||5.024000| XS_EXTERNAL||5.024000| XS_INTERNAL||5.024000| XS_VERSION_BOOTCHECK||5.024000| XS_VERSION||| XSprePUSH|5.006000||p XS||| XopDISABLE||5.024000| XopENABLE||5.024000| XopENTRYCUSTOM||5.024000| XopENTRY_set||5.024000| XopENTRY||5.024000| XopFLAGS||5.013007| ZeroD|5.009002||p Zero||| _aMY_CXT|5.007003||p _add_range_to_invlist||| _append_range_to_invlist||| _core_swash_init||| _get_encoding||| _get_regclass_nonbitmap_data||| _get_swash_invlist||| _invlistEQ||| _invlist_array_init|||n _invlist_contains_cp|||n _invlist_dump||| _invlist_intersection_maybe_complement_2nd||| _invlist_intersection||| _invlist_invert||| _invlist_len|||n _invlist_populate_swatch|||n _invlist_search|||n _invlist_subtract||| _invlist_union_maybe_complement_2nd||| _invlist_union||| _is_cur_LC_category_utf8||| _is_in_locale_category||5.021001| _is_uni_FOO||5.017008| _is_uni_perl_idcont||5.017008| _is_uni_perl_idstart||5.017007| _is_utf8_FOO||5.017008| _is_utf8_char_slow||5.021001|n _is_utf8_idcont||5.021001| _is_utf8_idstart||5.021001| _is_utf8_mark||5.017008| _is_utf8_perl_idcont||5.017008| _is_utf8_perl_idstart||5.017007| _is_utf8_xidcont||5.021001| _is_utf8_xidstart||5.021001| _load_PL_utf8_foldclosures||| _make_exactf_invlist||| _new_invlist_C_array||| _new_invlist||| _pMY_CXT|5.007003||p _setlocale_debug_string|||n _setup_canned_invlist||| _swash_inversion_hash||| _swash_to_invlist||| _to_fold_latin1||| _to_uni_fold_flags||5.014000| _to_upper_title_latin1||| _to_utf8_case||| _to_utf8_fold_flags||5.019009| _to_utf8_lower_flags||5.019009| _to_utf8_title_flags||5.019009| _to_utf8_upper_flags||5.019009| _warn_problematic_locale|||n aMY_CXT_|5.007003||p aMY_CXT|5.007003||p aTHXR_|5.024000||p aTHXR|5.024000||p aTHX_|5.006000||p aTHX|5.006000||p add_above_Latin1_folds||| add_cp_to_invlist||| add_data|||n add_multi_match||| add_utf16_textfilter||| adjust_size_and_find_bucket|||n advance_one_LB||| advance_one_SB||| advance_one_WB||| alloc_maybe_populate_EXACT||| alloccopstash||| allocmy||| amagic_call||| amagic_cmp_locale||| amagic_cmp||| amagic_deref_call||5.013007| amagic_i_ncmp||| amagic_is_enabled||| amagic_ncmp||| anonymise_cv_maybe||| any_dup||| ao||| append_utf8_from_native_byte||5.019004|n apply_attrs_my||| apply_attrs_string||5.006001| apply_attrs||| apply||| assert_uft8_cache_coherent||| assignment_type||| atfork_lock||5.007003|n atfork_unlock||5.007003|n av_arylen_p||5.009003| av_clear||| av_create_and_push||5.009005| av_create_and_unshift_one||5.009005| av_delete||5.006000| av_exists||5.006000| av_extend_guts||| av_extend||| av_fetch||| av_fill||| av_iter_p||5.011000| av_len||| av_make||| av_pop||| av_push||| av_reify||| av_shift||| av_store||| av_tindex||5.017009| av_top_index||5.017009| av_undef||| av_unshift||| ax|||n backup_one_LB||| backup_one_SB||| backup_one_WB||| bad_type_gv||| bad_type_pv||| bind_match||| block_end||5.004000| block_gimme||5.004000| block_start||5.004000| blockhook_register||5.013003| boolSV|5.004000||p boot_core_PerlIO||| boot_core_UNIVERSAL||| boot_core_mro||| bytes_cmp_utf8||5.013007| bytes_from_utf8||5.007001| bytes_to_utf8||5.006001| cBOOL|5.013000||p call_argv|5.006000||p call_atexit||5.006000| call_list||5.004000| call_method|5.006000||p call_pv|5.006000||p call_sv|5.006000||p caller_cx|5.013005|5.006000|p calloc||5.007002|n cando||| cast_i32||5.006000|n cast_iv||5.006000|n cast_ulong||5.006000|n cast_uv||5.006000|n check_locale_boundary_crossing||| check_type_and_open||| check_uni||| check_utf8_print||| checkcomma||| ckWARN|5.006000||p ck_entersub_args_core||| ck_entersub_args_list||5.013006| ck_entersub_args_proto_or_list||5.013006| ck_entersub_args_proto||5.013006| ck_warner_d||5.011001|v ck_warner||5.011001|v ckwarn_common||| ckwarn_d||5.009003| ckwarn||5.009003| clear_defarray||5.023008| clear_placeholders||| clear_special_blocks||| clone_params_del|||n clone_params_new|||n closest_cop||| cntrl_to_mnemonic|||n compute_EXACTish|||n construct_ahocorasick_from_trie||| cop_fetch_label||5.015001| cop_free||| cop_hints_2hv||5.013007| cop_hints_fetch_pvn||5.013007| cop_hints_fetch_pvs||5.013007| cop_hints_fetch_pv||5.013007| cop_hints_fetch_sv||5.013007| cop_store_label||5.015001| cophh_2hv||5.013007| cophh_copy||5.013007| cophh_delete_pvn||5.013007| cophh_delete_pvs||5.013007| cophh_delete_pv||5.013007| cophh_delete_sv||5.013007| cophh_fetch_pvn||5.013007| cophh_fetch_pvs||5.013007| cophh_fetch_pv||5.013007| cophh_fetch_sv||5.013007| cophh_free||5.013007| cophh_new_empty||5.024000| cophh_store_pvn||5.013007| cophh_store_pvs||5.013007| cophh_store_pv||5.013007| cophh_store_sv||5.013007| core_prototype||| coresub_op||| cr_textfilter||| create_eval_scope||| croak_memory_wrap||5.019003|n croak_no_mem|||n croak_no_modify||5.013003|n croak_nocontext|||vn croak_popstack|||n croak_sv||5.013001| croak_xs_usage||5.010001|n croak|||v csighandler||5.009003|n current_re_engine||| curse||| custom_op_desc||5.007003| custom_op_get_field||| custom_op_name||5.007003| custom_op_register||5.013007| custom_op_xop||5.013007| cv_ckproto_len_flags||| cv_clone_into||| cv_clone||| cv_const_sv_or_av|||n cv_const_sv||5.003070|n cv_dump||| cv_forget_slab||| cv_get_call_checker||5.013006| cv_name||5.021005| cv_set_call_checker_flags||5.021004| cv_set_call_checker||5.013006| cv_undef_flags||| cv_undef||| cvgv_from_hek||| cvgv_set||| cvstash_set||| cx_dump||5.005000| cx_dup||| cx_popblock||5.023008| cx_popeval||5.023008| cx_popformat||5.023008| cx_popgiven||5.023008| cx_poploop||5.023008| cx_popsub_args||5.023008| cx_popsub_common||5.023008| cx_popsub||5.023008| cx_popwhen||5.023008| cx_pushblock||5.023008| cx_pusheval||5.023008| cx_pushformat||5.023008| cx_pushgiven||5.023008| cx_pushloop_for||5.023008| cx_pushloop_plain||5.023008| cx_pushsub||5.023008| cx_pushwhen||5.023008| cx_topblock||5.023008| cxinc||| dAXMARK|5.009003||p dAX|5.007002||p dITEMS|5.007002||p dMARK||| dMULTICALL||5.009003| dMY_CXT_SV|5.007003||p dMY_CXT|5.007003||p dNOOP|5.006000||p dORIGMARK||| dSP||| dTHR|5.004050||p dTHXR|5.024000||p dTHXa|5.006000||p dTHXoa|5.006000||p dTHX|5.006000||p dUNDERBAR|5.009002||p dVAR|5.009003||p dXCPT|5.009002||p dXSARGS||| dXSI32||| dXSTARG|5.006000||p deb_curcv||| deb_nocontext|||vn deb_stack_all||| deb_stack_n||| debop||5.005000| debprofdump||5.005000| debprof||| debstackptrs||5.007003| debstack||5.007003| debug_start_match||| deb||5.007003|v defelem_target||| del_sv||| delete_eval_scope||| delimcpy||5.004000|n deprecate_commaless_var_list||| despatch_signals||5.007001| destroy_matcher||| die_nocontext|||vn die_sv||5.013001| die_unwind||| die|||v dirp_dup||| div128||| djSP||| do_aexec5||| do_aexec||| do_aspawn||| do_binmode||5.004050| do_chomp||| do_close||| do_delete_local||| do_dump_pad||| do_eof||| do_exec3||| do_execfree||| do_exec||| do_gv_dump||5.006000| do_gvgv_dump||5.006000| do_hv_dump||5.006000| do_ipcctl||| do_ipcget||| do_join||| do_magic_dump||5.006000| do_msgrcv||| do_msgsnd||| do_ncmp||| do_oddball||| do_op_dump||5.006000| do_open6||| do_open9||5.006000| do_open_raw||| do_openn||5.007001| do_open||5.003070| do_pmop_dump||5.006000| do_print||| do_readline||| do_seek||| do_semop||| do_shmio||| do_smartmatch||| do_spawn_nowait||| do_spawn||| do_sprintf||| do_sv_dump||5.006000| do_sysseek||| do_tell||| do_trans_complex_utf8||| do_trans_complex||| do_trans_count_utf8||| do_trans_count||| do_trans_simple_utf8||| do_trans_simple||| do_trans||| do_vecget||| do_vecset||| do_vop||| docatch||| doeval_compile||| dofile||| dofindlabel||| doform||| doing_taint||5.008001|n dooneliner||| doopen_pm||| doparseform||| dopoptoeval||| dopoptogivenfor||| dopoptolabel||| dopoptoloop||| dopoptosub_at||| dopoptowhen||| doref||5.009003| dounwind||| dowantarray||| drand48_init_r|||n drand48_r|||n dtrace_probe_call||| dtrace_probe_load||| dtrace_probe_op||| dtrace_probe_phase||| dump_all_perl||| dump_all||5.006000| dump_c_backtrace||| dump_eval||5.006000| dump_exec_pos||| dump_form||5.006000| dump_indent||5.006000|v dump_mstats||| dump_packsubs_perl||| dump_packsubs||5.006000| dump_sub_perl||| dump_sub||5.006000| dump_sv_child||| dump_trie_interim_list||| dump_trie_interim_table||| dump_trie||| dump_vindent||5.006000| dumpuntil||| dup_attrlist||| edit_distance|||n emulate_cop_io||| eval_pv|5.006000||p eval_sv|5.006000||p exec_failed||| expect_number||| fbm_compile||5.005000| fbm_instr||5.005000| feature_is_enabled||| filter_add||| filter_del||| filter_gets||| filter_read||| finalize_optree||| finalize_op||| find_and_forget_pmops||| find_array_subscript||| find_beginning||| find_byclass||| find_default_stash||| find_hash_subscript||| find_in_my_stash||| find_lexical_cv||| find_runcv_where||| find_runcv||5.008001| find_rundefsvoffset||5.009002| find_rundefsv||5.013002| find_script||| find_uninit_var||| first_symbol|||n fixup_errno_string||| foldEQ_latin1||5.013008|n foldEQ_locale||5.013002|n foldEQ_utf8_flags||5.013010| foldEQ_utf8||5.013002| foldEQ||5.013002|n fold_constants||| forbid_setid||| force_ident_maybe_lex||| force_ident||| force_list||| force_next||| force_strict_version||| force_version||| force_word||| forget_pmop||| form_nocontext|||vn form_short_octal_warning||| form||5.004000|v fp_dup||| fprintf_nocontext|||vn free_c_backtrace||| free_global_struct||| free_tied_hv_pool||| free_tmps||| gen_constant_list||| get_ANYOF_cp_list_for_ssc||| get_and_check_backslash_N_name||| get_aux_mg||| get_av|5.006000||p get_c_backtrace_dump||| get_c_backtrace||| get_context||5.006000|n get_cvn_flags||| get_cvs|5.011000||p get_cv|5.006000||p get_db_sub||| get_debug_opts||| get_hash_seed||| get_hv|5.006000||p get_invlist_iter_addr|||n get_invlist_offset_addr|||n get_invlist_previous_index_addr|||n get_mstats||| get_no_modify||| get_num||| get_op_descs||5.005000| get_op_names||5.005000| get_opargs||| get_ppaddr||5.006000| get_re_arg||| get_sv|5.006000||p get_vtbl||5.005030| getcwd_sv||5.007002| getenv_len||| glob_2number||| glob_assign_glob||| gp_dup||| gp_free||| gp_ref||| grok_atoUV|||n grok_bin|5.007003||p grok_bslash_N||| grok_bslash_c||| grok_bslash_o||| grok_bslash_x||| grok_hex|5.007003||p grok_infnan||5.021004| grok_number_flags||5.021002| grok_number|5.007002||p grok_numeric_radix|5.007002||p grok_oct|5.007003||p group_end||| gv_AVadd||| gv_HVadd||| gv_IOadd||| gv_SVadd||| gv_add_by_type||5.011000| gv_autoload4||5.004000| gv_autoload_pvn||5.015004| gv_autoload_pv||5.015004| gv_autoload_sv||5.015004| gv_check||| gv_const_sv||5.009003| gv_dump||5.006000| gv_efullname3||5.003070| gv_efullname4||5.006001| gv_efullname||| gv_fetchfile_flags||5.009005| gv_fetchfile||| gv_fetchmeth_autoload||5.007003| gv_fetchmeth_internal||| gv_fetchmeth_pv_autoload||5.015004| gv_fetchmeth_pvn_autoload||5.015004| gv_fetchmeth_pvn||5.015004| gv_fetchmeth_pv||5.015004| gv_fetchmeth_sv_autoload||5.015004| gv_fetchmeth_sv||5.015004| gv_fetchmethod_autoload||5.004000| gv_fetchmethod_pv_flags||5.015004| gv_fetchmethod_pvn_flags||5.015004| gv_fetchmethod_sv_flags||5.015004| gv_fetchmethod||| gv_fetchmeth||| gv_fetchpvn_flags|5.009002||p gv_fetchpvs|5.009004||p gv_fetchpv||| gv_fetchsv||| gv_fullname3||5.003070| gv_fullname4||5.006001| gv_fullname||| gv_handler||5.007001| gv_init_pvn||| gv_init_pv||5.015004| gv_init_svtype||| gv_init_sv||5.015004| gv_init||| gv_is_in_main||| gv_magicalize_isa||| gv_magicalize||| gv_name_set||5.009004| gv_override||| gv_setref||| gv_stashpvn_internal||| gv_stashpvn|5.003070||p gv_stashpvs|5.009003||p gv_stashpv||| gv_stashsvpvn_cached||| gv_stashsv||| gv_try_downgrade||| handle_named_backref||| handle_possible_posix||| handle_regex_sets||| he_dup||| hek_dup||| hfree_next_entry||| hfreeentries||| hsplit||| hv_assert||| hv_auxinit_internal|||n hv_auxinit||| hv_backreferences_p||| hv_clear_placeholders||5.009001| hv_clear||| hv_common_key_len||5.010000| hv_common||5.010000| hv_copy_hints_hv||5.009004| hv_delayfree_ent||5.004000| hv_delete_common||| hv_delete_ent||5.003070| hv_delete||| hv_eiter_p||5.009003| hv_eiter_set||5.009003| hv_ename_add||| hv_ename_delete||| hv_exists_ent||5.003070| hv_exists||| hv_fetch_ent||5.003070| hv_fetchs|5.009003||p hv_fetch||| hv_fill||5.013002| hv_free_ent_ret||| hv_free_ent||5.004000| hv_iterinit||| hv_iterkeysv||5.003070| hv_iterkey||| hv_iternext_flags||5.008000| hv_iternextsv||| hv_iternext||| hv_iterval||| hv_kill_backrefs||| hv_ksplit||5.003070| hv_magic_check|||n hv_magic||| hv_name_set||5.009003| hv_notallowed||| hv_placeholders_get||5.009003| hv_placeholders_p||| hv_placeholders_set||5.009003| hv_rand_set||5.018000| hv_riter_p||5.009003| hv_riter_set||5.009003| hv_scalar||5.009001| hv_store_ent||5.003070| hv_store_flags||5.008000| hv_stores|5.009004||p hv_store||| hv_undef_flags||| hv_undef||| ibcmp_locale||5.004000| ibcmp_utf8||5.007003| ibcmp||| incline||| incpush_if_exists||| incpush_use_sep||| incpush||| ingroup||| init_argv_symbols||| init_constants||| init_dbargs||| init_debugger||| init_global_struct||| init_i18nl10n||5.006000| init_i18nl14n||5.006000| init_ids||| init_interp||| init_main_stash||| init_perllib||| init_postdump_symbols||| init_predump_symbols||| init_stacks||5.005000| init_tm||5.007002| inplace_aassign||| instr|||n intro_my||5.004000| intuit_method||| intuit_more||| invert||| invlist_array|||n invlist_clear||| invlist_clone||| invlist_contents||| invlist_extend||| invlist_highest|||n invlist_is_iterating|||n invlist_iterfinish|||n invlist_iterinit|||n invlist_iternext|||n invlist_max|||n invlist_previous_index|||n invlist_replace_list_destroys_src||| invlist_set_len||| invlist_set_previous_index|||n invlist_trim|||n invoke_exception_hook||| io_close||| isALNUMC|5.006000||p isALNUM_lazy||5.021001| isALPHANUMERIC||5.017008| isALPHA||| isASCII|5.006000||p isBLANK|5.006001||p isCNTRL|5.006000||p isDIGIT||| isFOO_lc||| isFOO_utf8_lc||| isGCB|||n isGRAPH|5.006000||p isIDCONT||5.017008| isIDFIRST_lazy||5.021001| isIDFIRST||| isLB||| isLOWER||| isOCTAL||5.013005| isPRINT|5.004000||p isPSXSPC|5.006001||p isPUNCT|5.006000||p isSB||| isSPACE||| isUPPER||| isUTF8_CHAR||5.021001| isWB||| isWORDCHAR||5.013006| isXDIGIT|5.006000||p is_an_int||| is_ascii_string||5.011000| is_handle_constructor|||n is_invariant_string||5.021007|n is_lvalue_sub||5.007001| is_safe_syscall||5.019004| is_ssc_worth_it|||n is_uni_alnum_lc||5.006000| is_uni_alnumc_lc||5.017007| is_uni_alnumc||5.017007| is_uni_alnum||5.006000| is_uni_alpha_lc||5.006000| is_uni_alpha||5.006000| is_uni_ascii_lc||5.006000| is_uni_ascii||5.006000| is_uni_blank_lc||5.017002| is_uni_blank||5.017002| is_uni_cntrl_lc||5.006000| is_uni_cntrl||5.006000| is_uni_digit_lc||5.006000| is_uni_digit||5.006000| is_uni_graph_lc||5.006000| is_uni_graph||5.006000| is_uni_idfirst_lc||5.006000| is_uni_idfirst||5.006000| is_uni_lower_lc||5.006000| is_uni_lower||5.006000| is_uni_print_lc||5.006000| is_uni_print||5.006000| is_uni_punct_lc||5.006000| is_uni_punct||5.006000| is_uni_space_lc||5.006000| is_uni_space||5.006000| is_uni_upper_lc||5.006000| is_uni_upper||5.006000| is_uni_xdigit_lc||5.006000| is_uni_xdigit||5.006000| is_utf8_alnumc||5.017007| is_utf8_alnum||5.006000| is_utf8_alpha||5.006000| is_utf8_ascii||5.006000| is_utf8_blank||5.017002| is_utf8_char_buf||5.015008|n is_utf8_char||5.006000|n is_utf8_cntrl||5.006000| is_utf8_common||| is_utf8_digit||5.006000| is_utf8_graph||5.006000| is_utf8_idcont||5.008000| is_utf8_idfirst||5.006000| is_utf8_lower||5.006000| is_utf8_mark||5.006000| is_utf8_perl_space||5.011001| is_utf8_perl_word||5.011001| is_utf8_posix_digit||5.011001| is_utf8_print||5.006000| is_utf8_punct||5.006000| is_utf8_space||5.006000| is_utf8_string_loclen||5.009003|n is_utf8_string_loc||5.008001|n is_utf8_string||5.006001|n is_utf8_upper||5.006000| is_utf8_xdigit||5.006000| is_utf8_xidcont||5.013010| is_utf8_xidfirst||5.013010| isa_lookup||| isinfnansv||| isinfnan||5.021004|n items|||n ix|||n jmaybe||| join_exact||| keyword_plugin_standard||| keyword||| leave_adjust_stacks||5.023008| leave_scope||| lex_bufutf8||5.011002| lex_discard_to||5.011002| lex_grow_linestr||5.011002| lex_next_chunk||5.011002| lex_peek_unichar||5.011002| lex_read_space||5.011002| lex_read_to||5.011002| lex_read_unichar||5.011002| lex_start||5.009005| lex_stuff_pvn||5.011002| lex_stuff_pvs||5.013005| lex_stuff_pv||5.013006| lex_stuff_sv||5.011002| lex_unstuff||5.011002| listkids||| list||| load_module_nocontext|||vn load_module|5.006000||pv localize||| looks_like_bool||| looks_like_number||| lop||| mPUSHi|5.009002||p mPUSHn|5.009002||p mPUSHp|5.009002||p mPUSHs|5.010001||p mPUSHu|5.009002||p mXPUSHi|5.009002||p mXPUSHn|5.009002||p mXPUSHp|5.009002||p mXPUSHs|5.010001||p mXPUSHu|5.009002||p magic_clear_all_env||| magic_cleararylen_p||| magic_clearenv||| magic_clearhints||| magic_clearhint||| magic_clearisa||| magic_clearpack||| magic_clearsig||| magic_copycallchecker||| magic_dump||5.006000| magic_existspack||| magic_freearylen_p||| magic_freeovrld||| magic_getarylen||| magic_getdebugvar||| magic_getdefelem||| magic_getnkeys||| magic_getpack||| magic_getpos||| magic_getsig||| magic_getsubstr||| magic_gettaint||| magic_getuvar||| magic_getvec||| magic_get||| magic_killbackrefs||| magic_methcall1||| magic_methcall|||v magic_methpack||| magic_nextpack||| magic_regdata_cnt||| magic_regdatum_get||| magic_regdatum_set||| magic_scalarpack||| magic_set_all_env||| magic_setarylen||| magic_setcollxfrm||| magic_setdbline||| magic_setdebugvar||| magic_setdefelem||| magic_setenv||| magic_sethint||| magic_setisa||| magic_setlvref||| magic_setmglob||| magic_setnkeys||| magic_setpack||| magic_setpos||| magic_setregexp||| magic_setsig||| magic_setsubstr||| magic_settaint||| magic_setutf8||| magic_setuvar||| magic_setvec||| magic_set||| magic_sizepack||| magic_wipepack||| make_matcher||| make_trie||| malloc_good_size|||n malloced_size|||n malloc||5.007002|n markstack_grow||5.021001| matcher_matches_sv||| maybe_multimagic_gv||| mayberelocate||| measure_struct||| memEQs|5.009005||p memEQ|5.004000||p memNEs|5.009005||p memNE|5.004000||p mem_collxfrm||| mem_log_alloc|||n mem_log_common|||n mem_log_free|||n mem_log_realloc|||n mess_alloc||| mess_nocontext|||vn mess_sv||5.013001| mess||5.006000|v mfree||5.007002|n mg_clear||| mg_copy||| mg_dup||| mg_find_mglob||| mg_findext|5.013008||pn mg_find|||n mg_free_type||5.013006| mg_free||| mg_get||| mg_length||5.005000| mg_localize||| mg_magical|||n mg_set||| mg_size||5.005000| mini_mktime||5.007002|n minus_v||| missingterm||| mode_from_discipline||| modkids||| more_bodies||| more_sv||| moreswitches||| move_proto_attr||| mro_clean_isarev||| mro_gather_and_rename||| mro_get_from_name||5.010001| mro_get_linear_isa_dfs||| mro_get_linear_isa||5.009005| mro_get_private_data||5.010001| mro_isa_changed_in||| mro_meta_dup||| mro_meta_init||| mro_method_changed_in||5.009005| mro_package_moved||| mro_register||5.010001| mro_set_mro||5.010001| mro_set_private_data||5.010001| mul128||| mulexp10|||n multideref_stringify||| my_atof2||5.007002| my_atof||5.006000| my_attrs||| my_bcopy||5.004050|n my_bytes_to_utf8|||n my_bzero|||n my_chsize||| my_clearenv||| my_cxt_index||| my_cxt_init||| my_dirfd||5.009005|n my_exit_jump||| my_exit||| my_failure_exit||5.004000| my_fflush_all||5.006000| my_fork||5.007003|n my_kid||| my_lstat_flags||| my_lstat||5.024000| my_memcmp|||n my_memset|||n my_pclose||5.003070| my_popen_list||5.007001| my_popen||5.003070| my_setenv||| my_setlocale||| my_snprintf|5.009004||pvn my_socketpair||5.007003|n my_sprintf|5.009003||pvn my_stat_flags||| my_stat||5.024000| my_strerror||5.021001| my_strftime||5.007002| my_strlcat|5.009004||pn my_strlcpy|5.009004||pn my_unexec||| my_vsnprintf||5.009004|n need_utf8|||n newANONATTRSUB||5.006000| newANONHASH||| newANONLIST||| newANONSUB||| newASSIGNOP||| newATTRSUB_x||| newATTRSUB||5.006000| newAVREF||| newAV||| newBINOP||| newCONDOP||| newCONSTSUB_flags||5.015006| newCONSTSUB|5.004050||p newCVREF||| newDEFSVOP||5.021006| newFORM||| newFOROP||5.013007| newGIVENOP||5.009003| newGIVWHENOP||| newGP||| newGVOP||| newGVREF||| newGVgen_flags||5.015004| newGVgen||| newHVREF||| newHVhv||5.005000| newHV||| newIO||| newLISTOP||| newLOGOP||| newLOOPEX||| newLOOPOP||| newMETHOP_internal||| newMETHOP_named||5.021005| newMETHOP||5.021005| newMYSUB||5.017004| newNULLLIST||| newOP||| newPADNAMELIST||5.021007|n newPADNAMEouter||5.021007|n newPADNAMEpvn||5.021007|n newPADOP||| newPMOP||| newPROG||| newPVOP||| newRANGE||| newRV_inc|5.004000||p newRV_noinc|5.004000||p newRV||| newSLICEOP||| newSTATEOP||| newSTUB||| newSUB||| newSVOP||| newSVREF||| newSV_type|5.009005||p newSVavdefelem||| newSVhek||5.009003| newSViv||| newSVnv||| newSVpadname||5.017004| newSVpv_share||5.013006| newSVpvf_nocontext|||vn newSVpvf||5.004000|v newSVpvn_flags|5.010001||p newSVpvn_share|5.007001||p newSVpvn_utf8|5.010001||p newSVpvn|5.004050||p newSVpvs_flags|5.010001||p newSVpvs_share|5.009003||p newSVpvs|5.009003||p newSVpv||| newSVrv||| newSVsv||| newSVuv|5.006000||p newSV||| newUNOP_AUX||5.021007| newUNOP||| newWHENOP||5.009003| newWHILEOP||5.013007| newXS_deffile||| newXS_flags||5.009004| newXS_len_flags||| newXSproto||5.006000| newXS||5.006000| new_collate||5.006000| new_constant||| new_ctype||5.006000| new_he||| new_logop||| new_numeric||5.006000| new_stackinfo||5.005000| new_version||5.009000| new_warnings_bitfield||| next_symbol||| nextargv||| nextchar||| ninstr|||n no_bareword_allowed||| no_fh_allowed||| no_op||| noperl_die|||vn not_a_number||| not_incrementable||| nothreadhook||5.008000| nuke_stacks||| num_overflow|||n oopsAV||| oopsHV||| op_append_elem||5.013006| op_append_list||5.013006| op_clear||| op_contextualize||5.013006| op_convert_list||5.021006| op_dump||5.006000| op_free||| op_integerize||| op_linklist||5.013006| op_lvalue_flags||| op_lvalue||5.013007| op_null||5.007002| op_parent|||n op_prepend_elem||5.013006| op_refcnt_dec||| op_refcnt_inc||| op_refcnt_lock||5.009002| op_refcnt_unlock||5.009002| op_relocate_sv||| op_scope||5.013007| op_sibling_splice||5.021002|n op_std_init||| op_unscope||| open_script||| openn_cleanup||| openn_setup||| opmethod_stash||| opslab_force_free||| opslab_free_nopad||| opslab_free||| output_or_return_posix_warnings||| pMY_CXT_|5.007003||p pMY_CXT|5.007003||p pTHX_|5.006000||p pTHX|5.006000||p packWARN|5.007003||p pack_cat||5.007003| pack_rec||| package_version||| package||| packlist||5.008001| pad_add_anon||5.008001| pad_add_name_pvn||5.015001| pad_add_name_pvs||5.015001| pad_add_name_pv||5.015001| pad_add_name_sv||5.015001| pad_add_weakref||| pad_alloc_name||| pad_alloc||| pad_block_start||| pad_check_dup||| pad_compname_type||5.009003| pad_findlex||| pad_findmy_pvn||5.015001| pad_findmy_pvs||5.015001| pad_findmy_pv||5.015001| pad_findmy_sv||5.015001| pad_fixup_inner_anons||| pad_free||| pad_leavemy||| pad_new||5.008001| pad_push||| pad_reset||| pad_setsv||| pad_sv||| pad_swipe||| pad_tidy||5.008001| padlist_dup||| padlist_store||| padname_dup||| padname_free||| padnamelist_dup||| padnamelist_fetch||5.021007|n padnamelist_free||| padnamelist_store||5.021007| parse_arithexpr||5.013008| parse_barestmt||5.013007| parse_block||5.013007| parse_body||| parse_fullexpr||5.013008| parse_fullstmt||5.013005| parse_gv_stash_name||| parse_ident||| parse_label||5.013007| parse_listexpr||5.013008| parse_lparen_question_flags||| parse_stmtseq||5.013006| parse_subsignature||| parse_termexpr||5.013008| parse_unicode_opts||| parser_dup||| parser_free_nexttoke_ops||| parser_free||| path_is_searchable|||n peep||| pending_ident||| perl_alloc_using|||n perl_alloc|||n perl_clone_using|||n perl_clone|||n perl_construct|||n perl_destruct||5.007003|n perl_free|||n perl_parse||5.006000|n perl_run|||n pidgone||| pm_description||| pmop_dump||5.006000| pmruntime||| pmtrans||| pop_scope||| populate_ANYOF_from_invlist||| populate_isa|||v pregcomp||5.009005| pregexec||| pregfree2||5.011000| pregfree||| prescan_version||5.011004| printbuf||| printf_nocontext|||vn process_special_blocks||| ptr_hash|||n ptr_table_clear||5.009005| ptr_table_fetch||5.009005| ptr_table_find|||n ptr_table_free||5.009005| ptr_table_new||5.009005| ptr_table_split||5.009005| ptr_table_store||5.009005| push_scope||| put_charclass_bitmap_innards_common||| put_charclass_bitmap_innards_invlist||| put_charclass_bitmap_innards||| put_code_point||| put_range||| pv_display|5.006000||p pv_escape|5.009004||p pv_pretty|5.009004||p pv_uni_display||5.007003| qerror||| qsortsvu||| quadmath_format_needed|||n quadmath_format_single|||n re_compile||5.009005| re_croak2||| re_dup_guts||| re_exec_indentf|||v re_indentf|||v re_intuit_start||5.019001| re_intuit_string||5.006000| re_op_compile||| re_printf|||v realloc||5.007002|n reentrant_free||5.024000| reentrant_init||5.024000| reentrant_retry||5.024000|vn reentrant_size||5.024000| ref_array_or_hash||| refcounted_he_chain_2hv||| refcounted_he_fetch_pvn||| refcounted_he_fetch_pvs||| refcounted_he_fetch_pv||| refcounted_he_fetch_sv||| refcounted_he_free||| refcounted_he_inc||| refcounted_he_new_pvn||| refcounted_he_new_pvs||| refcounted_he_new_pv||| refcounted_he_new_sv||| refcounted_he_value||| refkids||| refto||| ref||5.024000| reg2Lanode||| reg_check_named_buff_matched|||n reg_named_buff_all||5.009005| reg_named_buff_exists||5.009005| reg_named_buff_fetch||5.009005| reg_named_buff_firstkey||5.009005| reg_named_buff_iter||| reg_named_buff_nextkey||5.009005| reg_named_buff_scalar||5.009005| reg_named_buff||| reg_node||| reg_numbered_buff_fetch||| reg_numbered_buff_length||| reg_numbered_buff_store||| reg_qr_package||| reg_recode||| reg_scan_name||| reg_skipcomment|||n reg_temp_copy||| reganode||| regatom||| regbranch||| regclass_swash||5.009004| regclass||| regcppop||| regcppush||| regcurly|||n regdump_extflags||| regdump_intflags||| regdump||5.005000| regdupe_internal||| regex_set_precedence|||n regexec_flags||5.005000| regfree_internal||5.009005| reghop3|||n reghop4|||n reghopmaybe3|||n reginclass||| reginitcolors||5.006000| reginsert||| regmatch||| regnext||5.005000| regnode_guts||| regpiece||| regprop||| regrepeat||| regtail_study||| regtail||| regtry||| reg||| repeatcpy|||n report_evil_fh||| report_redefined_cv||| report_uninit||| report_wrongway_fh||| require_pv||5.006000| require_tie_mod||| restore_magic||| rninstr|||n rpeep||| rsignal_restore||| rsignal_save||| rsignal_state||5.004000| rsignal||5.004000| run_body||| run_user_filter||| runops_debug||5.005000| runops_standard||5.005000| rv2cv_op_cv||5.013006| rvpv_dup||| rxres_free||| rxres_restore||| rxres_save||| safesyscalloc||5.006000|n safesysfree||5.006000|n safesysmalloc||5.006000|n safesysrealloc||5.006000|n same_dirent||| save_I16||5.004000| save_I32||| save_I8||5.006000| save_adelete||5.011000| save_aelem_flags||5.011000| save_aelem||5.004050| save_alloc||5.006000| save_aptr||| save_ary||| save_bool||5.008001| save_clearsv||| save_delete||| save_destructor_x||5.006000| save_destructor||5.006000| save_freeop||| save_freepv||| save_freesv||| save_generic_pvref||5.006001| save_generic_svref||5.005030| save_gp||5.004000| save_hash||| save_hdelete||5.011000| save_hek_flags|||n save_helem_flags||5.011000| save_helem||5.004050| save_hints||5.010001| save_hptr||| save_int||| save_item||| save_iv||5.005000| save_lines||| save_list||| save_long||| save_magic_flags||| save_mortalizesv||5.007001| save_nogv||| save_op||5.005000| save_padsv_and_mortalize||5.010001| save_pptr||| save_pushi32ptr||5.010001| save_pushptri32ptr||| save_pushptrptr||5.010001| save_pushptr||5.010001| save_re_context||5.006000| save_scalar_at||| save_scalar||| save_set_svflags||5.009000| save_shared_pvref||5.007003| save_sptr||| save_strlen||| save_svref||| save_vptr||5.006000| savepvn||| savepvs||5.009003| savepv||| savesharedpvn||5.009005| savesharedpvs||5.013006| savesharedpv||5.007003| savesharedsvpv||5.013006| savestack_grow_cnt||5.008001| savestack_grow||| savesvpv||5.009002| savetmps||5.023008| sawparens||| scalar_mod_type|||n scalarboolean||| scalarkids||| scalarseq||| scalarvoid||| scalar||| scan_bin||5.006000| scan_commit||| scan_const||| scan_formline||| scan_heredoc||| scan_hex||| scan_ident||| scan_inputsymbol||| scan_num||5.007001| scan_oct||| scan_pat||| scan_str||| scan_subst||| scan_trans||| scan_version||5.009001| scan_vstring||5.009005| scan_word||| search_const||| seed||5.008001| sequence_num||| set_ANYOF_arg||| set_caret_X||| set_context||5.006000|n set_numeric_local||5.006000| set_numeric_radix||5.006000| set_numeric_standard||5.006000| set_padlist|||n setdefout||| share_hek_flags||| share_hek||5.004000| should_warn_nl|||n si_dup||| sighandler|||n simplify_sort||| skip_to_be_ignored_text||| skipspace_flags||| softref2xv||| sortcv_stacked||| sortcv_xsub||| sortcv||| sortsv_flags||5.009003| sortsv||5.007003| space_join_names_mortal||| ss_dup||| ssc_add_range||| ssc_and||| ssc_anything||| ssc_clear_locale|||n ssc_cp_and||| ssc_finalize||| ssc_init||| ssc_intersection||| ssc_is_anything|||n ssc_is_cp_posixl_init|||n ssc_or||| ssc_union||| stack_grow||| start_glob||| start_subparse||5.004000| stdize_locale||| strEQ||| strGE||| strGT||| strLE||| strLT||| strNE||| str_to_version||5.006000| strip_return||| strnEQ||| strnNE||| study_chunk||| sub_crush_depth||| sublex_done||| sublex_push||| sublex_start||| sv_2bool_flags||5.013006| sv_2bool||| sv_2cv||| sv_2io||| sv_2iuv_common||| sv_2iuv_non_preserve||| sv_2iv_flags||5.009001| sv_2iv||| sv_2mortal||| sv_2num||| sv_2nv_flags||5.013001| sv_2pv_flags|5.007002||p sv_2pv_nolen|5.006000||p sv_2pvbyte_nolen|5.006000||p sv_2pvbyte|5.006000||p sv_2pvutf8_nolen||5.006000| sv_2pvutf8||5.006000| sv_2pv||| sv_2uv_flags||5.009001| sv_2uv|5.004000||p sv_add_arena||| sv_add_backref||| sv_backoff|||n sv_bless||| sv_buf_to_ro||| sv_buf_to_rw||| sv_cat_decode||5.008001| sv_catpv_flags||5.013006| sv_catpv_mg|5.004050||p sv_catpv_nomg||5.013006| sv_catpvf_mg_nocontext|||pvn sv_catpvf_mg|5.006000|5.004000|pv sv_catpvf_nocontext|||vn sv_catpvf||5.004000|v sv_catpvn_flags||5.007002| sv_catpvn_mg|5.004050||p sv_catpvn_nomg|5.007002||p sv_catpvn||| sv_catpvs_flags||5.013006| sv_catpvs_mg||5.013006| sv_catpvs_nomg||5.013006| sv_catpvs|5.009003||p sv_catpv||| sv_catsv_flags||5.007002| sv_catsv_mg|5.004050||p sv_catsv_nomg|5.007002||p sv_catsv||| sv_chop||| sv_clean_all||| sv_clean_objs||| sv_clear||| sv_cmp_flags||5.013006| sv_cmp_locale_flags||5.013006| sv_cmp_locale||5.004000| sv_cmp||| sv_collxfrm_flags||5.013006| sv_collxfrm||| sv_copypv_flags||5.017002| sv_copypv_nomg||5.017002| sv_copypv||| sv_dec_nomg||5.013002| sv_dec||| sv_del_backref||| sv_derived_from_pvn||5.015004| sv_derived_from_pv||5.015004| sv_derived_from_sv||5.015004| sv_derived_from||5.004000| sv_destroyable||5.010000| sv_display||| sv_does_pvn||5.015004| sv_does_pv||5.015004| sv_does_sv||5.015004| sv_does||5.009004| sv_dump||| sv_dup_common||| sv_dup_inc_multiple||| sv_dup_inc||| sv_dup||| sv_eq_flags||5.013006| sv_eq||| sv_exp_grow||| sv_force_normal_flags||5.007001| sv_force_normal||5.006000| sv_free2||| sv_free_arenas||| sv_free||| sv_get_backrefs||5.021008|n sv_gets||5.003070| sv_grow||| sv_i_ncmp||| sv_inc_nomg||5.013002| sv_inc||| sv_insert_flags||5.010001| sv_insert||| sv_isa||| sv_isobject||| sv_iv||5.005000| sv_kill_backrefs||| sv_len_utf8_nomg||| sv_len_utf8||5.006000| sv_len||| sv_magic_portable|5.024000|5.004000|p sv_magicext_mglob||| sv_magicext||5.007003| sv_magic||| sv_mortalcopy_flags||| sv_mortalcopy||| sv_ncmp||| sv_newmortal||| sv_newref||| sv_nolocking||5.007003| sv_nosharing||5.007003| sv_nounlocking||| sv_nv||5.005000| sv_only_taint_gmagic|||n sv_or_pv_pos_u2b||| sv_peek||5.005000| sv_pos_b2u_flags||5.019003| sv_pos_b2u_midway||| sv_pos_b2u||5.006000| sv_pos_u2b_cached||| sv_pos_u2b_flags||5.011005| sv_pos_u2b_forwards|||n sv_pos_u2b_midway|||n sv_pos_u2b||5.006000| sv_pvbyten_force||5.006000| sv_pvbyten||5.006000| sv_pvbyte||5.006000| sv_pvn_force_flags|5.007002||p sv_pvn_force||| sv_pvn_nomg|5.007003|5.005000|p sv_pvn||5.005000| sv_pvutf8n_force||5.006000| sv_pvutf8n||5.006000| sv_pvutf8||5.006000| sv_pv||5.006000| sv_recode_to_utf8||5.007003| sv_reftype||| sv_ref||5.015004| sv_replace||| sv_report_used||| sv_resetpvn||| sv_reset||| sv_rvweaken||5.006000| sv_sethek||| sv_setiv_mg|5.004050||p sv_setiv||| sv_setnv_mg|5.006000||p sv_setnv||| sv_setpv_mg|5.004050||p sv_setpvf_mg_nocontext|||pvn sv_setpvf_mg|5.006000|5.004000|pv sv_setpvf_nocontext|||vn sv_setpvf||5.004000|v sv_setpviv_mg||5.008001| sv_setpviv||5.008001| sv_setpvn_mg|5.004050||p sv_setpvn||| sv_setpvs_mg||5.013006| sv_setpvs|5.009004||p sv_setpv||| sv_setref_iv||| sv_setref_nv||| sv_setref_pvn||| sv_setref_pvs||5.024000| sv_setref_pv||| sv_setref_uv||5.007001| sv_setsv_cow||| sv_setsv_flags||5.007002| sv_setsv_mg|5.004050||p sv_setsv_nomg|5.007002||p sv_setsv||| sv_setuv_mg|5.004050||p sv_setuv|5.004000||p sv_tainted||5.004000| sv_taint||5.004000| sv_true||5.005000| sv_unglob||| sv_uni_display||5.007003| sv_unmagicext|5.013008||p sv_unmagic||| sv_unref_flags||5.007001| sv_unref||| sv_untaint||5.004000| sv_upgrade||| sv_usepvn_flags||5.009004| sv_usepvn_mg|5.004050||p sv_usepvn||| sv_utf8_decode||5.006000| sv_utf8_downgrade||5.006000| sv_utf8_encode||5.006000| sv_utf8_upgrade_flags_grow||5.011000| sv_utf8_upgrade_flags||5.007002| sv_utf8_upgrade_nomg||5.007002| sv_utf8_upgrade||5.007001| sv_uv|5.005000||p sv_vcatpvf_mg|5.006000|5.004000|p sv_vcatpvfn_flags||5.017002| sv_vcatpvfn||5.004000| sv_vcatpvf|5.006000|5.004000|p sv_vsetpvf_mg|5.006000|5.004000|p sv_vsetpvfn||5.004000| sv_vsetpvf|5.006000|5.004000|p svtype||| swallow_bom||| swash_fetch||5.007002| swash_init||5.006000| swash_scan_list_line||| swatch_get||| sync_locale||5.021004| sys_init3||5.010000|n sys_init||5.010000|n sys_intern_clear||| sys_intern_dup||| sys_intern_init||| sys_term||5.010000|n taint_env||| taint_proper||| tied_method|||v tmps_grow_p||| toFOLD_utf8||5.019001| toFOLD_uvchr||5.023009| toFOLD||5.019001| toLOWER_L1||5.019001| toLOWER_LC||5.004000| toLOWER_utf8||5.015007| toLOWER_uvchr||5.023009| toLOWER||| toTITLE_utf8||5.015007| toTITLE_uvchr||5.023009| toTITLE||5.019001| toUPPER_utf8||5.015007| toUPPER_uvchr||5.023009| toUPPER||| to_byte_substr||| to_lower_latin1|||n to_uni_fold||5.007003| to_uni_lower_lc||5.006000| to_uni_lower||5.007003| to_uni_title_lc||5.006000| to_uni_title||5.007003| to_uni_upper_lc||5.006000| to_uni_upper||5.007003| to_utf8_case||5.007003| to_utf8_fold||5.015007| to_utf8_lower||5.015007| to_utf8_substr||| to_utf8_title||5.015007| to_utf8_upper||5.015007| tokenize_use||| tokeq||| tokereport||| too_few_arguments_pv||| too_many_arguments_pv||| translate_substr_offsets|||n try_amagic_bin||| try_amagic_un||| uiv_2buf|||n unlnk||| unpack_rec||| unpack_str||5.007003| unpackstring||5.008001| unreferenced_to_tmp_stack||| unshare_hek_or_pvn||| unshare_hek||| unsharepvn||5.003070| unwind_handler_stack||| update_debugger_info||| upg_version||5.009005| usage||| utf16_textfilter||| utf16_to_utf8_reversed||5.006001| utf16_to_utf8||5.006001| utf8_distance||5.006000| utf8_hop||5.006000|n utf8_length||5.007001| utf8_mg_len_cache_update||| utf8_mg_pos_cache_update||| utf8_to_bytes||5.006001| utf8_to_uvchr_buf||5.015009| utf8_to_uvchr||5.007001| utf8_to_uvuni_buf||5.015009| utf8_to_uvuni||5.007001| utf8n_to_uvchr||5.007001| utf8n_to_uvuni||5.007001| utilize||| uvchr_to_utf8_flags||5.007003| uvchr_to_utf8||5.007001| uvoffuni_to_utf8_flags||5.019004| uvuni_to_utf8_flags||5.007003| uvuni_to_utf8||5.007001| valid_utf8_to_uvchr||5.015009| valid_utf8_to_uvuni||5.015009| validate_proto||| validate_suid||| varname||| vcmp||5.009000| vcroak||5.006000| vdeb||5.007003| vform||5.006000| visit||| vivify_defelem||| vivify_ref||| vload_module|5.006000||p vmess||5.006000| vnewSVpvf|5.006000|5.004000|p vnormal||5.009002| vnumify||5.009000| vstringify||5.009000| vverify||5.009003| vwarner||5.006000| vwarn||5.006000| wait4pid||| warn_nocontext|||vn warn_sv||5.013001| warner_nocontext|||vn warner|5.006000|5.004000|pv warn|||v was_lvalue_sub||| watch||| whichsig_pvn||5.015004| whichsig_pv||5.015004| whichsig_sv||5.015004| whichsig||| win32_croak_not_implemented|||n with_queued_errors||| wrap_op_checker||5.015008| write_to_stderr||| xs_boot_epilog||| xs_handshake|||vn xs_version_bootcheck||| yyerror_pvn||| yyerror_pv||| yyerror||| yylex||| yyparse||| yyunlex||| yywarn||| ); if (exists $opt{'list-unsupported'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{todo}; print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; } exit 0; } # Scan for possible replacement candidates my(%replace, %need, %hints, %warnings, %depends); my $replace = 0; my($hint, $define, $function); sub find_api { my $code = shift; $code =~ s{ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; grep { exists $API{$_} } $code =~ /(\w+)/mg; } while () { if ($hint) { my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; if (m{^\s*\*\s(.*?)\s*$}) { for (@{$hint->[1]}) { $h->{$_} ||= ''; # suppress warning with older perls $h->{$_} .= "$1\n"; } } else { undef $hint } } $hint = [$1, [split /,?\s+/, $2]] if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; if ($define) { if ($define->[1] =~ /\\$/) { $define->[1] .= $_; } else { if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { my @n = find_api($define->[1]); push @{$depends{$define->[0]}}, @n if @n } undef $define; } } $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; if ($function) { if (/^}/) { if (exists $API{$function->[0]}) { my @n = find_api($function->[1]); push @{$depends{$function->[0]}}, @n if @n } undef $function; } else { $function->[1] .= $_; } } $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { my @deps = map { s/\s+//g; $_ } split /,/, $3; my $d; for $d (map { s/\s+//g; $_ } split /,/, $1) { push @{$depends{$d}}, @deps; } } $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; } for (values %depends) { my %s; $_ = [sort grep !$s{$_}++, @$_]; } if (exists $opt{'api-info'}) { my $f; my $count = 0; my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $f =~ /$match/; print "\n=== $f ===\n\n"; my $info = 0; if ($API{$f}{base} || $API{$f}{todo}) { my $base = format_version($API{$f}{base} || $API{$f}{todo}); print "Supported at least starting from perl-$base.\n"; $info++; } if ($API{$f}{provided}) { my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; print "Support by $ppport provided back to perl-$todo.\n"; print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; print "\n$hints{$f}" if exists $hints{$f}; print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; $info++; } print "No portability information available.\n" unless $info; $count++; } $count or print "Found no API matching '$opt{'api-info'}'."; print "\n"; exit 0; } if (exists $opt{'list-provided'}) { my $f; for $f (sort { lc $a cmp lc $b } keys %API) { next unless $API{$f}{provided}; my @flags; push @flags, 'explicit' if exists $need{$f}; push @flags, 'depend' if exists $depends{$f}; push @flags, 'hint' if exists $hints{$f}; push @flags, 'warning' if exists $warnings{$f}; my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; print "$f$flags\n"; } exit 0; } my @files; my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); my $srcext = join '|', map { quotemeta $_ } @srcext; if (@ARGV) { my %seen; for (@ARGV) { if (-e) { if (-f) { push @files, $_ unless $seen{$_}++; } else { warn "'$_' is not a file.\n" } } else { my @new = grep { -f } glob $_ or warn "'$_' does not exist.\n"; push @files, grep { !$seen{$_}++ } @new; } } } else { eval { require File::Find; File::Find::find(sub { $File::Find::name =~ /($srcext)$/i and push @files, $File::Find::name; }, '.'); }; if ($@) { @files = map { glob "*$_" } @srcext; } } if (!@ARGV || $opt{filter}) { my(@in, @out); my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; for (@files) { my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; push @{ $out ? \@out : \@in }, $_; } if (@ARGV && @out) { warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); } @files = @in; } die "No input files given!\n" unless @files; my(%files, %global, %revreplace); %revreplace = reverse %replace; my $filename; my $patch_opened = 0; for $filename (@files) { unless (open IN, "<$filename") { warn "Unable to read from $filename: $!\n"; next; } info("Scanning $filename ..."); my $c = do { local $/; }; close IN; my %file = (orig => $c, changes => 0); # Temporarily remove C/XS comments and strings from the code my @ccom; $c =~ s{ ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) | ( ^$HS*\#[^\r\n]* | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) }{ defined $2 and push @ccom, $2; defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; $file{ccom} = \@ccom; $file{code} = $c; $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; my $func; for $func (keys %API) { my $match = $func; $match .= "|$revreplace{$func}" if exists $revreplace{$func}; if ($c =~ /\b(?:Perl_)?($match)\b/) { $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; if (exists $API{$func}{provided}) { $file{uses_provided}{$func}++; if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { $file{uses}{$func}++; my @deps = rec_depend($func); if (@deps) { $file{uses_deps}{$func} = \@deps; for (@deps) { $file{uses}{$_} = 0 unless exists $file{uses}{$_}; } } for ($func, @deps) { $file{needs}{$_} = 'static' if exists $need{$_}; } } } if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { if ($c =~ /\b$func\b/) { $file{uses_todo}{$func}++; } } } } while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { if (exists $need{$2}) { $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; } else { warning("Possibly wrong #define $1 in $filename") } } for (qw(uses needs uses_todo needed_global needed_static)) { for $func (keys %{$file{$_}}) { push @{$global{$_}{$func}}, $filename; } } $files{$filename} = \%file; } # Globally resolve NEED_'s my $need; for $need (keys %{$global{needs}}) { if (@{$global{needs}{$need}} > 1) { my @targets = @{$global{needs}{$need}}; my @t = grep $files{$_}{needed_global}{$need}, @targets; @targets = @t if @t; @t = grep /\.xs$/i, @targets; @targets = @t if @t; my $target = shift @targets; $files{$target}{needs}{$need} = 'global'; for (@{$global{needs}{$need}}) { $files{$_}{needs}{$need} = 'extern' if $_ ne $target; } } } for $filename (@files) { exists $files{$filename} or next; info("=== Analyzing $filename ==="); my %file = %{$files{$filename}}; my $func; my $c = $file{code}; my $warnings = 0; for $func (sort keys %{$file{uses_Perl}}) { if ($API{$func}{varargs}) { unless ($API{$func}{nothxarg}) { my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); if ($changes) { warning("Doesn't pass interpreter argument aTHX to Perl_$func"); $file{changes} += $changes; } } } else { warning("Uses Perl_$func instead of $func"); $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} {$func$1(}g); } } for $func (sort keys %{$file{uses_replace}}) { warning("Uses $func instead of $replace{$func}"); $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); } for $func (sort keys %{$file{uses_provided}}) { if ($file{uses}{$func}) { if (exists $file{uses_deps}{$func}) { diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); } else { diag("Uses $func"); } } $warnings += hint($func); } unless ($opt{quiet}) { for $func (sort keys %{$file{uses_todo}}) { print "*** WARNING: Uses $func, which may not be portable below perl ", format_version($API{$func}{todo}), ", even with '$ppport'\n"; $warnings++; } } for $func (sort keys %{$file{needed_static}}) { my $message = ''; if (not exists $file{uses}{$func}) { $message = "No need to define NEED_$func if $func is never used"; } elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { $message = "No need to define NEED_$func when already needed globally"; } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); } } for $func (sort keys %{$file{needed_global}}) { my $message = ''; if (not exists $global{uses}{$func}) { $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; } elsif (exists $file{needs}{$func}) { if ($file{needs}{$func} eq 'extern') { $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; } elsif ($file{needs}{$func} eq 'static') { $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; } } if ($message) { diag($message); $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); } } $file{needs_inc_ppport} = keys %{$file{uses}}; if ($file{needs_inc_ppport}) { my $pp = ''; for $func (sort keys %{$file{needs}}) { my $type = $file{needs}{$func}; next if $type eq 'extern'; my $suffix = $type eq 'global' ? '_GLOBAL' : ''; unless (exists $file{"needed_$type"}{$func}) { if ($type eq 'global') { diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); } else { diag("File needs $func, adding static request"); } $pp .= "#define NEED_$func$suffix\n"; } } if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { $pp = ''; $file{changes}++; } unless ($file{has_inc_ppport}) { diag("Needs to include '$ppport'"); $pp .= qq(#include "$ppport"\n) } if ($pp) { $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) || ($c =~ s/^/$pp/); } } else { if ($file{has_inc_ppport}) { diag("No need to include '$ppport'"); $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); } } # put back in our C comments my $ix; my $cppc = 0; my @ccom = @{$file{ccom}}; for $ix (0 .. $#ccom) { if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { $cppc++; $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; } else { $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; } } if ($cppc) { my $s = $cppc != 1 ? 's' : ''; warning("Uses $cppc C++ style comment$s, which is not portable"); } my $s = $warnings != 1 ? 's' : ''; my $warn = $warnings ? " ($warnings warning$s)" : ''; info("Analysis completed$warn"); if ($file{changes}) { if (exists $opt{copy}) { my $newfile = "$filename$opt{copy}"; if (-e $newfile) { error("'$newfile' already exists, refusing to write copy of '$filename'"); } else { local *F; if (open F, ">$newfile") { info("Writing copy of '$filename' with changes to '$newfile'"); print F $c; close F; } else { error("Cannot open '$newfile' for writing: $!"); } } } elsif (exists $opt{patch} || $opt{changes}) { if (exists $opt{patch}) { unless ($patch_opened) { if (open PATCH, ">$opt{patch}") { $patch_opened = 1; } else { error("Cannot open '$opt{patch}' for writing: $!"); delete $opt{patch}; $opt{changes} = 1; goto fallback; } } mydiff(\*PATCH, $filename, $c); } else { fallback: info("Suggested changes:"); mydiff(\*STDOUT, $filename, $c); } } else { my $s = $file{changes} == 1 ? '' : 's'; info("$file{changes} potentially required change$s detected"); } } else { info("Looks good"); } } close PATCH if $patch_opened; exit 0; sub try_use { eval "use @_;"; return $@ eq '' } sub mydiff { local *F = shift; my($file, $str) = @_; my $diff; if (exists $opt{diff}) { $diff = run_diff($opt{diff}, $file, $str); } if (!defined $diff and try_use('Text::Diff')) { $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); $diff = <
$tmp") { print F $str; close F; if (open F, "$prog $file $tmp |") { while () { s/\Q$tmp\E/$file.patched/; $diff .= $_; } close F; unlink $tmp; return $diff; } unlink $tmp; } else { error("Cannot open '$tmp' for writing: $!"); } return undef; } sub rec_depend { my($func, $seen) = @_; return () unless exists $depends{$func}; $seen = {%{$seen||{}}}; return () if $seen->{$func}++; my %s; grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; } sub parse_version { my $ver = shift; if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { return ($1, $2, $3); } elsif ($ver !~ /^\d+\.[\d_]+$/) { die "cannot parse version '$ver'\n"; } $ver =~ s/_//g; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "cannot parse version '$ver'\n"; } } return ($r, $v, $s); } sub format_version { my $ver = shift; $ver =~ s/$/000000/; my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; $v = int $v; $s = int $s; if ($r < 5 || ($r == 5 && $v < 6)) { if ($s % 10) { die "invalid version '$ver'\n"; } $s /= 10; $ver = sprintf "%d.%03d", $r, $v; $s > 0 and $ver .= sprintf "_%02d", $s; return $ver; } return sprintf "%d.%d.%d", $r, $v, $s; } sub info { $opt{quiet} and return; print @_, "\n"; } sub diag { $opt{quiet} and return; $opt{diag} and print @_, "\n"; } sub warning { $opt{quiet} and return; print "*** ", @_, "\n"; } sub error { print "*** ERROR: ", @_, "\n"; } my %given_hints; my %given_warnings; sub hint { $opt{quiet} and return; my $func = shift; my $rv = 0; if (exists $warnings{$func} && !$given_warnings{$func}++) { my $warn = $warnings{$func}; $warn =~ s!^!*** !mg; print "*** WARNING: $func\n", $warn; $rv++; } if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { my $hint = $hints{$func}; $hint =~ s/^/ /mg; print " --- hint for $func ---\n", $hint; } $rv; } sub usage { my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; my %M = ( 'I' => '*' ); $usage =~ s/^\s*perl\s+\S+/$^X $0/; $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; print < }; my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; $copy =~ s/^(?=\S+)/ /gms; $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; $self =~ s/^SKIP.*(?=^__DATA__)/SKIP if (\@ARGV && \$ARGV[0] eq '--unstrip') { eval { require Devel::PPPort }; \$@ and die "Cannot require Devel::PPPort, please install.\\n"; if (eval \$Devel::PPPort::VERSION < $VERSION) { die "$0 was originally generated with Devel::PPPort $VERSION.\\n" . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" . "Please install a newer version, or --unstrip will not work.\\n"; } Devel::PPPort::WriteFile(\$0); exit 0; } print <$0" or die "cannot strip $0: $!\n"; print OUT "$pl$c\n"; exit 0; } __DATA__ */ #ifndef _P_P_PORTABILITY_H_ #define _P_P_PORTABILITY_H_ #ifndef DPPP_NAMESPACE # define DPPP_NAMESPACE DPPP_ #endif #define DPPP_CAT2(x,y) CAT2(x,y) #define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) #ifndef PERL_REVISION # if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) # define PERL_PATCHLEVEL_H_IMPLICIT # include # endif # if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) # include # endif # ifndef PERL_REVISION # define PERL_REVISION (5) /* Replace: 1 */ # define PERL_VERSION PATCHLEVEL # define PERL_SUBVERSION SUBVERSION /* Replace PERL_PATCHLEVEL with PERL_VERSION */ /* Replace: 0 */ # endif #endif #define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) #define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) /* It is very unlikely that anyone will try to use this with Perl 6 (or greater), but who knows. */ #if PERL_REVISION != 5 # error include/ppport.h only works with Perl version 5 #endif /* PERL_REVISION != 5 */ #ifndef dTHR # define dTHR dNOOP #endif #ifndef dTHX # define dTHX dNOOP #endif #ifndef dTHXa # define dTHXa(x) dNOOP #endif #ifndef pTHX # define pTHX void #endif #ifndef pTHX_ # define pTHX_ #endif #ifndef aTHX # define aTHX #endif #ifndef aTHX_ # define aTHX_ #endif #if (PERL_BCDVERSION < 0x5006000) # ifdef USE_THREADS # define aTHXR thr # define aTHXR_ thr, # else # define aTHXR # define aTHXR_ # endif # define dTHXR dTHR #else # define aTHXR aTHX # define aTHXR_ aTHX_ # define dTHXR dTHX #endif #ifndef dTHXoa # define dTHXoa(x) dTHXa(x) #endif #ifdef I_LIMITS # include #endif #ifndef PERL_UCHAR_MIN # define PERL_UCHAR_MIN ((unsigned char)0) #endif #ifndef PERL_UCHAR_MAX # ifdef UCHAR_MAX # define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) # else # ifdef MAXUCHAR # define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) # else # define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) # endif # endif #endif #ifndef PERL_USHORT_MIN # define PERL_USHORT_MIN ((unsigned short)0) #endif #ifndef PERL_USHORT_MAX # ifdef USHORT_MAX # define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) # else # ifdef MAXUSHORT # define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) # else # ifdef USHRT_MAX # define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) # else # define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) # endif # endif # endif #endif #ifndef PERL_SHORT_MAX # ifdef SHORT_MAX # define PERL_SHORT_MAX ((short)SHORT_MAX) # else # ifdef MAXSHORT /* Often used in */ # define PERL_SHORT_MAX ((short)MAXSHORT) # else # ifdef SHRT_MAX # define PERL_SHORT_MAX ((short)SHRT_MAX) # else # define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) # endif # endif # endif #endif #ifndef PERL_SHORT_MIN # ifdef SHORT_MIN # define PERL_SHORT_MIN ((short)SHORT_MIN) # else # ifdef MINSHORT # define PERL_SHORT_MIN ((short)MINSHORT) # else # ifdef SHRT_MIN # define PERL_SHORT_MIN ((short)SHRT_MIN) # else # define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif #ifndef PERL_UINT_MAX # ifdef UINT_MAX # define PERL_UINT_MAX ((unsigned int)UINT_MAX) # else # ifdef MAXUINT # define PERL_UINT_MAX ((unsigned int)MAXUINT) # else # define PERL_UINT_MAX (~(unsigned int)0) # endif # endif #endif #ifndef PERL_UINT_MIN # define PERL_UINT_MIN ((unsigned int)0) #endif #ifndef PERL_INT_MAX # ifdef INT_MAX # define PERL_INT_MAX ((int)INT_MAX) # else # ifdef MAXINT /* Often used in */ # define PERL_INT_MAX ((int)MAXINT) # else # define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) # endif # endif #endif #ifndef PERL_INT_MIN # ifdef INT_MIN # define PERL_INT_MIN ((int)INT_MIN) # else # ifdef MININT # define PERL_INT_MIN ((int)MININT) # else # define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) # endif # endif #endif #ifndef PERL_ULONG_MAX # ifdef ULONG_MAX # define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) # else # ifdef MAXULONG # define PERL_ULONG_MAX ((unsigned long)MAXULONG) # else # define PERL_ULONG_MAX (~(unsigned long)0) # endif # endif #endif #ifndef PERL_ULONG_MIN # define PERL_ULONG_MIN ((unsigned long)0L) #endif #ifndef PERL_LONG_MAX # ifdef LONG_MAX # define PERL_LONG_MAX ((long)LONG_MAX) # else # ifdef MAXLONG # define PERL_LONG_MAX ((long)MAXLONG) # else # define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) # endif # endif #endif #ifndef PERL_LONG_MIN # ifdef LONG_MIN # define PERL_LONG_MIN ((long)LONG_MIN) # else # ifdef MINLONG # define PERL_LONG_MIN ((long)MINLONG) # else # define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) # endif # endif #endif #if defined(HAS_QUAD) && (defined(convex) || defined(uts)) # ifndef PERL_UQUAD_MAX # ifdef ULONGLONG_MAX # define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) # else # ifdef MAXULONGLONG # define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) # else # define PERL_UQUAD_MAX (~(unsigned long long)0) # endif # endif # endif # ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN ((unsigned long long)0L) # endif # ifndef PERL_QUAD_MAX # ifdef LONGLONG_MAX # define PERL_QUAD_MAX ((long long)LONGLONG_MAX) # else # ifdef MAXLONGLONG # define PERL_QUAD_MAX ((long long)MAXLONGLONG) # else # define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) # endif # endif # endif # ifndef PERL_QUAD_MIN # ifdef LONGLONG_MIN # define PERL_QUAD_MIN ((long long)LONGLONG_MIN) # else # ifdef MINLONGLONG # define PERL_QUAD_MIN ((long long)MINLONGLONG) # else # define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) # endif # endif # endif #endif /* This is based on code from 5.003 perl.h */ #ifdef HAS_QUAD # ifdef cray #ifndef IVTYPE # define IVTYPE int #endif #ifndef IV_MIN # define IV_MIN PERL_INT_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_INT_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UINT_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UINT_MAX #endif # ifdef INTSIZE #ifndef IVSIZE # define IVSIZE INTSIZE #endif # endif # else # if defined(convex) || defined(uts) #ifndef IVTYPE # define IVTYPE long long #endif #ifndef IV_MIN # define IV_MIN PERL_QUAD_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_QUAD_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_UQUAD_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_UQUAD_MAX #endif # ifdef LONGLONGSIZE #ifndef IVSIZE # define IVSIZE LONGLONGSIZE #endif # endif # else #ifndef IVTYPE # define IVTYPE long #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif # ifdef LONGSIZE #ifndef IVSIZE # define IVSIZE LONGSIZE #endif # endif # endif # endif #ifndef IVSIZE # define IVSIZE 8 #endif #ifndef LONGSIZE # define LONGSIZE 8 #endif #ifndef PERL_QUAD_MIN # define PERL_QUAD_MIN IV_MIN #endif #ifndef PERL_QUAD_MAX # define PERL_QUAD_MAX IV_MAX #endif #ifndef PERL_UQUAD_MIN # define PERL_UQUAD_MIN UV_MIN #endif #ifndef PERL_UQUAD_MAX # define PERL_UQUAD_MAX UV_MAX #endif #else #ifndef IVTYPE # define IVTYPE long #endif #ifndef LONGSIZE # define LONGSIZE 4 #endif #ifndef IV_MIN # define IV_MIN PERL_LONG_MIN #endif #ifndef IV_MAX # define IV_MAX PERL_LONG_MAX #endif #ifndef UV_MIN # define UV_MIN PERL_ULONG_MIN #endif #ifndef UV_MAX # define UV_MAX PERL_ULONG_MAX #endif #endif #ifndef IVSIZE # ifdef LONGSIZE # define IVSIZE LONGSIZE # else # define IVSIZE 4 /* A bold guess, but the best we can make. */ # endif #endif #ifndef UVTYPE # define UVTYPE unsigned IVTYPE #endif #ifndef UVSIZE # define UVSIZE IVSIZE #endif #ifndef sv_setuv # define sv_setuv(sv, uv) \ STMT_START { \ UV TeMpUv = uv; \ if (TeMpUv <= IV_MAX) \ sv_setiv(sv, TeMpUv); \ else \ sv_setnv(sv, (double)TeMpUv); \ } STMT_END #endif #ifndef newSVuv # define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) #endif #ifndef sv_2uv # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) #endif #ifndef SvUVX # define SvUVX(sv) ((UV)SvIVX(sv)) #endif #ifndef SvUVXx # define SvUVXx(sv) SvUVX(sv) #endif #ifndef SvUV # define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) #endif #ifndef SvUVx # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) #endif /* Hint: sv_uv * Always use the SvUVx() macro instead of sv_uv(). */ #ifndef sv_uv # define sv_uv(sv) SvUVx(sv) #endif #if !defined(SvUOK) && defined(SvIOK_UV) # define SvUOK(sv) SvIOK_UV(sv) #endif #ifndef XST_mUV # define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) #endif #ifndef XSRETURN_UV # define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END #endif #ifndef PUSHu # define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END #endif #ifndef XPUSHu # define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END #endif #ifdef HAS_MEMCMP #ifndef memNE # define memNE(s1,s2,l) (memcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) #endif #else #ifndef memNE # define memNE(s1,s2,l) (bcmp(s1,s2,l)) #endif #ifndef memEQ # define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) #endif #endif #ifndef memEQs # define memEQs(s1, l, s2) \ (sizeof(s2)-1 == l && memEQ(s1, (s2 ""), (sizeof(s2)-1))) #endif #ifndef memNEs # define memNEs(s1, l, s2) !memEQs(s1, l, s2) #endif #ifndef MoveD # define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifndef CopyD # define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) #endif #ifdef HAS_MEMSET #ifndef ZeroD # define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) #endif #else #ifndef ZeroD # define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) #endif #endif #ifndef PoisonWith # define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) #endif #ifndef PoisonNew # define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) #endif #ifndef PoisonFree # define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) #endif #ifndef Poison # define Poison(d,n,t) PoisonFree(d,n,t) #endif #ifndef Newx # define Newx(v,n,t) New(0,v,n,t) #endif #ifndef Newxc # define Newxc(v,n,t,c) Newc(0,v,n,t,c) #endif #ifndef Newxz # define Newxz(v,n,t) Newz(0,v,n,t) #endif #ifndef PERL_MAGIC_qr # define PERL_MAGIC_qr 'r' #endif #ifndef cBOOL # define cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0) #endif #ifndef OpHAS_SIBLING # define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling)) #endif #ifndef OpSIBLING # define OpSIBLING(o) (0 + (o)->op_sibling) #endif #ifndef OpMORESIB_set # define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib)) #endif #ifndef OpLASTSIB_set # define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL) #endif #ifndef OpMAYBESIB_set # define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib)) #endif #ifndef SvRX #if defined(NEED_SvRX) static void * DPPP_(my_SvRX)(pTHX_ SV *rv); static #else extern void * DPPP_(my_SvRX)(pTHX_ SV *rv); #endif #ifdef SvRX # undef SvRX #endif #define SvRX(a) DPPP_(my_SvRX)(aTHX_ a) #if defined(NEED_SvRX) || defined(NEED_SvRX_GLOBAL) void * DPPP_(my_SvRX)(pTHX_ SV *rv) { if (SvROK(rv)) { SV *sv = SvRV(rv); if (SvMAGICAL(sv)) { MAGIC *mg = mg_find(sv, PERL_MAGIC_qr); if (mg && mg->mg_obj) { return mg->mg_obj; } } } return 0; } #endif #endif #ifndef SvRXOK # define SvRXOK(sv) (!!SvRX(sv)) #endif #ifndef PERL_UNUSED_DECL # ifdef HASATTRIBUTE # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) # define PERL_UNUSED_DECL # else # define PERL_UNUSED_DECL __attribute__((unused)) # endif # else # define PERL_UNUSED_DECL # endif #endif #ifndef PERL_UNUSED_ARG # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else # define PERL_UNUSED_ARG(x) ((void)x) # endif #endif #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif #ifndef PERL_UNUSED_CONTEXT # ifdef USE_ITHREADS # define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) # else # define PERL_UNUSED_CONTEXT # endif #endif #ifndef PERL_UNUSED_RESULT # if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT) # define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END # else # define PERL_UNUSED_RESULT(v) ((void)(v)) # endif #endif #ifndef NOOP # define NOOP /*EMPTY*/(void)0 #endif #ifndef dNOOP # define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL #endif #ifndef NVTYPE # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) # define NVTYPE long double # else # define NVTYPE double # endif typedef NVTYPE NV; #endif #ifndef INT2PTR # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) # define PTRV UV # define INT2PTR(any,d) (any)(d) # else # if PTRSIZE == LONGSIZE # define PTRV unsigned long # else # define PTRV unsigned # endif # define INT2PTR(any,d) (any)(PTRV)(d) # endif #endif #ifndef PTR2ul # if PTRSIZE == LONGSIZE # define PTR2ul(p) (unsigned long)(p) # else # define PTR2ul(p) INT2PTR(unsigned long,p) # endif #endif #ifndef PTR2nat # define PTR2nat(p) (PTRV)(p) #endif #ifndef NUM2PTR # define NUM2PTR(any,d) (any)PTR2nat(d) #endif #ifndef PTR2IV # define PTR2IV(p) INT2PTR(IV,p) #endif #ifndef PTR2UV # define PTR2UV(p) INT2PTR(UV,p) #endif #ifndef PTR2NV # define PTR2NV(p) NUM2PTR(NV,p) #endif #undef START_EXTERN_C #undef END_EXTERN_C #undef EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C extern #endif #if defined(PERL_GCC_PEDANTIC) # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # define PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif #endif #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) # ifndef PERL_USE_GCC_BRACE_GROUPS # define PERL_USE_GCC_BRACE_GROUPS # endif #endif #undef STMT_START #undef STMT_END #ifdef PERL_USE_GCC_BRACE_GROUPS # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ # define STMT_END ) #else # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) # define STMT_START if (1) # define STMT_END else (void)0 # else # define STMT_START do # define STMT_END while (0) # endif #endif #ifndef boolSV # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) #endif /* DEFSV appears first in 5.004_56 */ #ifndef DEFSV # define DEFSV GvSV(PL_defgv) #endif #ifndef SAVE_DEFSV # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) #endif #ifndef DEFSV_set # define DEFSV_set(sv) (DEFSV = (sv)) #endif /* Older perls (<=5.003) lack AvFILLp */ #ifndef AvFILLp # define AvFILLp AvFILL #endif #ifndef ERRSV # define ERRSV get_sv("@",FALSE) #endif /* Hint: gv_stashpvn * This function's backport doesn't support the length parameter, but * rather ignores it. Portability can only be ensured if the length * parameter is used for speed reasons, but the length can always be * correctly computed from the string argument. */ #ifndef gv_stashpvn # define gv_stashpvn(str,len,create) gv_stashpv(str,create) #endif /* Replace: 1 */ #ifndef get_cv # define get_cv perl_get_cv #endif #ifndef get_sv # define get_sv perl_get_sv #endif #ifndef get_av # define get_av perl_get_av #endif #ifndef get_hv # define get_hv perl_get_hv #endif /* Replace: 0 */ #ifndef dUNDERBAR # define dUNDERBAR dNOOP #endif #ifndef UNDERBAR # define UNDERBAR DEFSV #endif #ifndef dAX # define dAX I32 ax = MARK - PL_stack_base + 1 #endif #ifndef dITEMS # define dITEMS I32 items = SP - MARK #endif #ifndef dXSTARG # define dXSTARG SV * targ = sv_newmortal() #endif #ifndef dAXMARK # define dAXMARK I32 ax = POPMARK; \ register SV ** const mark = PL_stack_base + ax++ #endif #ifndef XSprePUSH # define XSprePUSH (sp = PL_stack_base + ax - 1) #endif #if (PERL_BCDVERSION < 0x5005000) # undef XSRETURN # define XSRETURN(off) \ STMT_START { \ PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ return; \ } STMT_END #endif #ifndef XSPROTO # define XSPROTO(name) void name(pTHX_ CV* cv) #endif #ifndef SVfARG # define SVfARG(p) ((void*)(p)) #endif #ifndef PERL_ABS # define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) #endif #ifndef dVAR # define dVAR dNOOP #endif #ifndef SVf # define SVf "_" #endif #ifndef UTF8_MAXBYTES # define UTF8_MAXBYTES UTF8_MAXLEN #endif #ifndef CPERLscope # define CPERLscope(x) x #endif #ifndef PERL_HASH # define PERL_HASH(hash,str,len) \ STMT_START { \ const char *s_PeRlHaSh = str; \ I32 i_PeRlHaSh = len; \ U32 hash_PeRlHaSh = 0; \ while (i_PeRlHaSh--) \ hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ (hash) = hash_PeRlHaSh; \ } STMT_END #endif #ifndef PERLIO_FUNCS_DECL # ifdef PERLIO_FUNCS_CONST # define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) # else # define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (funcs) # endif #endif /* provide these typedefs for older perls */ #if (PERL_BCDVERSION < 0x5009003) # ifdef ARGSproto typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); # else typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); # endif typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); #endif #ifndef isPSXSPC # define isPSXSPC(c) (isSPACE(c) || (c) == '\v') #endif #ifndef isBLANK # define isBLANK(c) ((c) == ' ' || (c) == '\t') #endif #ifdef EBCDIC #ifndef isALNUMC # define isALNUMC(c) isalnum(c) #endif #ifndef isASCII # define isASCII(c) isascii(c) #endif #ifndef isCNTRL # define isCNTRL(c) iscntrl(c) #endif #ifndef isGRAPH # define isGRAPH(c) isgraph(c) #endif #ifndef isPRINT # define isPRINT(c) isprint(c) #endif #ifndef isPUNCT # define isPUNCT(c) ispunct(c) #endif #ifndef isXDIGIT # define isXDIGIT(c) isxdigit(c) #endif #else # if (PERL_BCDVERSION < 0x5010000) /* Hint: isPRINT * The implementation in older perl versions includes all of the * isSPACE() characters, which is wrong. The version provided by * Devel::PPPort always overrides a present buggy version. */ # undef isPRINT # endif #ifdef HAS_QUAD # ifdef U64TYPE # define WIDEST_UTYPE U64TYPE # else # define WIDEST_UTYPE Quad_t # endif #else # define WIDEST_UTYPE U32 #endif #ifndef isALNUMC # define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) #endif #ifndef isASCII # define isASCII(c) ((WIDEST_UTYPE) (c) <= 127) #endif #ifndef isCNTRL # define isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127) #endif #ifndef isGRAPH # define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) #endif #ifndef isPRINT # define isPRINT(c) (((c) >= 32 && (c) < 127)) #endif #ifndef isPUNCT # define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) #endif #ifndef isXDIGIT # define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) #endif #endif /* Until we figure out how to support this in older perls... */ #if (PERL_BCDVERSION >= 0x5008000) #ifndef HeUTF8 # define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \ SvUTF8(HeKEY_sv(he)) : \ (U32)HeKUTF8(he)) #endif #endif #ifndef C_ARRAY_LENGTH # define C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0])) #endif #ifndef C_ARRAY_END # define C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a)) #endif #ifndef PERL_SIGNALS_UNSAFE_FLAG #define PERL_SIGNALS_UNSAFE_FLAG 0x0001 #if (PERL_BCDVERSION < 0x5008000) # define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG #else # define D_PPP_PERL_SIGNALS_INIT 0 #endif #if defined(NEED_PL_signals) static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #elif defined(NEED_PL_signals_GLOBAL) U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; #else extern U32 DPPP_(my_PL_signals); #endif #define PL_signals DPPP_(my_PL_signals) #endif /* Hint: PL_ppaddr * Calling an op via PL_ppaddr requires passing a context argument * for threaded builds. Since the context argument is different for * 5.005 perls, you can use aTHXR (supplied by include/ppport.h), which will * automatically be defined as the correct argument. */ #if (PERL_BCDVERSION <= 0x5005005) /* Replace: 1 */ # define PL_ppaddr ppaddr # define PL_no_modify no_modify /* Replace: 0 */ #endif #if (PERL_BCDVERSION <= 0x5004005) /* Replace: 1 */ # define PL_DBsignal DBsignal # define PL_DBsingle DBsingle # define PL_DBsub DBsub # define PL_DBtrace DBtrace # define PL_Sv Sv # define PL_bufend bufend # define PL_bufptr bufptr # define PL_compiling compiling # define PL_copline copline # define PL_curcop curcop # define PL_curstash curstash # define PL_debstash debstash # define PL_defgv defgv # define PL_diehook diehook # define PL_dirty dirty # define PL_dowarn dowarn # define PL_errgv errgv # define PL_error_count error_count # define PL_expect expect # define PL_hexdigit hexdigit # define PL_hints hints # define PL_in_my in_my # define PL_laststatval laststatval # define PL_lex_state lex_state # define PL_lex_stuff lex_stuff # define PL_linestr linestr # define PL_na na # define PL_perl_destruct_level perl_destruct_level # define PL_perldb perldb # define PL_rsfp_filters rsfp_filters # define PL_rsfp rsfp # define PL_stack_base stack_base # define PL_stack_sp stack_sp # define PL_statcache statcache # define PL_stdingv stdingv # define PL_sv_arenaroot sv_arenaroot # define PL_sv_no sv_no # define PL_sv_undef sv_undef # define PL_sv_yes sv_yes # define PL_tainted tainted # define PL_tainting tainting # define PL_tokenbuf tokenbuf /* Replace: 0 */ #endif /* Warning: PL_parser * For perl versions earlier than 5.9.5, this is an always * non-NULL dummy. Also, it cannot be dereferenced. Don't * use it if you can avoid is and unless you absolutely know * what you're doing. * If you always check that PL_parser is non-NULL, you can * define DPPP_PL_parser_NO_DUMMY to avoid the creation of * a dummy parser structure. */ #if (PERL_BCDVERSION >= 0x5009005) # ifdef DPPP_PL_parser_NO_DUMMY # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (croak("panic: PL_parser == NULL in %s:%d", \ __FILE__, __LINE__), (yy_parser *) NULL))->var) # else # ifdef DPPP_PL_parser_NO_DUMMY_WARNING # define D_PPP_parser_dummy_warning(var) # else # define D_PPP_parser_dummy_warning(var) \ warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), # endif # define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) #if defined(NEED_PL_parser) static yy_parser DPPP_(dummy_PL_parser); #elif defined(NEED_PL_parser_GLOBAL) yy_parser DPPP_(dummy_PL_parser); #else extern yy_parser DPPP_(dummy_PL_parser); #endif # endif /* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ /* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf * Do not use this variable unless you know exactly what you're * doing. It is internal to the perl parser and may change or even * be removed in the future. As of perl 5.9.5, you have to check * for (PL_parser != NULL) for this variable to have any effect. * An always non-NULL PL_parser dummy is provided for earlier * perl versions. * If PL_parser is NULL when you try to access this variable, a * dummy is being accessed instead and a warning is issued unless * you define DPPP_PL_parser_NO_DUMMY_WARNING. * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access * this variable will croak with a panic message. */ # define PL_expect D_PPP_my_PL_parser_var(expect) # define PL_copline D_PPP_my_PL_parser_var(copline) # define PL_rsfp D_PPP_my_PL_parser_var(rsfp) # define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) # define PL_linestr D_PPP_my_PL_parser_var(linestr) # define PL_bufptr D_PPP_my_PL_parser_var(bufptr) # define PL_bufend D_PPP_my_PL_parser_var(bufend) # define PL_lex_state D_PPP_my_PL_parser_var(lex_state) # define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) # define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) # define PL_in_my D_PPP_my_PL_parser_var(in_my) # define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) # define PL_error_count D_PPP_my_PL_parser_var(error_count) #else /* ensure that PL_parser != NULL and cannot be dereferenced */ # define PL_parser ((void *) 1) #endif #ifndef mPUSHs # define mPUSHs(s) PUSHs(sv_2mortal(s)) #endif #ifndef PUSHmortal # define PUSHmortal PUSHs(sv_newmortal()) #endif #ifndef mPUSHp # define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) #endif #ifndef mPUSHn # define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) #endif #ifndef mPUSHi # define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) #endif #ifndef mPUSHu # define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) #endif #ifndef mXPUSHs # define mXPUSHs(s) XPUSHs(sv_2mortal(s)) #endif #ifndef XPUSHmortal # define XPUSHmortal XPUSHs(sv_newmortal()) #endif #ifndef mXPUSHp # define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END #endif #ifndef mXPUSHn # define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END #endif #ifndef mXPUSHi # define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END #endif #ifndef mXPUSHu # define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END #endif /* Replace: 1 */ #ifndef call_sv # define call_sv perl_call_sv #endif #ifndef call_pv # define call_pv perl_call_pv #endif #ifndef call_argv # define call_argv perl_call_argv #endif #ifndef call_method # define call_method perl_call_method #endif #ifndef eval_sv # define eval_sv perl_eval_sv #endif /* Replace: 0 */ #ifndef PERL_LOADMOD_DENY # define PERL_LOADMOD_DENY 0x1 #endif #ifndef PERL_LOADMOD_NOIMPORT # define PERL_LOADMOD_NOIMPORT 0x2 #endif #ifndef PERL_LOADMOD_IMPORT_OPS # define PERL_LOADMOD_IMPORT_OPS 0x4 #endif #ifndef G_METHOD # define G_METHOD 64 # ifdef call_sv # undef call_sv # endif # if (PERL_BCDVERSION < 0x5006000) # define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) # else # define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) # endif #endif /* Replace perl_eval_pv with eval_pv */ #ifndef eval_pv #if defined(NEED_eval_pv) static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); static #else extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); #endif #ifdef eval_pv # undef eval_pv #endif #define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) #define Perl_eval_pv DPPP_(my_eval_pv) #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error) { dSP; SV* sv = newSVpv(p, 0); PUSHMARK(sp); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); SPAGAIN; sv = POPs; PUTBACK; if (croak_on_error && SvTRUE(GvSV(errgv))) croak(SvPVx(GvSV(errgv), na)); return sv; } #endif #endif #ifndef vload_module #if defined(NEED_vload_module) static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); static #else extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); #endif #ifdef vload_module # undef vload_module #endif #define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) #define Perl_vload_module DPPP_(my_vload_module) #if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) { dTHR; dVAR; OP *veop, *imop; OP * const modname = newSVOP(OP_CONST, 0, name); /* 5.005 has a somewhat hacky force_normal that doesn't croak on SvREADONLY() if PL_compling is true. Current perls take care in ck_require() to correctly turn off SvREADONLY before calling force_normal_flags(). This seems a better fix than fudging PL_compling */ SvREADONLY_off(((SVOP*)modname)->op_sv); modname->op_private |= OPpCONST_BARE; if (ver) { veop = newSVOP(OP_CONST, 0, ver); } else veop = NULL; if (flags & PERL_LOADMOD_NOIMPORT) { imop = sawparens(newNULLLIST()); } else if (flags & PERL_LOADMOD_IMPORT_OPS) { imop = va_arg(*args, OP*); } else { SV *sv; imop = NULL; sv = va_arg(*args, SV*); while (sv) { imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); sv = va_arg(*args, SV*); } } { const line_t ocopline = PL_copline; COP * const ocurcop = PL_curcop; const int oexpect = PL_expect; #if (PERL_BCDVERSION >= 0x5004000) utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); #elif (PERL_BCDVERSION > 0x5003000) utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), veop, modname, imop); #else utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), modname, imop); #endif PL_expect = oexpect; PL_copline = ocopline; PL_curcop = ocurcop; } } #endif #endif #ifndef load_module #if defined(NEED_load_module) static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); static #else extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); #endif #ifdef load_module # undef load_module #endif #define load_module DPPP_(my_load_module) #define Perl_load_module DPPP_(my_load_module) #if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) { va_list args; va_start(args, ver); vload_module(flags, name, ver, &args); va_end(args); } #endif #endif #ifndef newRV_inc # define newRV_inc(sv) newRV(sv) /* Replace */ #endif #ifndef newRV_noinc #if defined(NEED_newRV_noinc) static SV * DPPP_(my_newRV_noinc)(SV *sv); static #else extern SV * DPPP_(my_newRV_noinc)(SV *sv); #endif #ifdef newRV_noinc # undef newRV_noinc #endif #define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) #define Perl_newRV_noinc DPPP_(my_newRV_noinc) #if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) SV * DPPP_(my_newRV_noinc)(SV *sv) { SV *rv = (SV *)newRV(sv); SvREFCNT_dec(sv); return rv; } #endif #endif /* Hint: newCONSTSUB * Returns a CV* as of perl-5.7.1. This return value is not supported * by Devel::PPPort. */ /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ #if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) #if defined(NEED_newCONSTSUB) static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); static #else extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); #endif #ifdef newCONSTSUB # undef newCONSTSUB #endif #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) /* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ /* (There's no PL_parser in perl < 5.005, so this is completely safe) */ #define D_PPP_PL_copline PL_copline void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) { U32 oldhints = PL_hints; HV *old_cop_stash = PL_curcop->cop_stash; HV *old_curstash = PL_curstash; line_t oldline = PL_curcop->cop_line; PL_curcop->cop_line = D_PPP_PL_copline; PL_hints &= ~HINT_BLOCK_SCOPE; if (stash) PL_curstash = PL_curcop->cop_stash = stash; newSUB( #if (PERL_BCDVERSION < 0x5003022) start_subparse(), #elif (PERL_BCDVERSION == 0x5003022) start_subparse(0), #else /* 5.003_23 onwards */ start_subparse(FALSE, 0), #endif newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) ); PL_hints = oldhints; PL_curcop->cop_stash = old_cop_stash; PL_curstash = old_curstash; PL_curcop->cop_line = oldline; } #endif #endif /* * Boilerplate macros for initializing and accessing interpreter-local * data from C. All statics in extensions should be reworked to use * this, if you want to make the extension thread-safe. See ext/re/re.xs * for an example of the use of these macros. * * Code that uses these macros is responsible for the following: * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" * 2. Declare a typedef named my_cxt_t that is a structure that contains * all the data that needs to be interpreter-local. * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. * 4. Use the MY_CXT_INIT macro such that it is called exactly once * (typically put in the BOOT: section). * 5. Use the members of the my_cxt_t structure everywhere as * MY_CXT.member. * 6. Use the dMY_CXT macro (a declaration) in all the functions that * access MY_CXT. */ #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) #ifndef START_MY_CXT /* This must appear in all extensions that define a my_cxt_t structure, * right after the definition (i.e. at file scope). The non-threads * case below uses it to declare the data as static. */ #define START_MY_CXT #if (PERL_BCDVERSION < 0x5004068) /* Fetches the SV that keeps the per-interpreter data. */ #define dMY_CXT_SV \ SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) #else /* >= perl5.004_68 */ #define dMY_CXT_SV \ SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ sizeof(MY_CXT_KEY)-1, TRUE) #endif /* < perl5.004_68 */ /* This declaration should be used within all functions that use the * interpreter-local data. */ #define dMY_CXT \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) /* Creates and zeroes the per-interpreter data. * (We allocate my_cxtp in a Perl SV so that it will be released when * the interpreter goes away.) */ #define MY_CXT_INIT \ dMY_CXT_SV; \ /* newSV() allocates one more than needed */ \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Zero(my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) /* This macro must be used to access members of the my_cxt_t structure. * e.g. MYCXT.some_data */ #define MY_CXT (*my_cxtp) /* Judicious use of these macros can reduce the number of times dMY_CXT * is used. Use is similar to pTHX, aTHX etc. */ #define pMY_CXT my_cxt_t *my_cxtp #define pMY_CXT_ pMY_CXT, #define _pMY_CXT ,pMY_CXT #define aMY_CXT my_cxtp #define aMY_CXT_ aMY_CXT, #define _aMY_CXT ,aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE /* Clones the per-interpreter data. */ #define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) #endif #else /* single interpreter */ #ifndef START_MY_CXT #define START_MY_CXT static my_cxt_t my_cxt; #define dMY_CXT_SV dNOOP #define dMY_CXT dNOOP #define MY_CXT_INIT NOOP #define MY_CXT my_cxt #define pMY_CXT void #define pMY_CXT_ #define _pMY_CXT #define aMY_CXT #define aMY_CXT_ #define _aMY_CXT #endif /* START_MY_CXT */ #ifndef MY_CXT_CLONE #define MY_CXT_CLONE NOOP #endif #endif #ifndef IVdf # if IVSIZE == LONGSIZE # define IVdf "ld" # define UVuf "lu" # define UVof "lo" # define UVxf "lx" # define UVXf "lX" # elif IVSIZE == INTSIZE # define IVdf "d" # define UVuf "u" # define UVof "o" # define UVxf "x" # define UVXf "X" # else # error "cannot define IV/UV formats" # endif #endif #ifndef NVef # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) /* Not very likely, but let's try anyway. */ # define NVef PERL_PRIeldbl # define NVff PERL_PRIfldbl # define NVgf PERL_PRIgldbl # else # define NVef "e" # define NVff "f" # define NVgf "g" # endif #endif #ifndef SvREFCNT_inc # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (SvREFCNT(_sv))++; \ _sv; \ }) # else # define SvREFCNT_inc(sv) \ ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) # endif #endif #ifndef SvREFCNT_inc_simple # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_simple(sv) \ ({ \ if (sv) \ (SvREFCNT(sv))++; \ (SV *)(sv); \ }) # else # define SvREFCNT_inc_simple(sv) \ ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) # endif #endif #ifndef SvREFCNT_inc_NN # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_NN(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ SvREFCNT(_sv)++; \ _sv; \ }) # else # define SvREFCNT_inc_NN(sv) \ (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) # endif #endif #ifndef SvREFCNT_inc_void # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc_void(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (void)(SvREFCNT(_sv)++); \ }) # else # define SvREFCNT_inc_void(sv) \ (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) # endif #endif #ifndef SvREFCNT_inc_simple_void # define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END #endif #ifndef SvREFCNT_inc_simple_NN # define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) #endif #ifndef SvREFCNT_inc_void_NN # define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef SvREFCNT_inc_simple_void_NN # define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) #endif #ifndef newSV_type #if defined(NEED_newSV_type) static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); static #else extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); #endif #ifdef newSV_type # undef newSV_type #endif #define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) #define Perl_newSV_type DPPP_(my_newSV_type) #if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) SV* DPPP_(my_newSV_type)(pTHX_ svtype const t) { SV* const sv = newSV(0); sv_upgrade(sv, t); return sv; } #endif #endif #if (PERL_BCDVERSION < 0x5006000) # define D_PPP_CONSTPV_ARG(x) ((char *) (x)) #else # define D_PPP_CONSTPV_ARG(x) (x) #endif #ifndef newSVpvn # define newSVpvn(data,len) ((data) \ ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ : newSV(0)) #endif #ifndef newSVpvn_utf8 # define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) #endif #ifndef SVf_UTF8 # define SVf_UTF8 0 #endif #ifndef newSVpvn_flags #if defined(NEED_newSVpvn_flags) static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); static #else extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); #endif #ifdef newSVpvn_flags # undef newSVpvn_flags #endif #define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) #define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) #if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) { SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); SvFLAGS(sv) |= (flags & SVf_UTF8); return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; } #endif #endif /* Backwards compatibility stuff... :-( */ #if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) # define NEED_sv_2pv_flags #endif #if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) # define NEED_sv_2pv_flags_GLOBAL #endif /* Hint: sv_2pv_nolen * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). */ #ifndef sv_2pv_nolen # define sv_2pv_nolen(sv) SvPV_nolen(sv) #endif #ifdef SvPVbyte /* Hint: SvPVbyte * Does not work in perl-5.6.1, include/ppport.h implements a version * borrowed from perl-5.7.3. */ #if (PERL_BCDVERSION < 0x5007000) #if defined(NEED_sv_2pvbyte) static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); static #else extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); #endif #ifdef sv_2pvbyte # undef sv_2pvbyte #endif #define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) #define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) #if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) { sv_utf8_downgrade(sv,0); return SvPV(sv,*lp); } #endif /* Hint: sv_2pvbyte * Use the SvPVbyte() macro instead of sv_2pvbyte(). */ #undef SvPVbyte #define SvPVbyte(sv, lp) \ ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) #endif #else # define SvPVbyte SvPV # define sv_2pvbyte sv_2pv #endif #ifndef sv_2pvbyte_nolen # define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) #endif /* Hint: sv_pvn * Always use the SvPV() macro instead of sv_pvn(). */ /* Hint: sv_pvn_force * Always use the SvPV_force() macro instead of sv_pvn_force(). */ /* If these are undefined, they're not handled by the core anyway */ #ifndef SV_IMMEDIATE_UNREF # define SV_IMMEDIATE_UNREF 0 #endif #ifndef SV_GMAGIC # define SV_GMAGIC 0 #endif #ifndef SV_COW_DROP_PV # define SV_COW_DROP_PV 0 #endif #ifndef SV_UTF8_NO_ENCODING # define SV_UTF8_NO_ENCODING 0 #endif #ifndef SV_NOSTEAL # define SV_NOSTEAL 0 #endif #ifndef SV_CONST_RETURN # define SV_CONST_RETURN 0 #endif #ifndef SV_MUTABLE_RETURN # define SV_MUTABLE_RETURN 0 #endif #ifndef SV_SMAGIC # define SV_SMAGIC 0 #endif #ifndef SV_HAS_TRAILING_NUL # define SV_HAS_TRAILING_NUL 0 #endif #ifndef SV_COW_SHARED_HASH_KEYS # define SV_COW_SHARED_HASH_KEYS 0 #endif #if (PERL_BCDVERSION < 0x5007002) #if defined(NEED_sv_2pv_flags) static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif #ifdef sv_2pv_flags # undef sv_2pv_flags #endif #define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) #define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) #if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_2pv(sv, lp ? lp : &n_a); } #endif #if defined(NEED_sv_pvn_force_flags) static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); static #else extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); #endif #ifdef sv_pvn_force_flags # undef sv_pvn_force_flags #endif #define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) #define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) #if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) { STRLEN n_a = (STRLEN) flags; return sv_pvn_force(sv, lp ? lp : &n_a); } #endif #endif #if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) # define DPPP_SVPV_NOLEN_LP_ARG &PL_na #else # define DPPP_SVPV_NOLEN_LP_ARG 0 #endif #ifndef SvPV_const # define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_mutable # define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_flags # define SvPV_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) #endif #ifndef SvPV_flags_const # define SvPV_flags_const(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_const_nolen # define SvPV_flags_const_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : \ (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) #endif #ifndef SvPV_flags_mutable # define SvPV_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_force # define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nolen # define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) #endif #ifndef SvPV_force_mutable # define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) #endif #ifndef SvPV_force_nomg # define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) #endif #ifndef SvPV_force_nomg_nolen # define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) #endif #ifndef SvPV_force_flags # define SvPV_force_flags(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) #endif #ifndef SvPV_force_flags_nolen # define SvPV_force_flags_nolen(sv, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) #endif #ifndef SvPV_force_flags_mutable # define SvPV_force_flags_mutable(sv, lp, flags) \ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) #endif #ifndef SvPV_nolen # define SvPV_nolen(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) #endif #ifndef SvPV_nolen_const # define SvPV_nolen_const(sv) \ ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) #endif #ifndef SvPV_nomg # define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) #endif #ifndef SvPV_nomg_const # define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) #endif #ifndef SvPV_nomg_const_nolen # define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) #endif #ifndef SvPV_nomg_nolen # define SvPV_nomg_nolen(sv) ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, 0)) #endif #ifndef SvPV_renew # define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ SvPV_set((sv), (char *) saferealloc( \ (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ } STMT_END #endif #ifndef SvMAGIC_set # define SvMAGIC_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5009003) #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) (0 + SvPVX(sv)) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END #endif #else #ifndef SvPVX_const # define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) #endif #ifndef SvPVX_mutable # define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) #endif #ifndef SvRV_set # define SvRV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ ((sv)->sv_u.svu_rv = (val)); } STMT_END #endif #endif #ifndef SvSTASH_set # define SvSTASH_set(sv, val) \ STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END #endif #if (PERL_BCDVERSION < 0x5004000) #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END #endif #else #ifndef SvUV_set # define SvUV_set(sv, val) \ STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) #if defined(NEED_vnewSVpvf) static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); static #else extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); #endif #ifdef vnewSVpvf # undef vnewSVpvf #endif #define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) #define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) #if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) { register SV *sv = newSV(0); sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); return sv; } #endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) # define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) # define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ #ifndef sv_catpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext # else # define sv_catpvf_mg Perl_sv_catpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) # define sv_vcatpvf_mg(sv, pat, args) \ STMT_START { \ sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); #endif #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) { va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #ifdef PERL_IMPLICIT_CONTEXT #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); #endif #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) { dTHX; va_list args; va_start(args, pat); sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); va_end(args); } #endif #endif #endif /* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ #ifndef sv_setpvf_mg # ifdef PERL_IMPLICIT_CONTEXT # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext # else # define sv_setpvf_mg Perl_sv_setpvf_mg # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) # define sv_vsetpvf_mg(sv, pat, args) \ STMT_START { \ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ SvSETMAGIC(sv); \ } STMT_END #endif /* Hint: newSVpvn_share * The SVs created by this function only mimic the behaviour of * shared PVs without really being shared. Only use if you know * what you're doing. */ #ifndef newSVpvn_share #if defined(NEED_newSVpvn_share) static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); static #else extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); #endif #ifdef newSVpvn_share # undef newSVpvn_share #endif #define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) #define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) #if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) { SV *sv; if (len < 0) len = -len; if (!hash) PERL_HASH(hash, (char*) src, len); sv = newSVpvn((char *) src, len); sv_upgrade(sv, SVt_PVIV); SvIVX(sv) = hash; SvREADONLY_on(sv); SvPOK_on(sv); return sv; } #endif #endif #ifndef SvSHARED_HASH # define SvSHARED_HASH(sv) (0 + SvUVX(sv)) #endif #ifndef HvNAME_get # define HvNAME_get(hv) HvNAME(hv) #endif #ifndef HvNAMELEN_get # define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) #endif #ifndef gv_fetchpvn_flags #if defined(NEED_gv_fetchpvn_flags) static GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types); static #else extern GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types); #endif #ifdef gv_fetchpvn_flags # undef gv_fetchpvn_flags #endif #define gv_fetchpvn_flags(a,b,c,d) DPPP_(my_gv_fetchpvn_flags)(aTHX_ a,b,c,d) #define Perl_gv_fetchpvn_flags DPPP_(my_gv_fetchpvn_flags) #if defined(NEED_gv_fetchpvn_flags) || defined(NEED_gv_fetchpvn_flags_GLOBAL) GV* DPPP_(my_gv_fetchpvn_flags)(pTHX_ const char* name, STRLEN len, int flags, int types) { char *namepv = savepvn(name, len); GV* stash = gv_fetchpv(namepv, TRUE, SVt_PVHV); Safefree(namepv); return stash; } #endif #endif #ifndef GvSVn # define GvSVn(gv) GvSV(gv) #endif #ifndef isGV_with_GP # define isGV_with_GP(gv) isGV(gv) #endif #ifndef gv_fetchsv # define gv_fetchsv(name, flags, svt) gv_fetchpv(SvPV_nolen_const(name), flags, svt) #endif #ifndef get_cvn_flags # define get_cvn_flags(name, namelen, flags) get_cv(name, flags) #endif #ifndef gv_init_pvn # define gv_init_pvn(gv, stash, ptr, len, flags) gv_init(gv, stash, ptr, len, flags & GV_ADDMULTI ? TRUE : FALSE) #endif #ifndef WARN_ALL # define WARN_ALL 0 #endif #ifndef WARN_CLOSURE # define WARN_CLOSURE 1 #endif #ifndef WARN_DEPRECATED # define WARN_DEPRECATED 2 #endif #ifndef WARN_EXITING # define WARN_EXITING 3 #endif #ifndef WARN_GLOB # define WARN_GLOB 4 #endif #ifndef WARN_IO # define WARN_IO 5 #endif #ifndef WARN_CLOSED # define WARN_CLOSED 6 #endif #ifndef WARN_EXEC # define WARN_EXEC 7 #endif #ifndef WARN_LAYER # define WARN_LAYER 8 #endif #ifndef WARN_NEWLINE # define WARN_NEWLINE 9 #endif #ifndef WARN_PIPE # define WARN_PIPE 10 #endif #ifndef WARN_UNOPENED # define WARN_UNOPENED 11 #endif #ifndef WARN_MISC # define WARN_MISC 12 #endif #ifndef WARN_NUMERIC # define WARN_NUMERIC 13 #endif #ifndef WARN_ONCE # define WARN_ONCE 14 #endif #ifndef WARN_OVERFLOW # define WARN_OVERFLOW 15 #endif #ifndef WARN_PACK # define WARN_PACK 16 #endif #ifndef WARN_PORTABLE # define WARN_PORTABLE 17 #endif #ifndef WARN_RECURSION # define WARN_RECURSION 18 #endif #ifndef WARN_REDEFINE # define WARN_REDEFINE 19 #endif #ifndef WARN_REGEXP # define WARN_REGEXP 20 #endif #ifndef WARN_SEVERE # define WARN_SEVERE 21 #endif #ifndef WARN_DEBUGGING # define WARN_DEBUGGING 22 #endif #ifndef WARN_INPLACE # define WARN_INPLACE 23 #endif #ifndef WARN_INTERNAL # define WARN_INTERNAL 24 #endif #ifndef WARN_MALLOC # define WARN_MALLOC 25 #endif #ifndef WARN_SIGNAL # define WARN_SIGNAL 26 #endif #ifndef WARN_SUBSTR # define WARN_SUBSTR 27 #endif #ifndef WARN_SYNTAX # define WARN_SYNTAX 28 #endif #ifndef WARN_AMBIGUOUS # define WARN_AMBIGUOUS 29 #endif #ifndef WARN_BAREWORD # define WARN_BAREWORD 30 #endif #ifndef WARN_DIGIT # define WARN_DIGIT 31 #endif #ifndef WARN_PARENTHESIS # define WARN_PARENTHESIS 32 #endif #ifndef WARN_PRECEDENCE # define WARN_PRECEDENCE 33 #endif #ifndef WARN_PRINTF # define WARN_PRINTF 34 #endif #ifndef WARN_PROTOTYPE # define WARN_PROTOTYPE 35 #endif #ifndef WARN_QW # define WARN_QW 36 #endif #ifndef WARN_RESERVED # define WARN_RESERVED 37 #endif #ifndef WARN_SEMICOLON # define WARN_SEMICOLON 38 #endif #ifndef WARN_TAINT # define WARN_TAINT 39 #endif #ifndef WARN_THREADS # define WARN_THREADS 40 #endif #ifndef WARN_UNINITIALIZED # define WARN_UNINITIALIZED 41 #endif #ifndef WARN_UNPACK # define WARN_UNPACK 42 #endif #ifndef WARN_UNTIE # define WARN_UNTIE 43 #endif #ifndef WARN_UTF8 # define WARN_UTF8 44 #endif #ifndef WARN_VOID # define WARN_VOID 45 #endif #ifndef WARN_ASSERTIONS # define WARN_ASSERTIONS 46 #endif #ifndef packWARN # define packWARN(a) (a) #endif #ifndef ckWARN # ifdef G_WARN_ON # define ckWARN(a) (PL_dowarn & G_WARN_ON) # else # define ckWARN(a) PL_dowarn # endif #endif #if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) #if defined(NEED_warner) static void DPPP_(my_warner)(U32 err, const char *pat, ...); static #else extern void DPPP_(my_warner)(U32 err, const char *pat, ...); #endif #define Perl_warner DPPP_(my_warner) #if defined(NEED_warner) || defined(NEED_warner_GLOBAL) void DPPP_(my_warner)(U32 err, const char *pat, ...) { SV *sv; va_list args; PERL_UNUSED_ARG(err); va_start(args, pat); sv = vnewSVpvf(pat, &args); va_end(args); sv_2mortal(sv); warn("%s", SvPV_nolen(sv)); } #define warner Perl_warner #define Perl_warner_nocontext Perl_warner #endif #endif /* concatenating with "" ensures that only literal strings are accepted as argument * note that STR_WITH_LEN() can't be used as argument to macros or functions that * under some configurations might be macros */ #ifndef STR_WITH_LEN # define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) #endif #ifndef newSVpvs # define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) #endif #ifndef newSVpvs_flags # define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) #endif #ifndef newSVpvs_share # define newSVpvs_share(str) newSVpvn_share(str "", sizeof(str) - 1, 0) #endif #ifndef sv_catpvs # define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) #endif #ifndef sv_setpvs # define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) #endif #ifndef hv_fetchs # define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) #endif #ifndef hv_stores # define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) #endif #ifndef gv_fetchpvs # define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) #endif #ifndef gv_stashpvs # define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) #endif #ifndef get_cvs # define get_cvs(name, flags) get_cvn_flags(name "", sizeof(name)-1, flags) #endif #ifndef SvGETMAGIC # define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END #endif /* Some random bits for sv_unmagicext. These should probably be pulled in for real and organized at some point */ #ifndef HEf_SVKEY # define HEf_SVKEY -2 #endif #ifndef MUTABLE_PTR #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) # define MUTABLE_PTR(p) ({ void *_p = (p); _p; }) #else # define MUTABLE_PTR(p) ((void *) (p)) #endif #endif #ifndef MUTABLE_SV # define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p)) #endif /* end of random bits */ #ifndef PERL_MAGIC_sv # define PERL_MAGIC_sv '\0' #endif #ifndef PERL_MAGIC_overload # define PERL_MAGIC_overload 'A' #endif #ifndef PERL_MAGIC_overload_elem # define PERL_MAGIC_overload_elem 'a' #endif #ifndef PERL_MAGIC_overload_table # define PERL_MAGIC_overload_table 'c' #endif #ifndef PERL_MAGIC_bm # define PERL_MAGIC_bm 'B' #endif #ifndef PERL_MAGIC_regdata # define PERL_MAGIC_regdata 'D' #endif #ifndef PERL_MAGIC_regdatum # define PERL_MAGIC_regdatum 'd' #endif #ifndef PERL_MAGIC_env # define PERL_MAGIC_env 'E' #endif #ifndef PERL_MAGIC_envelem # define PERL_MAGIC_envelem 'e' #endif #ifndef PERL_MAGIC_fm # define PERL_MAGIC_fm 'f' #endif #ifndef PERL_MAGIC_regex_global # define PERL_MAGIC_regex_global 'g' #endif #ifndef PERL_MAGIC_isa # define PERL_MAGIC_isa 'I' #endif #ifndef PERL_MAGIC_isaelem # define PERL_MAGIC_isaelem 'i' #endif #ifndef PERL_MAGIC_nkeys # define PERL_MAGIC_nkeys 'k' #endif #ifndef PERL_MAGIC_dbfile # define PERL_MAGIC_dbfile 'L' #endif #ifndef PERL_MAGIC_dbline # define PERL_MAGIC_dbline 'l' #endif #ifndef PERL_MAGIC_mutex # define PERL_MAGIC_mutex 'm' #endif #ifndef PERL_MAGIC_shared # define PERL_MAGIC_shared 'N' #endif #ifndef PERL_MAGIC_shared_scalar # define PERL_MAGIC_shared_scalar 'n' #endif #ifndef PERL_MAGIC_collxfrm # define PERL_MAGIC_collxfrm 'o' #endif #ifndef PERL_MAGIC_tied # define PERL_MAGIC_tied 'P' #endif #ifndef PERL_MAGIC_tiedelem # define PERL_MAGIC_tiedelem 'p' #endif #ifndef PERL_MAGIC_tiedscalar # define PERL_MAGIC_tiedscalar 'q' #endif #ifndef PERL_MAGIC_qr # define PERL_MAGIC_qr 'r' #endif #ifndef PERL_MAGIC_sig # define PERL_MAGIC_sig 'S' #endif #ifndef PERL_MAGIC_sigelem # define PERL_MAGIC_sigelem 's' #endif #ifndef PERL_MAGIC_taint # define PERL_MAGIC_taint 't' #endif #ifndef PERL_MAGIC_uvar # define PERL_MAGIC_uvar 'U' #endif #ifndef PERL_MAGIC_uvar_elem # define PERL_MAGIC_uvar_elem 'u' #endif #ifndef PERL_MAGIC_vstring # define PERL_MAGIC_vstring 'V' #endif #ifndef PERL_MAGIC_vec # define PERL_MAGIC_vec 'v' #endif #ifndef PERL_MAGIC_utf8 # define PERL_MAGIC_utf8 'w' #endif #ifndef PERL_MAGIC_substr # define PERL_MAGIC_substr 'x' #endif #ifndef PERL_MAGIC_defelem # define PERL_MAGIC_defelem 'y' #endif #ifndef PERL_MAGIC_glob # define PERL_MAGIC_glob '*' #endif #ifndef PERL_MAGIC_arylen # define PERL_MAGIC_arylen '#' #endif #ifndef PERL_MAGIC_pos # define PERL_MAGIC_pos '.' #endif #ifndef PERL_MAGIC_backref # define PERL_MAGIC_backref '<' #endif #ifndef PERL_MAGIC_ext # define PERL_MAGIC_ext '~' #endif /* That's the best we can do... */ #ifndef sv_catpvn_nomg # define sv_catpvn_nomg sv_catpvn #endif #ifndef sv_catsv_nomg # define sv_catsv_nomg sv_catsv #endif #ifndef sv_setsv_nomg # define sv_setsv_nomg sv_setsv #endif #ifndef sv_pvn_nomg # define sv_pvn_nomg sv_pvn #endif #ifndef SvIV_nomg # define SvIV_nomg SvIV #endif #ifndef SvUV_nomg # define SvUV_nomg SvUV #endif #ifndef sv_catpv_mg # define sv_catpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catpvn_mg # define sv_catpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_catpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_catsv_mg # define sv_catsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_catsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setiv_mg # define sv_setiv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setiv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setnv_mg # define sv_setnv_mg(sv, num) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setnv(TeMpSv,num); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpv_mg # define sv_setpv_mg(sv, ptr) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpv(TeMpSv,ptr); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setpvn_mg # define sv_setpvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setpvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setsv_mg # define sv_setsv_mg(dsv, ssv) \ STMT_START { \ SV *TeMpSv = dsv; \ sv_setsv(TeMpSv,ssv); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_setuv_mg # define sv_setuv_mg(sv, i) \ STMT_START { \ SV *TeMpSv = sv; \ sv_setuv(TeMpSv,i); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef sv_usepvn_mg # define sv_usepvn_mg(sv, ptr, len) \ STMT_START { \ SV *TeMpSv = sv; \ sv_usepvn(TeMpSv,ptr,len); \ SvSETMAGIC(TeMpSv); \ } STMT_END #endif #ifndef SvVSTRING_mg # define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) #endif /* Hint: sv_magic_portable * This is a compatibility function that is only available with * Devel::PPPort. It is NOT in the perl core. * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when * it is being passed a name pointer with namlen == 0. In that * case, perl 5.8.0 and later store the pointer, not a copy of it. * The compatibility can be provided back to perl 5.004. With * earlier versions, the code will not compile. */ #if (PERL_BCDVERSION < 0x5004000) /* code that uses sv_magic_portable will not compile */ #elif (PERL_BCDVERSION < 0x5008000) # define sv_magic_portable(sv, obj, how, name, namlen) \ STMT_START { \ SV *SvMp_sv = (sv); \ char *SvMp_name = (char *) (name); \ I32 SvMp_namlen = (namlen); \ if (SvMp_name && SvMp_namlen == 0) \ { \ MAGIC *mg; \ sv_magic(SvMp_sv, obj, how, 0, 0); \ mg = SvMAGIC(SvMp_sv); \ mg->mg_len = -42; /* XXX: this is the tricky part */ \ mg->mg_ptr = SvMp_name; \ } \ else \ { \ sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ } \ } STMT_END #else # define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) #endif #if !defined(mg_findext) #if defined(NEED_mg_findext) static MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); static #else extern MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl); #endif #define mg_findext DPPP_(my_mg_findext) #define Perl_mg_findext DPPP_(my_mg_findext) #if defined(NEED_mg_findext) || defined(NEED_mg_findext_GLOBAL) MAGIC * DPPP_(my_mg_findext)(SV * sv, int type, const MGVTBL *vtbl) { if (sv) { MAGIC *mg; #ifdef AvPAD_NAMELIST assert(!(SvTYPE(sv) == SVt_PVAV && AvPAD_NAMELIST(sv))); #endif for (mg = SvMAGIC (sv); mg; mg = mg->mg_moremagic) { if (mg->mg_type == type && mg->mg_virtual == vtbl) return mg; } } return NULL; } #endif #endif #if !defined(sv_unmagicext) #if defined(NEED_sv_unmagicext) static int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); static #else extern int DPPP_(my_sv_unmagicext)(pTHX_ SV * const sv, const int type, MGVTBL * vtbl); #endif #ifdef sv_unmagicext # undef sv_unmagicext #endif #define sv_unmagicext(a,b,c) DPPP_(my_sv_unmagicext)(aTHX_ a,b,c) #define Perl_sv_unmagicext DPPP_(my_sv_unmagicext) #if defined(NEED_sv_unmagicext) || defined(NEED_sv_unmagicext_GLOBAL) int DPPP_(my_sv_unmagicext)(pTHX_ SV *const sv, const int type, MGVTBL *vtbl) { MAGIC* mg; MAGIC** mgp; if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) return 0; mgp = &(SvMAGIC(sv)); for (mg = *mgp; mg; mg = *mgp) { const MGVTBL* const virt = mg->mg_virtual; if (mg->mg_type == type && virt == vtbl) { *mgp = mg->mg_moremagic; if (virt && virt->svt_free) virt->svt_free(aTHX_ sv, mg); if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { if (mg->mg_len > 0) Safefree(mg->mg_ptr); else if (mg->mg_len == HEf_SVKEY) /* Questionable on older perls... */ SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); else if (mg->mg_type == PERL_MAGIC_utf8) Safefree(mg->mg_ptr); } if (mg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(mg->mg_obj); Safefree(mg); } else mgp = &mg->mg_moremagic; } if (SvMAGIC(sv)) { if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ mg_magical(sv); /* else fix the flags now */ } else { SvMAGICAL_off(sv); SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; } return 0; } #endif #endif #ifdef USE_ITHREADS #ifndef CopFILE # define CopFILE(c) ((c)->cop_file) #endif #ifndef CopFILEGV # define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) ((c)->cop_stashpv) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) #endif #ifndef CopSTASH # define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ || (CopSTASHPV(c) && HvNAME(hv) \ && strEQ(CopSTASHPV(c), HvNAME(hv))))) #endif #else #ifndef CopFILEGV # define CopFILEGV(c) ((c)->cop_filegv) #endif #ifndef CopFILEGV_set # define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) #endif #ifndef CopFILE_set # define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) #endif #ifndef CopFILESV # define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) #endif #ifndef CopFILEAV # define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) #endif #ifndef CopFILE # define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) #endif #ifndef CopSTASH # define CopSTASH(c) ((c)->cop_stash) #endif #ifndef CopSTASH_set # define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) #endif #ifndef CopSTASHPV # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) #endif #ifndef CopSTASHPV_set # define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) #endif #ifndef CopSTASH_eq # define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) #endif #endif /* USE_ITHREADS */ #if (PERL_BCDVERSION >= 0x5006000) #ifndef caller_cx # if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) static I32 DPPP_dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) { I32 i; for (i = startingblock; i >= 0; i--) { register const PERL_CONTEXT * const cx = &cxstk[i]; switch (CxTYPE(cx)) { default: continue; case CXt_EVAL: case CXt_SUB: case CXt_FORMAT: return i; } } return i; } # endif # if defined(NEED_caller_cx) static const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp); static #else extern const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp); #endif #ifdef caller_cx # undef caller_cx #endif #define caller_cx(a,b) DPPP_(my_caller_cx)(aTHX_ a,b) #define Perl_caller_cx DPPP_(my_caller_cx) #if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 count, const PERL_CONTEXT **dbcxp) { register I32 cxix = DPPP_dopoptosub_at(cxstack, cxstack_ix); register const PERL_CONTEXT *cx; register const PERL_CONTEXT *ccstack = cxstack; const PERL_SI *top_si = PL_curstackinfo; for (;;) { /* we may be in a higher stacklevel, so dig down deeper */ while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { top_si = top_si->si_prev; ccstack = top_si->si_cxstack; cxix = DPPP_dopoptosub_at(ccstack, top_si->si_cxix); } if (cxix < 0) return NULL; /* caller() should not report the automatic calls to &DB::sub */ if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) count++; if (!count--) break; cxix = DPPP_dopoptosub_at(ccstack, cxix - 1); } cx = &ccstack[cxix]; if (dbcxp) *dbcxp = cx; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { const I32 dbcxix = DPPP_dopoptosub_at(ccstack, cxix - 1); /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the field below is defined for any cx. */ /* caller() should not report the automatic calls to &DB::sub */ if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) cx = &ccstack[dbcxix]; } return cx; } # endif #endif /* caller_cx */ #endif /* 5.6.0 */ #ifndef IN_PERL_COMPILETIME # define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) #endif #ifndef IN_LOCALE_RUNTIME # define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) #endif #ifndef IN_LOCALE_COMPILETIME # define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) #endif #ifndef IN_LOCALE # define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) #endif #ifndef IS_NUMBER_IN_UV # define IS_NUMBER_IN_UV 0x01 #endif #ifndef IS_NUMBER_GREATER_THAN_UV_MAX # define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 #endif #ifndef IS_NUMBER_NOT_INT # define IS_NUMBER_NOT_INT 0x04 #endif #ifndef IS_NUMBER_NEG # define IS_NUMBER_NEG 0x08 #endif #ifndef IS_NUMBER_INFINITY # define IS_NUMBER_INFINITY 0x10 #endif #ifndef IS_NUMBER_NAN # define IS_NUMBER_NAN 0x20 #endif #ifndef GROK_NUMERIC_RADIX # define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) #endif #ifndef PERL_SCAN_GREATER_THAN_UV_MAX # define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 #endif #ifndef PERL_SCAN_SILENT_ILLDIGIT # define PERL_SCAN_SILENT_ILLDIGIT 0x04 #endif #ifndef PERL_SCAN_ALLOW_UNDERSCORES # define PERL_SCAN_ALLOW_UNDERSCORES 0x01 #endif #ifndef PERL_SCAN_DISALLOW_PREFIX # define PERL_SCAN_DISALLOW_PREFIX 0x02 #endif #ifndef grok_numeric_radix #if defined(NEED_grok_numeric_radix) static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); static #else extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); #endif #ifdef grok_numeric_radix # undef grok_numeric_radix #endif #define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) #define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) bool DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) { #ifdef USE_LOCALE_NUMERIC #ifdef PL_numeric_radix_sv if (PL_numeric_radix_sv && IN_LOCALE) { STRLEN len; char* radix = SvPV(PL_numeric_radix_sv, len); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #else /* older perls don't have PL_numeric_radix_sv so the radix * must manually be requested from locale.h */ #include dTHR; /* needed for older threaded perls */ struct lconv *lc = localeconv(); char *radix = lc->decimal_point; if (radix && IN_LOCALE) { STRLEN len = strlen(radix); if (*sp + len <= send && memEQ(*sp, radix, len)) { *sp += len; return TRUE; } } #endif #endif /* USE_LOCALE_NUMERIC */ /* always try "." if numeric radix didn't match because * we may have data from different locales mixed */ if (*sp < send && **sp == '.') { ++*sp; return TRUE; } return FALSE; } #endif #endif #ifndef grok_number #if defined(NEED_grok_number) static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); static #else extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); #endif #ifdef grok_number # undef grok_number #endif #define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) #define Perl_grok_number DPPP_(my_grok_number) #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) int DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) { const char *s = pv; const char *send = pv + len; const UV max_div_10 = UV_MAX / 10; const char max_mod_10 = UV_MAX % 10; int numtype = 0; int sawinf = 0; int sawnan = 0; while (s < send && isSPACE(*s)) s++; if (s == send) { return 0; } else if (*s == '-') { s++; numtype = IS_NUMBER_NEG; } else if (*s == '+') s++; if (s == send) return 0; /* next must be digit or the radix separator or beginning of infinity */ if (isDIGIT(*s)) { /* UVs are at least 32 bits, so the first 9 decimal digits cannot overflow. */ UV value = *s - '0'; /* This construction seems to be more optimiser friendly. (without it gcc does the isDIGIT test and the *s - '0' separately) With it gcc on arm is managing 6 instructions (6 cycles) per digit. In theory the optimiser could deduce how far to unroll the loop before checking for overflow. */ if (++s < send) { int digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { digit = *s - '0'; if (digit >= 0 && digit <= 9) { value = value * 10 + digit; if (++s < send) { /* Now got 9 digits, so need to check each time for overflow. */ digit = *s - '0'; while (digit >= 0 && digit <= 9 && (value < max_div_10 || (value == max_div_10 && digit <= max_mod_10))) { value = value * 10 + digit; if (++s < send) digit = *s - '0'; else break; } if (digit >= 0 && digit <= 9 && (s < send)) { /* value overflowed. skip the remaining digits, don't worry about setting *valuep. */ do { s++; } while (s < send && isDIGIT(*s)); numtype |= IS_NUMBER_GREATER_THAN_UV_MAX; goto skip_value; } } } } } } } } } } } } } } } } } } numtype |= IS_NUMBER_IN_UV; if (valuep) *valuep = value; skip_value: if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT; while (s < send && isDIGIT(*s)) /* optional digits after the radix */ s++; } } else if (GROK_NUMERIC_RADIX(&s, send)) { numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ /* no digits before the radix means we need digits after it */ if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); if (valuep) { /* integer approximation is valid - it's 0. */ *valuep = 0; } } else return 0; } else if (*s == 'I' || *s == 'i') { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; s++; if (s < send && (*s == 'I' || *s == 'i')) { s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; s++; if (s == send || (*s != 'T' && *s != 't')) return 0; s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; s++; } sawinf = 1; } else if (*s == 'N' || *s == 'n') { /* XXX TODO: There are signaling NaNs and quiet NaNs. */ s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; s++; sawnan = 1; } else return 0; if (sawinf) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; } else if (sawnan) { numtype &= IS_NUMBER_NEG; /* Keep track of sign */ numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; } else if (s < send) { /* we can have an optional exponent part */ if (*s == 'e' || *s == 'E') { /* The only flag we keep is sign. Blow away any "it's UV" */ numtype &= IS_NUMBER_NEG; numtype |= IS_NUMBER_NOT_INT; s++; if (s < send && (*s == '-' || *s == '+')) s++; if (s < send && isDIGIT(*s)) { do { s++; } while (s < send && isDIGIT(*s)); } else return 0; } } while (s < send && isSPACE(*s)) s++; if (s >= send) return numtype; if (len == 10 && memEQ(pv, "0 but true", 10)) { if (valuep) *valuep = 0; return IS_NUMBER_IN_UV; } return 0; } #endif #endif /* * The grok_* routines have been modified to use warn() instead of * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, * which is why the stack variable has been renamed to 'xdigit'. */ #ifndef grok_bin #if defined(NEED_grok_bin) static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_bin # undef grok_bin #endif #define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) #define Perl_grok_bin DPPP_(my_grok_bin) #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) UV DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_2 = UV_MAX / 2; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading b or 0b. for compatibility silently suffer "b" and "0b" as valid binary numbers. */ if (len >= 1) { if (s[0] == 'b') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'b') { s+=2; len-=2; } } } for (; len-- && *s; s++) { char bit = *s; if (bit == '0' || bit == '1') { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_bin. */ redo: if (!overflowed) { if (value <= max_div_2) { value = (value << 1) | (bit - '0'); continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in binary number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 2.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount. */ value_nv += (NV)(bit - '0'); continue; } if (bit == '_' && len && allow_underscores && (bit = s[1]) && (bit == '0' || bit == '1')) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal binary digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Binary number > 0b11111111111111111111111111111111 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_hex #if defined(NEED_grok_hex) static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_hex # undef grok_hex #endif #define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) #define Perl_grok_hex DPPP_(my_grok_hex) #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) UV DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_16 = UV_MAX / 16; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; const char *xdigit; if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { /* strip off leading x or 0x. for compatibility silently suffer "x" and "0x" as valid hex numbers. */ if (len >= 1) { if (s[0] == 'x') { s++; len--; } else if (len >= 2 && s[0] == '0' && s[1] == 'x') { s+=2; len-=2; } } } for (; len-- && *s; s++) { xdigit = strchr((char *) PL_hexdigit, *s); if (xdigit) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. With gcc seems to be much straighter code than old scan_hex. */ redo: if (!overflowed) { if (value <= max_div_16) { value = (value << 4) | ((xdigit - PL_hexdigit) & 15); continue; } warn("Integer overflow in hexadecimal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 16.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 16-tuples. */ value_nv += (NV)((xdigit - PL_hexdigit) & 15); continue; } if (*s == '_' && len && allow_underscores && s[1] && (xdigit = strchr((char *) PL_hexdigit, s[1]))) { --len; ++s; goto redo; } if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal hexadecimal digit '%c' ignored", *s); break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Hexadecimal number > 0xffffffff non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #ifndef grok_oct #if defined(NEED_grok_oct) static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); static #else extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); #endif #ifdef grok_oct # undef grok_oct #endif #define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) #define Perl_grok_oct DPPP_(my_grok_oct) #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) UV DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) { const char *s = start; STRLEN len = *len_p; UV value = 0; NV value_nv = 0; const UV max_div_8 = UV_MAX / 8; bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; bool overflowed = FALSE; for (; len-- && *s; s++) { /* gcc 2.95 optimiser not smart enough to figure that this subtraction out front allows slicker code. */ int digit = *s - '0'; if (digit >= 0 && digit <= 7) { /* Write it in this wonky order with a goto to attempt to get the compiler to make the common case integer-only loop pretty tight. */ redo: if (!overflowed) { if (value <= max_div_8) { value = (value << 3) | digit; continue; } /* Bah. We're just overflowed. */ warn("Integer overflow in octal number"); overflowed = TRUE; value_nv = (NV) value; } value_nv *= 8.0; /* If an NV has not enough bits in its mantissa to * represent a UV this summing of small low-order numbers * is a waste of time (because the NV cannot preserve * the low-order bits anyway): we could just remember when * did we overflow and in the end just multiply value_nv by the * right amount of 8-tuples. */ value_nv += (NV)digit; continue; } if (digit == ('_' - '0') && len && allow_underscores && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) { --len; ++s; goto redo; } /* Allow \octal to work the DWIM way (that is, stop scanning * as soon as non-octal characters are seen, complain only iff * someone seems to want to use the digits eight and nine). */ if (digit == 8 || digit == 9) { if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) warn("Illegal octal digit '%c' ignored", *s); } break; } if ( ( overflowed && value_nv > 4294967295.0) #if UVSIZE > 4 || (!overflowed && value > 0xffffffff ) #endif ) { warn("Octal number > 037777777777 non-portable"); } *len_p = s - start; if (!overflowed) { *flags = 0; return value; } *flags = PERL_SCAN_GREATER_THAN_UV_MAX; if (result) *result = value_nv; return UV_MAX; } #endif #endif #if !defined(my_snprintf) #if defined(NEED_my_snprintf) static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); static #else extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); #endif #define my_snprintf DPPP_(my_my_snprintf) #define Perl_my_snprintf DPPP_(my_my_snprintf) #if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) int DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) { dTHX; int retval; va_list ap; va_start(ap, format); #ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); #else retval = vsprintf(buffer, format, ap); #endif va_end(ap); if (retval < 0 || (len > 0 && (Size_t)retval >= len)) Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); return retval; } #endif #endif #if !defined(my_sprintf) #if defined(NEED_my_sprintf) static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); static #else extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); #endif #define my_sprintf DPPP_(my_my_sprintf) #define Perl_my_sprintf DPPP_(my_my_sprintf) #if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) int DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) { va_list args; va_start(args, pat); vsprintf(buffer, pat, args); va_end(args); return strlen(buffer); } #endif #endif #ifdef NO_XSLOCKS # ifdef dJMPENV # define dXCPT dJMPENV; int rEtV = 0 # define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) # define XCPT_TRY_END JMPENV_POP; # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW JMPENV_JUMP(rEtV) # else # define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 # define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) # define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); # define XCPT_CATCH if (rEtV != 0) # define XCPT_RETHROW Siglongjmp(top_env, rEtV) # endif #endif #if !defined(my_strlcat) #if defined(NEED_my_strlcat) static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); #endif #define my_strlcat DPPP_(my_my_strlcat) #define Perl_my_strlcat DPPP_(my_my_strlcat) #if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) Size_t DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) { Size_t used, length, copy; used = strlen(dst); length = strlen(src); if (size > 0 && used < size - 1) { copy = (length >= size - used) ? size - used - 1 : length; memcpy(dst + used, src, copy); dst[used + copy] = '\0'; } return used + length; } #endif #endif #if !defined(my_strlcpy) #if defined(NEED_my_strlcpy) static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); static #else extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); #endif #define my_strlcpy DPPP_(my_my_strlcpy) #define Perl_my_strlcpy DPPP_(my_my_strlcpy) #if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) Size_t DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) { Size_t length, copy; length = strlen(src); if (size > 0) { copy = (length >= size) ? size - 1 : length; memcpy(dst, src, copy); dst[copy] = '\0'; } return length; } #endif #endif #ifndef PERL_PV_ESCAPE_QUOTE # define PERL_PV_ESCAPE_QUOTE 0x0001 #endif #ifndef PERL_PV_PRETTY_QUOTE # define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE #endif #ifndef PERL_PV_PRETTY_ELLIPSES # define PERL_PV_PRETTY_ELLIPSES 0x0002 #endif #ifndef PERL_PV_PRETTY_LTGT # define PERL_PV_PRETTY_LTGT 0x0004 #endif #ifndef PERL_PV_ESCAPE_FIRSTCHAR # define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 #endif #ifndef PERL_PV_ESCAPE_UNI # define PERL_PV_ESCAPE_UNI 0x0100 #endif #ifndef PERL_PV_ESCAPE_UNI_DETECT # define PERL_PV_ESCAPE_UNI_DETECT 0x0200 #endif #ifndef PERL_PV_ESCAPE_ALL # define PERL_PV_ESCAPE_ALL 0x1000 #endif #ifndef PERL_PV_ESCAPE_NOBACKSLASH # define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 #endif #ifndef PERL_PV_ESCAPE_NOCLEAR # define PERL_PV_ESCAPE_NOCLEAR 0x4000 #endif #ifndef PERL_PV_ESCAPE_RE # define PERL_PV_ESCAPE_RE 0x8000 #endif #ifndef PERL_PV_PRETTY_NOCLEAR # define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR #endif #ifndef PERL_PV_PRETTY_DUMP # define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE #endif #ifndef PERL_PV_PRETTY_REGPROP # define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE #endif /* Hint: pv_escape * Note that unicode functionality is only backported to * those perl versions that support it. For older perl * versions, the implementation will fall back to bytes. */ #ifndef pv_escape #if defined(NEED_pv_escape) static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); static #else extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); #endif #ifdef pv_escape # undef pv_escape #endif #define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) #define Perl_pv_escape DPPP_(my_pv_escape) #if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) char * DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags) { const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; char octbuf[32] = "%123456789ABCDF"; STRLEN wrote = 0; STRLEN chsize = 0; STRLEN readsize = 1; #if defined(is_utf8_string) && defined(utf8_to_uvchr) bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; #endif const char *pv = str; const char * const end = pv + count; octbuf[0] = esc; if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) sv_setpvs(dsv, ""); #if defined(is_utf8_string) && defined(utf8_to_uvchr) if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) isuni = 1; #endif for (; pv < end && (!max || wrote < max) ; pv += readsize) { const UV u = #if defined(is_utf8_string) && defined(utf8_to_uvchr) isuni ? utf8_to_uvchr((U8*)pv, &readsize) : #endif (U8)*pv; const U8 c = (U8)u & 0xFF; if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { if (flags & PERL_PV_ESCAPE_FIRSTCHAR) chsize = my_snprintf(octbuf, sizeof octbuf, "%" UVxf, u); else chsize = my_snprintf(octbuf, sizeof octbuf, "%cx{%" UVxf "}", esc, u); } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { chsize = 1; } else { if (c == dq || c == esc || !isPRINT(c)) { chsize = 2; switch (c) { case '\\' : /* fallthrough */ case '%' : if (c == esc) octbuf[1] = esc; else chsize = 1; break; case '\v' : octbuf[1] = 'v'; break; case '\t' : octbuf[1] = 't'; break; case '\r' : octbuf[1] = 'r'; break; case '\n' : octbuf[1] = 'n'; break; case '\f' : octbuf[1] = 'f'; break; case '"' : if (dq == '"') octbuf[1] = '"'; else chsize = 1; break; default: chsize = my_snprintf(octbuf, sizeof octbuf, pv < end && isDIGIT((U8)*(pv+readsize)) ? "%c%03o" : "%c%o", esc, c); } } else { chsize = 1; } } if (max && wrote + chsize > max) { break; } else if (chsize > 1) { sv_catpvn(dsv, octbuf, chsize); wrote += chsize; } else { char tmp[2]; my_snprintf(tmp, sizeof tmp, "%c", c); sv_catpvn(dsv, tmp, 1); wrote++; } if (flags & PERL_PV_ESCAPE_FIRSTCHAR) break; } if (escaped != NULL) *escaped= pv - str; return SvPVX(dsv); } #endif #endif #ifndef pv_pretty #if defined(NEED_pv_pretty) static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); static #else extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); #endif #ifdef pv_pretty # undef pv_pretty #endif #define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) #define Perl_pv_pretty DPPP_(my_pv_pretty) #if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) char * DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags) { const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; STRLEN escaped; if (!(flags & PERL_PV_PRETTY_NOCLEAR)) sv_setpvs(dsv, ""); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, "<"); if (start_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); if (end_color != NULL) sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); if (dq == '"') sv_catpvs(dsv, "\""); else if (flags & PERL_PV_PRETTY_LTGT) sv_catpvs(dsv, ">"); if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) sv_catpvs(dsv, "..."); return SvPVX(dsv); } #endif #endif #ifndef pv_display #if defined(NEED_pv_display) static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); static #else extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); #endif #ifdef pv_display # undef pv_display #endif #define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) #define Perl_pv_display DPPP_(my_pv_display) #if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) char * DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) { pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); if (len > cur && pv[cur] == '\0') sv_catpvs(dsv, "\\0"); return SvPVX(dsv); } #endif #endif #endif /* _P_P_PORTABILITY_H_ */ /* End of File include/ppport.h */ closure_reuse.t100644001750001750 120113065045605 17222 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 2; use FFI::CheckLib; use FFI::Platypus::Declare qw( void int ); lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; my $closure = closure { if (@_) { return $_[0] * 7; } return 21; }; attach [closure_set_closure1 => 'set_closure1'] => ['()->int'] => void; attach [closure_set_closure2 => 'set_closure2'] => ['(int)->int'] => void; attach [closure_call_closure1 => 'call_closure1'] => [] => int; attach [closure_call_closure2 => 'call_closure2'] => [int] => int; set_closure1($closure); set_closure2($closure); is call_closure1(), 21; is call_closure2(42), 294; closure_space.t100644001750001750 37313065045605 17163 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use FFI::Platypus; use Test::More tests => 2; my $ffi = FFI::Platypus->new; eval { $ffi->type('(int,int)->void') }; is $@, '', 'good without space'; eval { $ffi->type('(int, int) -> void') }; is $@, '', 'good with space'; bzip2.pl100644001750001750 400413065045605 17120 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use FFI::Platypus 0.20 (); # 0.20 required for using wrappers use FFI::CheckLib qw( find_lib_or_die ); use FFI::Platypus::Buffer qw( scalar_to_buffer buffer_to_scalar ); use FFI::Platypus::Memory qw( malloc free ); my $ffi = FFI::Platypus->new; $ffi->lib(find_lib_or_die lib => 'bz2'); $ffi->attach( [ BZ2_bzBuffToBuffCompress => 'compress' ] => [ 'opaque', # dest 'unsigned int *', # dest length 'opaque', # source 'unsigned int', # source length 'int', # blockSize100k 'int', # verbosity 'int', # workFactor ] => 'int', sub { my $sub = shift; my($source,$source_length) = scalar_to_buffer $_[0]; my $dest_length = int(length($source)*1.01) + 1 + 600; my $dest = malloc $dest_length; my $r = $sub->($dest, \$dest_length, $source, $source_length, 9, 0, 30); die "bzip2 error $r" unless $r == 0; my $compressed = buffer_to_scalar($dest, $dest_length); free $dest; $compressed; }, ); $ffi->attach( [ BZ2_bzBuffToBuffDecompress => 'decompress' ] => [ 'opaque', # dest 'unsigned int *', # dest length 'opaque', # source 'unsigned int', # source length 'int', # small 'int', # verbosity ] => 'int', sub { my $sub = shift; my($source, $source_length) = scalar_to_buffer $_[0]; my $dest_length = $_[1]; my $dest = malloc $dest_length; my $r = $sub->($dest, \$dest_length, $source, $source_length, 0, 0); die "bzip2 error $r" unless $r == 0; my $decompressed = buffer_to_scalar($dest, $dest_length); free $dest; $decompressed; }, ); my $original = "hello compression world\n"; my $compressed = compress($original); print decompress($compressed, length $original); run000755001750001750 013065045605 15136 5ustar00ollisgollisg000000000000FFI-Platypus-0.47/increadme.pl100644001750001750 73613065045605 17056 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/runuse strict; use warnings; use Pod::Abstract; use Pod::Simple::Text; my $root = Pod::Abstract->load_file("lib/FFI/Platypus.pm"); foreach my $name (qw( SUPPORT CONTRIBUTING )) { my($pod) = $root->select("/head1[\@heading=~{$name}]"); $_->detach for $pod->select('//#cut'); my $parser = Pod::Simple::Text->new; my $text; $parser->output_string( \$text ); $parser->parse_string_document( $pod->pod ); open my $fh, '>', $name; print $fh $text; close $fh; } travis.pl100644001750001750 120213065045605 17136 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/runuse strict; use warnings; use File::Find; use JSON::PP qw( encode_json decode_json ); my @list; # worlds worst interface find(sub { my $fn = $File::Find::name; return unless $fn =~ /\.pm/; push @list, $fn; }, 'lib'); die "requires MYMETA.json" unless -f 'MYMETA.json'; my %meta = do { open my $fh, '<', 'MYMETA.json'; my $meta = decode_json do { local $/; <$fh> }; close $fh; %$meta; }; foreach my $fn (@list) { open my $in, '<', $fn; my @list = <$in>; close $in; @list = map { s/^(# VERSION.*)$/our \$VERSION = '$meta{version}'; $1/; $_ } @list; open my $out, '>', $fn; print $out @list; close $out; } LibTest.pm100644001750001750 441313065045605 16765 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/Mypackage My::LibTest; use strict; use warnings; use File::Spec; use ExtUtils::CBuilder; use FindBin (); use File::Copy qw( move ); use File::Glob qw( bsd_glob ); use Config; use Text::ParseWords qw( shellwords ); my $root = $FindBin::Bin; sub build { my($class, $mb) = @_; my($header_time) = reverse sort map { (stat $_)[9] } bsd_glob "include/*.h"; my $compile_count = 0; my $b = $mb->cbuilder; my @obj = map { my $filename = $_; my($source_time) = reverse sort ((stat $filename)[9], $header_time); my $obj_name = $b->object_file($filename); my $obj_time = -e $obj_name ? ((stat $obj_name)[9]) : 0; if($obj_time < $source_time) { $b->compile( source => $filename, include_dirs => [ File::Spec->catdir($root, 'include'), ], extra_compiler_flags => $mb->extra_compiler_flags, ); $compile_count++; } $obj_name; } bsd_glob("libtest/*.c"); return unless $compile_count > 0; if($^O ne 'MSWin32') { my $dll = $b->link( lib_file => $b->lib_file(File::Spec->catfile($root, 'libtest', $b->object_file('libtest.c'))), objects => \@obj, extra_linker_flags => $mb->extra_linker_flags, ); if($^O =~ /^(cygwin|msys)$/) { my $old = $dll; my $new = $dll; if($^O eq 'cygwin') { $new =~ s{libtest.dll$}{cygtest-1.dll}; } elsif($^O eq 'msys') { $new =~ s{libtest.dll$}{msys-test-1.dll}; } else { die "how?"; } move($old => $new) || die "unable to copy $old => $new $!"; } } else { # On windows we can't depend on MM::CBuilder to make the .dll file because it creates dlls # that export only one symbol (which is used for bootstrapping XS modules). my $dll = File::Spec->catfile($FindBin::Bin, 'libtest', 'libtest.dll'); $dll =~ s{\\}{/}g; my @cmd; my $cc = $Config{cc}; if($cc !~ /cl(\.exe)?$/) { my $lddlflags = $Config{lddlflags}; $lddlflags =~ s{\\}{/}g; @cmd = ($cc, shellwords($lddlflags), -o => $dll, "-Wl,--export-all-symbols", @obj); } else { @cmd = ($cc, @obj, '/link', '/dll', '/out:' . $dll); } print "@cmd\n"; system @cmd; exit 2 if $?; } } 1; libtest.h100644001750001750 32613065045605 17144 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/include#ifndef LIBTEST_H #define LIBTEST_H #include "ffi_platypus.h" #ifdef HAVE_STDIO_H #include #endif #ifdef _MSC_VER #define EXTERN extern __declspec(dllexport) #else #define EXTERN extern #endif #endif ClosureData.xs100644001750001750 50013065045605 17110 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xsMODULE = FFI::Platypus PACKAGE = FFI::Platypus::ClosureData void DESTROY(self) ffi_pl_closure *self CODE: /* if(PL_dirty) fprintf(stderr, "global DESTROY\n"); else fprintf(stderr, "local DESTROY\n"); fflush(stderr); */ ffi_closure_free(self->ffi_closure); Safefree(self); closure.c100644001750001750 71113065045605 17166 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/libtest#include "libtest.h" typedef int (*closure1_t)(void); typedef int (*closure2_t)(int); static closure1_t my_closure1; static closure2_t my_closure2; EXTERN void closure_set_closure1(closure1_t closure) { my_closure1 = closure; } EXTERN void closure_set_closure2(closure2_t closure) { my_closure2 = closure; } EXTERN int closure_call_closure1(void) { return my_closure1(); } EXTERN int closure_call_closure2(int arg) { return my_closure2(arg); } memcmp4.c100644001750001750 23313065045605 17053 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/libtest#include "libtest.h" EXTERN int memcmp4(void *buf1, size_t n1, void *buf2, size_t n2) { if (n1 != n2) return 1; return memcmp(buf1, buf2, n1); } pointer.c100644001750001750 323313065045605 17214 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/libtest#include "libtest.h" EXTERN void * pointer_null(void) { return NULL; } EXTERN int pointer_is_null(void *ptr) { return ptr == NULL; } EXTERN int pointer_pointer_is_null(void **ptr) { return *ptr == NULL; } static void *my_pointer; EXTERN void pointer_set_my_pointer(void *ptr) { my_pointer = ptr; } EXTERN void * pointer_get_my_pointer(void) { return my_pointer; } EXTERN void pointer_get_my_pointer_arg(void **ret) { *ret = my_pointer; } EXTERN int pointer_arg_array_in(char *array[3]) { return !strcmp(array[0], "one") && !strcmp(array[1], "two") && !strcmp(array[2], "three"); } EXTERN int pointer_arg_array_null_in(char *array[3]) { return array[0] == NULL && array[1] == NULL && array[2] == NULL; } EXTERN void pointer_arg_array_out(char *array[3]) { array[0] = "four"; array[1] = "five"; array[2] = "six"; } EXTERN void pointer_arg_array_null_out(char *array[3]) { array[0] = NULL; array[1] = NULL; array[2] = NULL; } EXTERN char ** pointer_ret_array_out(void) { static char *array[3] = { "seven", "eight", "nine" }; return array; } EXTERN char ** pointer_ret_array_null_out(void) { static char *array[3] = { NULL, NULL, NULL }; return array; } EXTERN void * pointer_pointer_pointer_to_pointer(void **pointer_pointer) { return *pointer_pointer; } EXTERN void** pointer_pointer_to_pointer_pointer(void *pointer) { static void *pointer_pointer[1]; pointer_pointer[0] = pointer; return pointer_pointer; } typedef void *(*closure_t)(void*); static closure_t my_closure; EXTERN void pointer_set_closure(closure_t closure) { my_closure = closure; } EXTERN void* pointer_call_closure(void *value) { return my_closure(value); } closure.c100644001750001750 55613065045605 17345 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examples/* * closure.c - on Linux compile with: gcc closure.c -shared -o closure.so -fPIC */ #include typedef int (*closure_t)(int); closure_t my_closure = NULL; void set_closure(closure_t value) { my_closure = value; } int call_closure(int value) { if(my_closure != NULL) return my_closure(value); else fprintf(stderr, "closure is NULL\n"); } malloc.pl100644001750001750 47113065045605 17325 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use FFI::Platypus; use FFI::Platypus::Memory qw( malloc free memcpy ); my $ffi = FFI::Platypus->new; my $buffer = malloc 12; memcpy $buffer, $ffi->cast('string' => 'opaque', "hello there"), length "hello there\0"; print $ffi->cast('opaque' => 'string', $buffer), "\n"; free $buffer; string.pl100644001750001750 65613065045605 17371 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->attach(puts => ['string'] => 'int'); $ffi->attach(strlen => ['string'] => 'int'); puts(strlen('somestring')); $ffi->attach(strstr => ['string','string'] => 'string'); puts(strstr('somestring', 'string')); #attach puts => [string] => int; puts(puts("lol")); $ffi->attach(strerror => ['int'] => 'string'); puts(strerror(2)); notify.pl100644001750001750 210213065045605 17377 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use FFI::CheckLib; use FFI::Platypus; # NOTE: I ported this from the like named eg/notify.pl that came with FFI::Raw # and it seems to work most of the time, but also seems to SIGSEGV sometimes. # I saw the same behavior in the FFI::Raw version, and am not really familiar # with the libnotify API to say what is the cause. Patches welcome to fix it. my $ffi = FFI::Platypus->new; $ffi->lib(find_lib_or_exit lib => 'notify'); $ffi->attach(notify_init => ['string'] => 'void'); $ffi->attach(notify_uninit => [] => 'void'); $ffi->attach([notify_notification_new => 'notify_new'] => ['string', 'string', 'string'] => 'opaque'); $ffi->attach([notify_notification_update => 'notify_update'] => ['opaque', 'string', 'string', 'string'] => 'void'); $ffi->attach([notify_notification_show => 'notify_show'] => ['opaque', 'opaque'] => 'void'); notify_init('FFI::Platypus'); my $n = notify_new('','',''); notify_update($n, 'FFI::Platypus', 'It works!!!', 'media-playback-start'); notify_show($n, undef); notify_uninit(); getpid.pl100644001750001750 30013065045605 17321 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->attach(puts => ['string'] => 'int'); $ffi->attach(getpid => [] => 'int'); puts(getpid()); template000755001750001750 013065045605 16145 5ustar00ollisgollisg000000000000FFI-Platypus-0.47/incabi.c100644001750001750 43613065045605 17167 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/template#include "ffi_platypus.h" #include int main(int argc, char *argv[]) { ffi_cif cif; ffi_type *args[1]; ffi_abi abi; abi = ##ARG##; if(ffi_prep_cif(&cif, abi, 0, &ffi_type_void, args) == FFI_OK) { printf("|value=%d|\n", abi); return 0; } return 2; } AutoConf.pm100644001750001750 1304013065045605 17151 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/Mypackage My::AutoConf; use strict; use warnings; use Config::AutoConf; use Config; use File::Spec; use FindBin; use My::ShareConfig; my $root = $FindBin::Bin; my $prologue = < #endif #ifdef HAVE_ALLOCA_H #include #endif #ifdef HAVE_STDINT_H #include #endif #ifdef HAVE_COMPLEX_H #include #endif #define signed(type) (((type)-1) < 0) ? 1 : 0 EOF my @probe_types = split /\n/, <rel2abs( File::Spec->catfile( 'include', 'ffi_platypus_config.h' ) ); sub configure { my($self) = @_; my $share_config = My::ShareConfig->new; return if -r $config_h && ref($share_config->get( 'type_map' )) eq 'HASH'; my $ac = Config::AutoConf->new; $ac->check_prog_cc; $ac->define_var( do { my $os = uc $^O; $os =~ s/-/_/; $os =~ s/[^A-Z0-9_]//g; "PERL_OS_$os"; } => 1 ); $ac->define_var( PERL_OS_WINDOWS => 1 ) if $^O =~ /^(MSWin32|cygwin|msys)$/; foreach my $header (qw( stdlib stdint sys/types sys/stat unistd alloca dlfcn limits stddef wchar signal inttypes windows sys/cygwin string psapi stdio stdbool complex )) { $ac->check_header("$header.h"); } $ac->check_stdc_headers; if($ac->check_decl('RTLD_LAZY', { prologue => $prologue })) { $ac->define_var( HAVE_RTLD_LAZY => 1 ); } unless($share_config->get('config_no_alloca')) { if($ac->check_decl('alloca', { prologue => $prologue })) { $ac->define_var( HAVE_ALLOCA => 1 ); } } if(!$share_config->get('config_debug_fake32') && $Config{ivsize} >= 8) { $ac->define_var( HAVE_IV_IS_64 => 1 ); } else { $ac->define_var( HAVE_IV_IS_64 => 0 ); } foreach my $lib (map { s/^-l//; $_ } split /\s+/, $Config{perllibs}) { if($ac->check_lib($lib, 'dlopen')) { $ac->define_var( 'HAVE_dlopen' => 1 ); last; } } my %type_map; foreach my $type (@probe_types) { my $size; if($type =~ /^u?int(8|16|32|64)_t$/) { $size = $1 / 8; } else { $size = $ac->check_sizeof_type($type); } if($size) { if($type !~ /^(float|double|long double)$/) { my $signed; if($type =~ /^signed / || $type =~ /^(int[0-9]+_t|int_least[0-9]+_t)$/) { $signed = 1; } elsif($type =~ /^unsigned / || $type =~ /^(uint[0-9]+_t|uint_least[0-9]+_t)$/) { $signed = 0; } $signed = $ac->compute_int("signed($type)", { prologue => $prologue }) unless defined $signed; $type_map{$type} = sprintf "%sint%d", ($signed ? 's' : 'u'), $size*8; } } } $type_map{uchar} = $type_map{'unsigned char'}; $type_map{ushort} = $type_map{'unsigned short'}; $type_map{uint} = $type_map{'unsigned int'}; $type_map{ulong} = $type_map{'unsigned long'}; # on Linux and OS X at least the test for bool fails # but _Bool works (even though code using bool seems # to work for both). May be because bool is a macro # for _Bool or something. $type_map{bool} ||= delete $type_map{_Bool}; delete $type_map{_Bool}; $ac->check_default_headers; my %align = ( pointer => _alignment($ac, 'void*'), float => _alignment($ac, 'float'), double => _alignment($ac, 'double'), 'long double' => _alignment($ac, 'long double'), 'float complex' => _alignment($ac, 'float complex'), 'double complex' => _alignment($ac, 'double complex'), ); foreach my $bits (qw( 8 16 32 64 )) { $align{'sint'.$bits} = $align{'uint'.$bits} = _alignment($ac, "int${bits}_t"); } if($ac->check_sizeof_type('long double', { prologue => $prologue })) { $type_map{'long double'} = 'longdouble'; } if($ac->check_sizeof_type('float complex', { prologue => $prologue })) { $type_map{'float complex'} = 'complex_float'; } if($ac->check_sizeof_type('double complex', { prologue => $prologue })) { $type_map{'double complex'} = 'complex_double'; } if(my $size = $ac->check_sizeof_type('complex', { prologue => $prologue })) { if($size == 8) { $type_map{'complex'} = 'complex_float'; } elsif($size == 16) { $type_map{'complex'} = 'complex_double'; } } $ac->write_config_h( $config_h ); $share_config->set( type_map => \%type_map ); $share_config->set( align => \%align ); } sub _alignment { my($ac, $type) = @_; my $align = $ac->check_alignof_type($type); return $align if $align; # This no longer seems necessary now that we do a # check_default_headers above. See: # # https://github.com/ambs/Config-AutoConf/issues/7 my $btype = $type eq 'void*' ? 'vpointer' : "b$type"; $btype =~ s/\s+/_/g; my $prologue2 = $prologue . < #endif struct align { char a; $type $btype; }; EOF return $ac->compute_int("__builtin_offsetof(struct align, $btype)", { prologue => $prologue2 }); } sub clean { unlink $config_h; } 1; record_string.c100644001750001750 511213065045605 17362 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xs#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #include "ffi_platypus.h" #include "ffi_platypus_guts.h" XS(ffi_pl_record_accessor_string_ro) { ffi_pl_record_member *member; SV *self; SV *arg; char *ptr1; char **ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); if(!SvOK(self)) croak("Null record error"); ptr1 = (char*) SvPV_nolen(self); ptr2 = (char**) &ptr1[member->offset]; if(items > 1) { croak("member is read only"); } if(GIMME_V == G_VOID) XSRETURN_EMPTY; if(*ptr2 != NULL) XSRETURN_PV(*ptr2); else XSRETURN_EMPTY; } XS(ffi_pl_record_accessor_string_rw) { ffi_pl_record_member *member; SV *self; SV *arg; char *ptr1; char **ptr2; char *arg_ptr; STRLEN len; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); if(!SvOK(self)) croak("Null record error"); ptr1 = (char*) SvPV_nolen(self); ptr2 = (char**) &ptr1[member->offset]; if(items > 1) { arg = ST(1); if(SvOK(arg)) { arg_ptr = SvPV(arg, len); *ptr2 = realloc(*ptr2, len+1); (*ptr2)[len] = 0; memcpy(*ptr2, arg_ptr, len); } else if(*ptr2 != NULL) { free(*ptr2); *ptr2 = NULL; } } if(GIMME_V == G_VOID) XSRETURN_EMPTY; if(*ptr2 != NULL) XSRETURN_PV(*ptr2); else XSRETURN_EMPTY; } XS(ffi_pl_record_accessor_string_fixed) { ffi_pl_record_member *member; SV *self; SV *arg; SV *value; char *ptr1; char *ptr2; char *arg_ptr; STRLEN len; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); if(!SvOK(self)) croak("Null record error"); ptr1 = (char*) SvPV_nolen(self); ptr2 = (char*) &ptr1[member->offset]; if(items > 1) { arg = ST(1); if(SvOK(arg)) { arg_ptr = SvPV(ST(1), len); if(len > member->count) len = member->count; memcpy(ptr2, arg_ptr, len); } else { croak("Cannot assign undef to a fixed string field"); } } if(GIMME_V == G_VOID) XSRETURN_EMPTY; value = sv_newmortal(); sv_setpvn(value, ptr2, member->count); ST(0) = value; XSRETURN(1); } record_simple.c100644001750001750 5107013065045605 17371 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xs/* DO NOT MODIFY THIS FILE it is generated from these files: * inc/template/accessor.tt * inc/template/accessor_wrapper.tt * inc/run/generate_record_accessor.pl */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #include "ffi_platypus.h" #include "ffi_platypus_guts.h" XS(ffi_pl_record_accessor_uint8) { ffi_pl_record_member *member; SV *self; char *ptr1; uint8_t *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); if(!SvOK(self)) croak("Null record error"); ptr1 = (char*) SvPV_nolen(self); ptr2 = (uint8_t*) &ptr1[member->offset]; if(items > 1) *ptr2 = (uint8_t) SvUV(ST(1)); if(GIMME_V == G_VOID) XSRETURN_EMPTY; XSRETURN_UV(*ptr2); } XS(ffi_pl_record_accessor_uint8_array) { ffi_pl_record_member *member; SV *self; SV *arg; SV **item; AV *av; char *ptr1; int i; uint8_t *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); ptr1 = (char*) SvPV_nolen(self); ptr2 = (uint8_t*) &ptr1[member->offset]; if(items > 2) { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { arg = ST(2); ptr2[i] = SvUV(arg); } else { warn("illegal index %d", i); } } else if(items > 1) { arg = ST(1); if(SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) { av = (AV*) SvRV(arg); for(i=0; i < member->count; i++) { item = av_fetch(av, i, 0); if(item != NULL && SvOK(*item)) { ptr2[i] = SvUV(*item); } else { ptr2[i] = 0; } } } else { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { XSRETURN_UV(ptr2[i]); } else { warn("illegal index %d", i); XSRETURN_EMPTY; } } } if(GIMME_V == G_VOID) XSRETURN_EMPTY; av = newAV(); av_fill(av, member->count-1); for(i=0; i < member->count; i++) { sv_setuv(*av_fetch(av, i, 1), ptr2[i]); } ST(0) = newRV_inc((SV*)av); XSRETURN(1); } XS(ffi_pl_record_accessor_sint8) { ffi_pl_record_member *member; SV *self; char *ptr1; int8_t *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); if(!SvOK(self)) croak("Null record error"); ptr1 = (char*) SvPV_nolen(self); ptr2 = (int8_t*) &ptr1[member->offset]; if(items > 1) *ptr2 = (int8_t) SvIV(ST(1)); if(GIMME_V == G_VOID) XSRETURN_EMPTY; XSRETURN_IV(*ptr2); } XS(ffi_pl_record_accessor_sint8_array) { ffi_pl_record_member *member; SV *self; SV *arg; SV **item; AV *av; char *ptr1; int i; int8_t *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); ptr1 = (char*) SvPV_nolen(self); ptr2 = (int8_t*) &ptr1[member->offset]; if(items > 2) { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { arg = ST(2); ptr2[i] = SvIV(arg); } else { warn("illegal index %d", i); } } else if(items > 1) { arg = ST(1); if(SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) { av = (AV*) SvRV(arg); for(i=0; i < member->count; i++) { item = av_fetch(av, i, 0); if(item != NULL && SvOK(*item)) { ptr2[i] = SvIV(*item); } else { ptr2[i] = 0; } } } else { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { XSRETURN_IV(ptr2[i]); } else { warn("illegal index %d", i); XSRETURN_EMPTY; } } } if(GIMME_V == G_VOID) XSRETURN_EMPTY; av = newAV(); av_fill(av, member->count-1); for(i=0; i < member->count; i++) { sv_setiv(*av_fetch(av, i, 1), ptr2[i]); } ST(0) = newRV_inc((SV*)av); XSRETURN(1); } XS(ffi_pl_record_accessor_uint16) { ffi_pl_record_member *member; SV *self; char *ptr1; uint16_t *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); if(!SvOK(self)) croak("Null record error"); ptr1 = (char*) SvPV_nolen(self); ptr2 = (uint16_t*) &ptr1[member->offset]; if(items > 1) *ptr2 = (uint16_t) SvUV(ST(1)); if(GIMME_V == G_VOID) XSRETURN_EMPTY; XSRETURN_UV(*ptr2); } XS(ffi_pl_record_accessor_uint16_array) { ffi_pl_record_member *member; SV *self; SV *arg; SV **item; AV *av; char *ptr1; int i; uint16_t *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); ptr1 = (char*) SvPV_nolen(self); ptr2 = (uint16_t*) &ptr1[member->offset]; if(items > 2) { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { arg = ST(2); ptr2[i] = SvUV(arg); } else { warn("illegal index %d", i); } } else if(items > 1) { arg = ST(1); if(SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) { av = (AV*) SvRV(arg); for(i=0; i < member->count; i++) { item = av_fetch(av, i, 0); if(item != NULL && SvOK(*item)) { ptr2[i] = SvUV(*item); } else { ptr2[i] = 0; } } } else { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { XSRETURN_UV(ptr2[i]); } else { warn("illegal index %d", i); XSRETURN_EMPTY; } } } if(GIMME_V == G_VOID) XSRETURN_EMPTY; av = newAV(); av_fill(av, member->count-1); for(i=0; i < member->count; i++) { sv_setuv(*av_fetch(av, i, 1), ptr2[i]); } ST(0) = newRV_inc((SV*)av); XSRETURN(1); } XS(ffi_pl_record_accessor_sint16) { ffi_pl_record_member *member; SV *self; char *ptr1; int16_t *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); if(!SvOK(self)) croak("Null record error"); ptr1 = (char*) SvPV_nolen(self); ptr2 = (int16_t*) &ptr1[member->offset]; if(items > 1) *ptr2 = (int16_t) SvIV(ST(1)); if(GIMME_V == G_VOID) XSRETURN_EMPTY; XSRETURN_IV(*ptr2); } XS(ffi_pl_record_accessor_sint16_array) { ffi_pl_record_member *member; SV *self; SV *arg; SV **item; AV *av; char *ptr1; int i; int16_t *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); ptr1 = (char*) SvPV_nolen(self); ptr2 = (int16_t*) &ptr1[member->offset]; if(items > 2) { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { arg = ST(2); ptr2[i] = SvIV(arg); } else { warn("illegal index %d", i); } } else if(items > 1) { arg = ST(1); if(SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) { av = (AV*) SvRV(arg); for(i=0; i < member->count; i++) { item = av_fetch(av, i, 0); if(item != NULL && SvOK(*item)) { ptr2[i] = SvIV(*item); } else { ptr2[i] = 0; } } } else { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { XSRETURN_IV(ptr2[i]); } else { warn("illegal index %d", i); XSRETURN_EMPTY; } } } if(GIMME_V == G_VOID) XSRETURN_EMPTY; av = newAV(); av_fill(av, member->count-1); for(i=0; i < member->count; i++) { sv_setiv(*av_fetch(av, i, 1), ptr2[i]); } ST(0) = newRV_inc((SV*)av); XSRETURN(1); } XS(ffi_pl_record_accessor_uint32) { ffi_pl_record_member *member; SV *self; char *ptr1; uint32_t *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); if(!SvOK(self)) croak("Null record error"); ptr1 = (char*) SvPV_nolen(self); ptr2 = (uint32_t*) &ptr1[member->offset]; if(items > 1) *ptr2 = (uint32_t) SvUV(ST(1)); if(GIMME_V == G_VOID) XSRETURN_EMPTY; XSRETURN_UV(*ptr2); } XS(ffi_pl_record_accessor_uint32_array) { ffi_pl_record_member *member; SV *self; SV *arg; SV **item; AV *av; char *ptr1; int i; uint32_t *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); ptr1 = (char*) SvPV_nolen(self); ptr2 = (uint32_t*) &ptr1[member->offset]; if(items > 2) { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { arg = ST(2); ptr2[i] = SvUV(arg); } else { warn("illegal index %d", i); } } else if(items > 1) { arg = ST(1); if(SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) { av = (AV*) SvRV(arg); for(i=0; i < member->count; i++) { item = av_fetch(av, i, 0); if(item != NULL && SvOK(*item)) { ptr2[i] = SvUV(*item); } else { ptr2[i] = 0; } } } else { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { XSRETURN_UV(ptr2[i]); } else { warn("illegal index %d", i); XSRETURN_EMPTY; } } } if(GIMME_V == G_VOID) XSRETURN_EMPTY; av = newAV(); av_fill(av, member->count-1); for(i=0; i < member->count; i++) { sv_setuv(*av_fetch(av, i, 1), ptr2[i]); } ST(0) = newRV_inc((SV*)av); XSRETURN(1); } XS(ffi_pl_record_accessor_sint32) { ffi_pl_record_member *member; SV *self; char *ptr1; int32_t *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); if(!SvOK(self)) croak("Null record error"); ptr1 = (char*) SvPV_nolen(self); ptr2 = (int32_t*) &ptr1[member->offset]; if(items > 1) *ptr2 = (int32_t) SvIV(ST(1)); if(GIMME_V == G_VOID) XSRETURN_EMPTY; XSRETURN_IV(*ptr2); } XS(ffi_pl_record_accessor_sint32_array) { ffi_pl_record_member *member; SV *self; SV *arg; SV **item; AV *av; char *ptr1; int i; int32_t *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); ptr1 = (char*) SvPV_nolen(self); ptr2 = (int32_t*) &ptr1[member->offset]; if(items > 2) { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { arg = ST(2); ptr2[i] = SvIV(arg); } else { warn("illegal index %d", i); } } else if(items > 1) { arg = ST(1); if(SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) { av = (AV*) SvRV(arg); for(i=0; i < member->count; i++) { item = av_fetch(av, i, 0); if(item != NULL && SvOK(*item)) { ptr2[i] = SvIV(*item); } else { ptr2[i] = 0; } } } else { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { XSRETURN_IV(ptr2[i]); } else { warn("illegal index %d", i); XSRETURN_EMPTY; } } } if(GIMME_V == G_VOID) XSRETURN_EMPTY; av = newAV(); av_fill(av, member->count-1); for(i=0; i < member->count; i++) { sv_setiv(*av_fetch(av, i, 1), ptr2[i]); } ST(0) = newRV_inc((SV*)av); XSRETURN(1); } XS(ffi_pl_record_accessor_uint64) { ffi_pl_record_member *member; SV *self; char *ptr1; uint64_t *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); if(!SvOK(self)) croak("Null record error"); ptr1 = (char*) SvPV_nolen(self); ptr2 = (uint64_t*) &ptr1[member->offset]; if(items > 1) *ptr2 = (uint64_t) SvUV(ST(1)); if(GIMME_V == G_VOID) XSRETURN_EMPTY; XSRETURN_UV(*ptr2); } XS(ffi_pl_record_accessor_uint64_array) { ffi_pl_record_member *member; SV *self; SV *arg; SV **item; AV *av; char *ptr1; int i; uint64_t *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); ptr1 = (char*) SvPV_nolen(self); ptr2 = (uint64_t*) &ptr1[member->offset]; if(items > 2) { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { arg = ST(2); ptr2[i] = SvUV(arg); } else { warn("illegal index %d", i); } } else if(items > 1) { arg = ST(1); if(SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) { av = (AV*) SvRV(arg); for(i=0; i < member->count; i++) { item = av_fetch(av, i, 0); if(item != NULL && SvOK(*item)) { ptr2[i] = SvUV(*item); } else { ptr2[i] = 0; } } } else { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { XSRETURN_UV(ptr2[i]); } else { warn("illegal index %d", i); XSRETURN_EMPTY; } } } if(GIMME_V == G_VOID) XSRETURN_EMPTY; av = newAV(); av_fill(av, member->count-1); for(i=0; i < member->count; i++) { sv_setuv(*av_fetch(av, i, 1), ptr2[i]); } ST(0) = newRV_inc((SV*)av); XSRETURN(1); } XS(ffi_pl_record_accessor_sint64) { ffi_pl_record_member *member; SV *self; char *ptr1; int64_t *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); if(!SvOK(self)) croak("Null record error"); ptr1 = (char*) SvPV_nolen(self); ptr2 = (int64_t*) &ptr1[member->offset]; if(items > 1) *ptr2 = (int64_t) SvIV(ST(1)); if(GIMME_V == G_VOID) XSRETURN_EMPTY; XSRETURN_IV(*ptr2); } XS(ffi_pl_record_accessor_sint64_array) { ffi_pl_record_member *member; SV *self; SV *arg; SV **item; AV *av; char *ptr1; int i; int64_t *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); ptr1 = (char*) SvPV_nolen(self); ptr2 = (int64_t*) &ptr1[member->offset]; if(items > 2) { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { arg = ST(2); ptr2[i] = SvIV(arg); } else { warn("illegal index %d", i); } } else if(items > 1) { arg = ST(1); if(SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) { av = (AV*) SvRV(arg); for(i=0; i < member->count; i++) { item = av_fetch(av, i, 0); if(item != NULL && SvOK(*item)) { ptr2[i] = SvIV(*item); } else { ptr2[i] = 0; } } } else { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { XSRETURN_IV(ptr2[i]); } else { warn("illegal index %d", i); XSRETURN_EMPTY; } } } if(GIMME_V == G_VOID) XSRETURN_EMPTY; av = newAV(); av_fill(av, member->count-1); for(i=0; i < member->count; i++) { sv_setiv(*av_fetch(av, i, 1), ptr2[i]); } ST(0) = newRV_inc((SV*)av); XSRETURN(1); } XS(ffi_pl_record_accessor_float) { ffi_pl_record_member *member; SV *self; char *ptr1; float *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); if(!SvOK(self)) croak("Null record error"); ptr1 = (char*) SvPV_nolen(self); ptr2 = (float*) &ptr1[member->offset]; if(items > 1) *ptr2 = (float) SvNV(ST(1)); if(GIMME_V == G_VOID) XSRETURN_EMPTY; XSRETURN_NV(*ptr2); } XS(ffi_pl_record_accessor_float_array) { ffi_pl_record_member *member; SV *self; SV *arg; SV **item; AV *av; char *ptr1; int i; float *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); ptr1 = (char*) SvPV_nolen(self); ptr2 = (float*) &ptr1[member->offset]; if(items > 2) { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { arg = ST(2); ptr2[i] = SvNV(arg); } else { warn("illegal index %d", i); } } else if(items > 1) { arg = ST(1); if(SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) { av = (AV*) SvRV(arg); for(i=0; i < member->count; i++) { item = av_fetch(av, i, 0); if(item != NULL && SvOK(*item)) { ptr2[i] = SvNV(*item); } else { ptr2[i] = 0.0; } } } else { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { XSRETURN_NV(ptr2[i]); } else { warn("illegal index %d", i); XSRETURN_EMPTY; } } } if(GIMME_V == G_VOID) XSRETURN_EMPTY; av = newAV(); av_fill(av, member->count-1); for(i=0; i < member->count; i++) { sv_setnv(*av_fetch(av, i, 1), ptr2[i]); } ST(0) = newRV_inc((SV*)av); XSRETURN(1); } XS(ffi_pl_record_accessor_double) { ffi_pl_record_member *member; SV *self; char *ptr1; double *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); if(!SvOK(self)) croak("Null record error"); ptr1 = (char*) SvPV_nolen(self); ptr2 = (double*) &ptr1[member->offset]; if(items > 1) *ptr2 = (double) SvNV(ST(1)); if(GIMME_V == G_VOID) XSRETURN_EMPTY; XSRETURN_NV(*ptr2); } XS(ffi_pl_record_accessor_double_array) { ffi_pl_record_member *member; SV *self; SV *arg; SV **item; AV *av; char *ptr1; int i; double *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); ptr1 = (char*) SvPV_nolen(self); ptr2 = (double*) &ptr1[member->offset]; if(items > 2) { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { arg = ST(2); ptr2[i] = SvNV(arg); } else { warn("illegal index %d", i); } } else if(items > 1) { arg = ST(1); if(SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) { av = (AV*) SvRV(arg); for(i=0; i < member->count; i++) { item = av_fetch(av, i, 0); if(item != NULL && SvOK(*item)) { ptr2[i] = SvNV(*item); } else { ptr2[i] = 0.0; } } } else { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { XSRETURN_NV(ptr2[i]); } else { warn("illegal index %d", i); XSRETURN_EMPTY; } } } if(GIMME_V == G_VOID) XSRETURN_EMPTY; av = newAV(); av_fill(av, member->count-1); for(i=0; i < member->count; i++) { sv_setnv(*av_fetch(av, i, 1), ptr2[i]); } ST(0) = newRV_inc((SV*)av); XSRETURN(1); } record_opaque.c100644001750001750 506613065045605 17356 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xs#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #include "ffi_platypus.h" #include "ffi_platypus_guts.h" XS(ffi_pl_record_accessor_opaque) { ffi_pl_record_member *member; SV *self; SV *arg; char *ptr1; void **ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); if(!SvOK(self)) croak("Null record error"); ptr1 = (char*) SvPV_nolen(self); ptr2 = (void**) &ptr1[member->offset]; if(items > 1) { arg = ST(1); *ptr2 = SvOK(arg) ? INT2PTR(void*, SvIV(arg)) : NULL; } if(GIMME_V == G_VOID) XSRETURN_EMPTY; if(*ptr2 != NULL) XSRETURN_IV( PTR2IV( *ptr2 )); else XSRETURN_EMPTY; } XS(ffi_pl_record_accessor_opaque_array) { ffi_pl_record_member *member; SV *self; SV *arg; SV **item; AV *av; char *ptr1; void **ptr2; int i; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); if(!SvOK(self)) croak("Null record error"); ptr1 = (char*) SvPV_nolen(self); ptr2 = (void**) &ptr1[member->offset]; if(items > 2) { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { arg = ST(2); ptr2[i] = SvOK(arg) ? INT2PTR(void*, SvIV(arg)) : NULL; } else { warn("illegal index %d", i); } } else if(items > 1) { arg = ST(1); if(SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) { av = (AV*) SvRV(arg); for(i=0; i < member->count; i++) { item = av_fetch(av, i, 0); if(item != NULL && SvOK(*item)) { ptr2[i] = INT2PTR(void*, SvIV(*item)); } else { ptr2[i] = NULL; } } } else { i = SvIV(ST(1)); if(i < 0 && i >= member->count) { warn("illegal index %d", i); XSRETURN_EMPTY; } else if(ptr2[i] == NULL) { XSRETURN_EMPTY; } else { XSRETURN_IV(PTR2IV(ptr2[i])); } warn("passing non array reference into ffi/platypus array argument type"); } } if(GIMME_V == G_VOID) XSRETURN_EMPTY; av = newAV(); av_fill(av, member->count-1); for(i=0; i < member->count; i++) { if(ptr2[i] != NULL) sv_setiv(*av_fetch(av, i, 1), PTR2IV(ptr2[i])); } ST(0) = newRV_inc((SV*)av); XSRETURN(1); } strict.t100644001750001750 101413065045605 17347 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xt/authoruse strict; use warnings; use Test::More; BEGIN { plan skip_all => 'test requires Test::Strict' unless eval q{ use Test::Strict; 1 }; }; use Test::Strict; use FindBin; use File::Spec; chdir(File::Spec->catdir($FindBin::Bin, File::Spec->updir, File::Spec->updir)); unshift @Test::Strict::MODULES_ENABLING_STRICT, 'ozo', 'Test2::Bundle::SIPS', 'Test2::Bundle::Extended'; note "enabling strict = $_" for @Test::Strict::MODULES_ENABLING_STRICT; all_perl_files_ok( grep { -e $_ } qw( bin lib t Makefile.PL )); release000755001750001750 013065045605 15634 5ustar00ollisgollisg000000000000FFI-Platypus-0.47/xtfixme.t100644001750001750 62013065045605 17247 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xt/releaseuse strict; use warnings; use Test::More; BEGIN { plan skip_all => 'test requires Test::Fixme' unless eval q{ use Test::Fixme 0.14; 1 }; }; use Test::Fixme 0.07; use FindBin; use File::Spec; chdir(File::Spec->catdir($FindBin::Bin, File::Spec->updir, File::Spec->updir)); run_tests( match => qr/FIXME/, where => [ grep { -e $_ } qw( bin lib t Makefile.PL Build.PL )], warn => 1, ); type_longdouble.t100644001750001750 1024013065045605 17561 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib; BEGIN { plan skip_all => 'test requires support for long double' unless FFI::Platypus::_have_type('longdouble'); } use FFI::Platypus::Declare 'longdouble', 'int', ['longdouble*' => 'longdouble_p'], ['longdouble[3]' => 'longdouble_a3' ], ['longdouble[]' => 'longdouble_a' ]; plan tests => 2; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach [longdouble_add => 'add'] => [longdouble,longdouble] => longdouble; attach longdouble_pointer_test => [longdouble_p, longdouble_p] => int; attach longdouble_array_test => [longdouble_a, int] => int; attach [longdouble_array_test => 'longdouble_array_test3'] => [longdouble_a3, int] => int; attach longdouble_array_return_test => [] => longdouble_a3; attach pointer_is_null => [longdouble_p] => int; attach longdouble_pointer_return_test => [longdouble] => longdouble_p; attach pointer_null => [] => longdouble_p; subtest 'with Math::LongDouble' => sub { plan skip_all => 'test requires Math::LongDouble' unless eval q{ use Math::LongDouble; 1 }; plan tests => 5; my $ld15 = Math::LongDouble->new(1.5); my $ld25 = Math::LongDouble->new(2.5); my $ld40 = Math::LongDouble->new(4.0); my $ld80 = Math::LongDouble->new(8.0); subtest 'scalar' => sub { plan tests => 2; my $result = add($ld15, $ld25); isa_ok $result, 'Math::LongDouble'; ok $result == $ld40, "add(1.5,2.5) = 4.0"; }; subtest 'pointer' => sub { plan tests => 6; my $a = Math::LongDouble->new(1.5); my $b = Math::LongDouble->new(2.5); ok longdouble_pointer_test(\$a, \$b); ok $a == $ld40; ok $b == $ld80; ok pointer_is_null(undef); my $c = longdouble_pointer_return_test($ld15); isa_ok $$c, 'Math::LongDouble'; ok $$c == $ld15; }; my $ld10 = Math::LongDouble->new(1.0); my $ld20 = Math::LongDouble->new(2.0); my $ld30 = Math::LongDouble->new(3.0); subtest 'array fixed' => sub { plan tests => 4; my $list = [ map { Math::LongDouble->new($_) } qw( 25.0 25.0 50.0 )]; ok longdouble_array_test3($list, 3); note "[", join(',', map { "$_" } @$list), "]"; ok $list->[0] == $ld10; ok $list->[1] == $ld20; ok $list->[2] == $ld30; }; subtest 'array var' => sub { plan tests => 4; my $list = [ map { Math::LongDouble->new($_) } qw( 25.0 25.0 50.0 )]; ok longdouble_array_test($list, 3); note "[", join(',', map { "$_" } @$list), "]"; ok $list->[0] == $ld10; ok $list->[1] == $ld20; ok $list->[2] == $ld30; }; subtest 'array return' => sub { plan tests => 3; my $list = longdouble_array_return_test(); note "[", join(',', map { "$_" } @$list), "]"; ok $list->[0] == $ld10; ok $list->[1] == $ld20; ok $list->[2] == $ld30; }; }; subtest 'without Math::LongDouble' => sub { plan tests => 5; if(FFI::Platypus::_have_math_longdouble()) { note "You have Math::LongDouble, but for this test we are going to turn it off"; FFI::Platypus::_have_math_longdouble(0); } subtest 'scalar' => sub { plan tests => 1; is add(1.5, 2.5), 4.0, "add(1.5,2.5) = 4"; }; subtest 'pointer' => sub { plan tests => 5; my $a = 1.5; my $b = 2.5; ok longdouble_pointer_test(\$a, \$b); ok $a == 4.0; ok $b == 8.0; ok pointer_is_null(undef); my $c = longdouble_pointer_return_test(1.5); ok $$c == 1.5; }; subtest 'array fixed' => sub { plan tests => 4; my $list = [ qw( 25.0 25.0 50.0 )]; ok longdouble_array_test3($list, 3); note "[", join(',', map { "$_" } @$list), "]"; ok $list->[0] == 1.0; ok $list->[1] == 2.0; ok $list->[2] == 3.0; }; subtest 'array var' => sub { plan tests => 4; my $list = [ qw( 25.0 25.0 50.0 )]; ok longdouble_array_test($list, 3); note "[", join(',', map { "$_" } @$list), "]"; ok $list->[0] == 1.0; ok $list->[1] == 2.0; ok $list->[2] == 3.0; }; subtest 'array return' => sub { plan tests => 3; my $list = longdouble_array_return_test(); note "[", join(',', map { "$_" } @$list), "]"; ok $list->[0] == 1.0; ok $list->[1] == 2.0; ok $list->[2] == 3.0; }; }; time_oo.pl100644001750001750 431513065045605 17532 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; package My::UnixTime; use FFI::Platypus; use FFI::TinyCC; use FFI::TinyCC::Inline 'tcc_eval'; # store the source of the tm struct # for repeated use later my $tm_source = <new; $ffi->lib(undef); # define a record class My::UnixTime and alias it # to "tm" $ffi->type("record(My::UnixTime)" => 'tm'); # attach the C localtime function as a constructor $ffi->attach( [ localtime => '_new' ] => ['time_t*'] => 'tm' ); # the constructor needs to be wrapped in a Perl sub, # because localtime is expecting the time_t (if provided) # to come in as the first argument, not the second. # We could also acomplish something similar using # custom types. sub new { _new(\($_[1] || time)) } # for each attribute that we are interested in, create # get and set accessors. We just make accessors for # hour, minute and second, but we could make them for # all the fields if we needed. foreach my $attr (qw( hour min sec )) { my $tcc = FFI::TinyCC->new; $tcc->compile_string(qq{ $tm_source int get_$attr (struct tm *tm) { return tm->tm_$attr; } void set_$attr (struct tm *tm, int value) { tm->tm_$attr = value; } }); $ffi->attach( [ $tcc->get_symbol("get_$attr") => "get_$attr" ] => [ 'tm' ] => 'int' ); $ffi->attach( [ $tcc->get_symbol("set_$attr") => "set_$attr" ] => [ 'tm' ] => 'int' ); } package main; # now we can actually use our My::UnixTime class my $time = My::UnixTime->new; printf "time is %d:%d:%d\n", $time->get_hour, $time->get_min, $time->get_sec; integer.pl100644001750001750 31013065045605 17503 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->attach(puts => ['string'] => 'int'); $ffi->attach(atoi => ['string'] => 'int'); puts(atoi('56')); closure.pl100644001750001750 74013065045605 17531 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib('./closure.so'); $ffi->type('(int)->int' => 'closure_t'); $ffi->attach(set_closure => ['closure_t'] => 'void'); $ffi->attach(call_closure => ['int'] => 'int'); my $closure1 = $ffi->closure(sub { $_[0] * 2 }); set_closure($closure1); print call_closure(2), "\n"; # prints "4" my $closure2 = $ffi->closure(sub { $_[0] * 4 }); set_closure($closure2); print call_closure(2), "\n"; # prints "8" archive.pl100644001750001750 626613065045605 17527 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use FFI::Platypus (); use FFI::Platypus::API (); use FFI::CheckLib (); # This example uses FreeBSD's libarchive to list the contents of any # archive format that it suppors. We've also filled out a part of # the ArchiveWrite class that could be used for writing archive formats # supported by libarchive my $ffi = My::Platypus->new; $ffi->lib(FFI::CheckLib::find_lib_or_exit lib => 'archive'); $ffi->custom_type(archive => { native_type => 'opaque', perl_to_native => sub { ${$_[0]} }, native_to_perl => sub { # this works because archive_read_new ignores any arguments # and we pass in the class name which we can get here. my $class = FFI::Platypus::API::arguments_get_string(0); bless \$_[0], $class; }, }); $ffi->custom_type(archive_entry => { native_type => 'opaque', perl_to_native => sub { ${$_[0]} }, native_to_perl => sub { # works likewise for archive_entry objects my $class = FFI::Platypus::API::arguments_get_string(0); bless \$_[0], $class, }, }); package My::Platypus; use base qw( FFI::Platypus ); sub find_symbol { my($self, $name) = @_; my $prefix = lcfirst caller(2); $prefix =~ s{([A-Z])}{"_" . lc $1}eg; $self->SUPER::find_symbol(join '_', $prefix, $name); } package Archive; # base class is "abstract" having no constructor or destructor $ffi->attach( error_string => ['archive'] => 'string' ); package ArchiveRead; our @ISA = qw( Archive ); $ffi->attach( new => ['string'] => 'archive' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive'] => 'void' ); $ffi->attach( support_filter_all => ['archive'] => 'int' ); $ffi->attach( support_format_all => ['archive'] => 'int' ); $ffi->attach( open_filename => ['archive','string','size_t'] => 'int' ); $ffi->attach( next_header2 => ['archive', 'archive_entry' ] => 'int' ); $ffi->attach( data_skip => ['archive'] => 'int' ); # ... define additional read methods package ArchiveWrite; our @ISA = qw( Archive ); $ffi->attach( new => ['string'] => 'archive' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive'] => 'void' ); # ... define additional write methods package ArchiveEntry; $ffi->attach( new => ['string'] => 'archive_entry' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive_entry'] => 'void' ); $ffi->attach( pathname => ['archive_entry'] => 'string' ); # ... define additional entry methods package main; use constant ARCHIVE_OK => 0; # this is a Perl version of the C code here: # https://github.com/libarchive/libarchive/wiki/Examples#List_contents_of_Archive_stored_in_File my $archive_filename = shift @ARGV; unless(defined $archive_filename) { print "usage: $0 archive.tar\n"; exit; } my $archive = ArchiveRead->new; $archive->support_filter_all; $archive->support_format_all; my $r = $archive->open_filename($archive_filename, 1024); die "error opening $archive_filename: ", $archive->error_string unless $r == ARCHIVE_OK; my $entry = ArchiveEntry->new; while($archive->next_header2($entry) == ARCHIVE_OK) { print $entry->pathname, "\n"; $archive->data_skip; } complex.c100644001750001750 265213065045605 17421 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/probe#include "ffi_platypus.h" float my_float_real(float complex c) { return crealf(c); } float my_float_imag(float complex c) { return cimagf(c); } double my_double_real(double complex c) { return creal(c); } double my_double_imag(double complex c) { return cimag(c); } int main(int argc, char *argv[]) { ffi_cif cif; ffi_type *args[1]; void *values[1]; args[0] = &ffi_type_complex_float; if(ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 1, &ffi_type_float, args) == FFI_OK) { float answer; float complex input; input = 1.0 + 2.0 * I; values[0] = &input; ffi_call(&cif, (void*) my_float_real, &answer, values); /* printf("answer = %g\n", answer); */ if(answer != 1.0) return 2; ffi_call(&cif, (void*) my_float_imag, &answer, values); /* printf("answer = %g\n", answer); */ if(answer != 2.0) return 2; } else { return 2; } args[0] = &ffi_type_complex_double; if(ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 1, &ffi_type_double, args) == FFI_OK) { double answer; double complex input; input = 1.0 + 2.0 * I; values[0] = &input; ffi_call(&cif, (void*) my_double_real, &answer, values); /* printf("answer = %g\n", answer); */ if(answer != 1.0) return 2; ffi_call(&cif, (void*) my_double_imag, &answer, values); /* printf("answer = %g\n", answer); */ if(answer != 2.0) return 2; } else { return 2; } return 0; } FFI000755001750001750 013065045605 14733 5ustar00ollisgollisg000000000000FFI-Platypus-0.47/libPlatypus.xs100644001750001750 374413065045605 17300 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFI#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #include "ffi_platypus.h" #include "ffi_platypus_guts.h" #ifndef HAVE_IV_IS_64 #include "perl_math_int64.h" #endif #define MY_CXT_KEY "FFI::Platypus::_guts" XS_VERSION typedef struct { ffi_pl_arguments *current_argv; /* * -1 until we have checked * 0 tried, not there * 1 tried, is there */ int have_math_longdouble; /* Math::LongDouble */ int have_math_complex; /* Math::Complex */ } my_cxt_t; START_MY_CXT void *cast0(void) { return NULL; } void *cast1(void *value) { return value; } XS(ffi_pl_sub_call) { ffi_pl_function *self; char *buffer; size_t buffer_size; int i,n, perl_arg_index; SV *arg; ffi_pl_result result; ffi_pl_arguments *arguments; void **argument_pointers; dMY_CXT; dVAR; dXSARGS; self = (ffi_pl_function*) CvXSUBANY(cv).any_ptr; #define EXTRA_ARGS 0 #include "ffi_platypus_call.h" } MODULE = FFI::Platypus PACKAGE = FFI::Platypus BOOT: { MY_CXT_INIT; MY_CXT.current_argv = NULL; MY_CXT.have_math_longdouble = -1; MY_CXT.have_math_complex = -1; #ifndef HAVE_IV_IS_64 PERL_MATH_INT64_LOAD_OR_CROAK; #endif } int _have_math_longdouble(value = -2) int value PREINIT: dMY_CXT; CODE: if(value != -2) MY_CXT.have_math_longdouble = value; RETVAL = MY_CXT.have_math_longdouble; OUTPUT: RETVAL int _have_math_complex(value = -2) int value PREINIT: dMY_CXT; CODE: if(value != -2) MY_CXT.have_math_complex = value; RETVAL = MY_CXT.have_math_complex; OUTPUT: RETVAL int _have_type(name) const char *name CODE: RETVAL = !strcmp(name, "string") || ffi_pl_name_to_type(name) != NULL; OUTPUT: RETVAL void CLONE(...) CODE: MY_CXT_CLONE; INCLUDE: ../../xs/dl.xs INCLUDE: ../../xs/Type.xs INCLUDE: ../../xs/Function.xs INCLUDE: ../../xs/Declare.xs INCLUDE: ../../xs/ClosureData.xs INCLUDE: ../../xs/API.xs INCLUDE: ../../xs/ABI.xs INCLUDE: ../../xs/Record.xs Platypus.pm100644001750001750 20200713065045605 17313 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFIpackage FFI::Platypus; use strict; use warnings; use 5.008001; use Carp qw( croak ); # ABSTRACT: Write Perl bindings to non-Perl libraries with FFI. No XS required. our $VERSION = '0.47'; # VERSION # Platypus Man, # Platypus Man, # Does Everything The Platypus Can # ... # Watch Out! # Here Comes The Platypus Man # From the original FFI::Platypus prototype: # Kinda like gluing a duckbill to an adorable mammal our @CARP_NOT = qw( FFI::Platypus::Declare ); require XSLoader; XSLoader::load( 'FFI::Platypus', eval q{ $VERSION } || do { # this is for testing without dzil # it expects MYMETA.json for FFI::Platypus # to be in the current working directory. require JSON::PP; my $fh; open($fh, '<', 'MYMETA.json') || die "unable to read MYMETA.json"; my $config = JSON::PP::decode_json(do { local $/; <$fh> }); close $fh; $config->{version}; } ); sub new { my($class, %args) = @_; my @lib; if(defined $args{lib}) { if(!ref($args{lib})) { push @lib, $args{lib}; } elsif(ref($args{lib}) eq 'ARRAY') { push @lib, @{$args{lib}}; } else { croak "lib argument must be a scalar or array reference"; } } bless { lib => \@lib, handles => {}, types => {}, lang => $args{lang} || 'C', abi => -1, ignore_not_found => defined $args{ignore_not_found} ? $args{ignore_not_found} : 0, }, $class; } sub _lang_class ($) { my($lang) = @_; my $class = $lang =~ m/^=(.*)$/ ? $1 : "FFI::Platypus::Lang::$lang"; unless($class->can('native_type_map')) { eval qq{ use $class }; croak "unable to load $class: $@" if $@; } croak "$class does not provide native_type_map method" unless $class->can("native_type_map"); $class; } sub _type_map { my($self) = @_; unless(defined $self->{type_map}) { my $class = _lang_class($self->{lang}); my %type_map; foreach my $key (keys %{ $class->native_type_map }) { my $value = $class->native_type_map->{$key}; next unless _have_type($value); $type_map{$key} = $value; } # include the standard libffi types $type_map{$_} = $_ for grep { _have_type($_) } qw( void sint8 uint8 sint16 uint16 sint32 uint32 sint64 uint64 float double string opaque longdouble complex_float complex_double ); $type_map{pointer} = 'opaque'; $self->{type_map} = \%type_map; } $self->{type_map}; } sub lib { my($self, @new) = @_; if(@new) { push @{ $self->{lib} }, @new; delete $self->{mangler}; } @{ $self->{lib} }; } sub ignore_not_found { my($self, $value) = @_; if(defined $value) { $self->{ignore_not_found} = $value; } $self->{ignore_not_found}; } sub lang { my($self, $value) = @_; if(defined $value) { $self->{lang} = $value; delete $self->{type_map}; my $class = _lang_class($self->{lang}); $self->abi($class->abi) if $class->can('abi'); } $self->{lang}; } sub type { my($self, $name, $alias) = @_; croak "usage: \$ffi->type(name => alias) (alias is optional)" unless defined $self && defined $name; croak "spaces not allowed in alias" if defined $alias && $alias =~ /\s/; croak "allowed characters for alias: [A-Za-z0-9_]+" if defined $alias && $alias =~ /[^A-Za-z0-9_]/; my $type_map = $self->_type_map; croak "alias conflicts with existing type" if defined $alias && (defined $type_map->{$alias} || defined $self->{types}->{$alias}); if($name =~ /-\>/ || $name =~ /^record\s*\([0-9A-Z:a-z_]+\)$/ || $name =~ /^string(_rw|_ro|\s+rw|\s+ro|\s*\([0-9]+\))$/) { # for closure and record types we do not try to convet into the # basic type so you can have many many many copies of a given # closure type if you do not spell it exactly the same each time. # Recommended that you use an alias for a closure type anyway. $self->{types}->{$name} ||= FFI::Platypus::Type->new($name, $self); } else { my $basic = $name; my $extra = ''; if($basic =~ s/\s*((\*|\[|\<).*)$//) { $extra = " $1"; } croak "unknown type: $basic" unless defined $type_map->{$basic}; $self->{types}->{$name} = $self->{types}->{$type_map->{$basic}.$extra} ||= FFI::Platypus::Type->new($type_map->{$basic}.$extra, $self); } if(defined $alias) { $self->{types}->{$alias} = $self->{types}->{$name}; } $self; } sub custom_type { my($self, $name, $cb) = @_; my $type = $cb->{native_type}; $type ||= 'opaque'; my $argument_count = $cb->{argument_count} || 1; croak "argument_count must be >= 1" unless $argument_count >= 1; croak "Usage: \$ffi->custom_type(\$name, { ... })" unless defined $name && ref($cb) eq 'HASH'; croak "must define at least one of native_to_perl, perl_to_native, or perl_to_native_post" unless defined $cb->{native_to_perl} || defined $cb->{perl_to_native} || defined $cb->{perl_to_native_post}; my $type_map = $self->_type_map; croak "$type is not a native type" unless defined $type_map->{$type} || $type eq 'string'; croak "name conflicts with existing type" if defined $type_map->{$name} || defined $self->{types}->{$name}; $self->{types}->{$name} = FFI::Platypus::Type->_new_custom_perl( $type_map->{$type}, $cb->{perl_to_native}, $cb->{native_to_perl}, $cb->{perl_to_native_post}, $argument_count, ); $self; } sub load_custom_type { my($self, $name, $alias, @type_args) = @_; croak "usage: \$ffi->load_custom_type(\$name, \$alias, ...)" unless defined $name && defined $alias; $name = "FFI::Platypus::Type$name" if $name =~ /^::/; $name = "FFI::Platypus::Type::$name" unless $name =~ /::/; unless($name->can("ffi_custom_type_api_1")) { eval qq{ use $name () }; warn $@ if $@; } unless($name->can("ffi_custom_type_api_1")) { croak "$name does not appear to conform to the custom type API"; } my $cb = $name->ffi_custom_type_api_1($self, @type_args); $self->custom_type($alias => $cb); $self; } sub _type_lookup { my($self, $name) = @_; $self->type($name) unless defined $self->{types}->{$name}; $self->{types}->{$name}; } sub types { my($self) = @_; $self = $self->new unless ref $self && eval { $self->isa('FFI::Platypus') }; my %types = map { $_ => 1 } keys %{ $self->_type_map }; $types{$_} ||= 1 foreach keys %{ $self->{types} }; sort keys %types; } sub type_meta { my($self, $name) = @_; $self = $self->new unless ref $self && eval { $self->isa('FFI::Platypus') }; my $type = $self->{types}->{$name} || $self->_type_lookup($name); $type->meta; } sub function { my($self, $name, $args, $ret) = @_; croak "usage \$ffi->function( name, [ arguments ], return_type)" unless @_ == 4; my @args = map { $self->_type_lookup($_) || croak "unknown type: $_" } @$args; $ret = $self->_type_lookup($ret) || croak "unknown type: $ret"; my $address = $name =~ /^-?[0-9]+$/ ? $name : $self->find_symbol($name); croak "unable to find $name" unless defined $address || $self->ignore_not_found; return unless defined $address; FFI::Platypus::Function->new($self, $address, $self->{abi}, $ret, @args); } my $inner_counter=0; sub attach { my $wrapper; $wrapper = pop if ref $_[-1] eq 'CODE'; my($self, $name, $args, $ret, $proto) = @_; $ret = 'void' unless defined $ret; my($c_name, $perl_name) = ref($name) ? @$name : ($name, $name); croak "you tried to provide a perl name that looks like an address" if $perl_name =~ /^-?[0-9]+$/; my $function = $self->function($c_name, $args, $ret); if(defined $function) { my($caller, $filename, $line) = caller; $perl_name = join '::', $caller, $perl_name unless $perl_name =~ /::/; my $attach_name = $perl_name; if($wrapper) { $attach_name = "FFI::Platypus::Inner::xsub$inner_counter"; $inner_counter++; } $function->attach($attach_name, "$filename:$line", $proto); if($wrapper) { my $inner_coderef = \&{$attach_name}; no strict 'refs'; # TODO: Sub::Name ? *{$perl_name} = sub { $wrapper->($inner_coderef, @_) }; } } $self; } sub closure { my($self, $coderef) = @_; croak "not a coderef" unless ref $coderef eq 'CODE'; FFI::Platypus::Closure->new($coderef); } sub cast { $_[0]->function(0 => [$_[1]] => $_[2])->call($_[3]); } sub attach_cast { my($self, $name, $type1, $type2) = @_; my $caller = caller; $name = join '::', $caller, $name unless $name =~ /::/; $self->attach([0 => $name] => [$type1] => $type2 => '$'); $self; } sub sizeof { my($self,$name) = @_; my $type = $self->{types}->{$name} || $self->_type_lookup($name); FFI::Platypus::Type::sizeof($type); } sub alignof { my($self, $name) = @_; my $meta = $self->type_meta($name); croak "cannot determine alignment of record" if $meta->{type} eq 'record'; my $ffi_type; if($meta->{type} eq 'pointer') { $ffi_type = 'pointer'; } elsif($meta->{type} eq 'string' && $meta->{fixed_size}) { $ffi_type = 'uint8'; } else { $ffi_type = $meta->{ffi_type}; } require FFI::Platypus::ShareConfig; FFI::Platypus::ShareConfig->get('align')->{$ffi_type}; } sub find_lib { my $self = shift; require FFI::CheckLib; $self->lib(FFI::CheckLib::find_lib(@_)); $self; } sub find_symbol { my($self, $name) = @_; unless(defined $self->{mangler}) { my $class = _lang_class($self->{lang}); if($class->can('mangler')) { $self->{mangler} = $class->mangler($self->lib); } else { $self->{mangler} = sub { $_[0] }; } } foreach my $path (@{ $self->{lib} }) { my $handle = do { no warnings; $self->{handles}->{$path||0} } || FFI::Platypus::dl::dlopen($path); unless($handle) { warn "error loading $path: ", FFI::Platypus::dl::dlerror() if $ENV{FFI_PLATYPUS_DLERROR}; next; } my $address = FFI::Platypus::dl::dlsym($handle, $self->{mangler}->($name)); if($address) { $self->{handles}->{$path||0} = $handle; return $address; } else { FFI::Platypus::dl::dlclose($handle) unless $self->{handles}->{$path||0}; } } return; } sub package { my($self, $module, $modlibname) = @_; require FFI::Platypus::ShareConfig; my @dlext = @{ FFI::Platypus::ShareConfig->get("config_dlext") }; ($module, $modlibname) = caller() unless defined $modlibname; my @modparts = split /::/, $module; my $modfname = $modparts[-1]; my $modpname = join('/',@modparts); my $c = @modparts; $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename foreach my $dlext (@dlext) { my $file = "$modlibname/auto/$modpname/$modfname.$dlext"; unless(-e $file) { $modlibname =~ s,[\\/][^\\/]+$,,; $file = "$modlibname/arch/auto/$modpname/$modfname.$dlext"; } if(-e $file) { $self->lib($file); return $self; } } $self; } sub abis { require FFI::Platypus::ShareConfig; FFI::Platypus::ShareConfig->get("abi"); } sub abi { my($self, $newabi) = @_; unless($newabi =~ /^[0-9]+$/) { unless(defined $self->abis->{$newabi}) { croak "no such ABI: $newabi"; } $newabi = $self->abis->{$newabi}; } unless(FFI::Platypus::ABI::verify($newabi)) { croak "no such ABI: $newabi"; } $self->{abi} = $newabi; $self; } sub DESTROY { my($self) = @_; foreach my $handle (values %{ $self->{handles} }) { next unless $handle; FFI::Platypus::dl::dlclose($handle); } delete $self->{handles}; } sub _have_pm { my($class) = @_; my $ok = eval qq{ use $class; 1 }; $ok = $ok ? $ok : 0; $ok; } package FFI::Platypus::Function; our $VERSION = '0.47'; # VERSION use overload '&{}' => sub { my $ffi = shift; sub { $ffi->call(@_) }; }; use overload 'bool' => sub { my $ffi = shift; return $ffi; }; package FFI::Platypus::Closure; use Scalar::Util qw( refaddr); use Carp qw( croak ); use overload '&{}' => sub { my $self = shift; sub { $self->{code}->(@_) }; }; our $VERSION = '0.47'; # VERSION sub new { my($class, $coderef) = @_; croak "not a coderef" unless ref($coderef) eq 'CODE'; my $self = bless { code => $coderef, cbdata => {} }, $class; $self; } sub add_data { my($self, $payload, $type) = @_; $self->{cbdata}{$type} = bless \$payload, 'FFI::Platypus::ClosureData'; } sub get_data { my($self, $type) = @_; if (exists $self->{cbdata}{$type}) { return ${$self->{cbdata}{$type}}; } return 0; } package FFI::Platypus::ClosureData; our $VERSION = '0.47'; # VERSION package FFI::Platypus::Type; use Carp qw( croak ); our $VERSION = '0.47'; # VERSION sub new { my($class, $type, $platypus) = @_; # the platypus object is only needed for closures, so # that it can lookup existing types. if($type =~ m/^\((.*)\)\s*-\>\s*(.*)\s*$/) { croak "passing closure into a closure not supported" if $1 =~ /(\(|\)|-\>)/; my @argument_types = map { $platypus->_type_lookup($_) } map { s/^\s+//; s/\s+$//; $_ } split /,/, $1; my $return_type = $platypus->_type_lookup($2); return $class->_new_closure($return_type, @argument_types); } my $ffi_type; my $platypus_type; my $size = 0; my $classname; my $rw = 0; if($type =~ /^string(_rw|_ro|\s+ro|\s+rw|\s*\([0-9]+\)|)$/) { my $extra = $1; $ffi_type = 'pointer'; $platypus_type = 'string'; $rw = 1 if $extra =~ /rw$/; $size = $1 if $extra =~ /\(([0-9]+)\)$/; } elsif($type =~ /^record\s*\(([0-9:A-Za-z_]+)\)$/) { $ffi_type = 'pointer'; $platypus_type = 'record'; if($1 =~ /^([0-9]+)$/) { $size = $1; } else { $classname = $1; unless($classname->can('ffi_record_size') || $classname->can('_ffi_record_size')) { eval qq{ use $classname }; warn "error requiring $classname: $@" if $@; } if($classname->can('ffi_record_size')) { $size = $classname->ffi_record_size; } elsif($classname->can('_ffi_record_size')) { $size = $classname->_ffi_record_size; } else { croak "$classname has not ffi_record_size or _ffi_record_size method"; } } } elsif($type =~ s/\s+\*$//) { $ffi_type = $type; $platypus_type = 'pointer'; } elsif($type =~ s/\s+\[([0-9]*)\]$//) { $ffi_type = $type; $platypus_type = 'array'; $size = $1 ? $1 : 0; } else { $ffi_type = $type; $platypus_type = 'ffi'; } $class->_new($ffi_type, $platypus_type, $size, $classname, $rw); } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus - Write Perl bindings to non-Perl libraries with FFI. No XS required. =head1 VERSION version 0.47 =head1 SYNOPSIS use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib(undef); # search libc # call dynamically $ffi->function( puts => ['string'] => 'int' )->call("hello world"); # attach as a xsub and call (much faster) $ffi->attach( puts => ['string'] => 'int' ); puts("hello world"); =head1 DESCRIPTION Platypus is a library for creating interfaces to machine code libraries written in languages like C, L, L, L, L. Essentially anything that gets compiled into machine code. This implementation uses C to accomplish this task. C is battle tested by a number of other scripting and virtual machine languages, such as Python and Ruby to serve a similar role. There are a number of reasons why you might want to write an extension with Platypus instead of XS: =over 4 =item FFI / Platypus does not require messing with the guts of Perl XS is less of an API and more of the guts of perl splayed out to do whatever you want. That may at times be very powerful, but it can also be a frustrating exercise in hair pulling. =item FFI / Platypus is portable Lots of languages have FFI interfaces, and it is subjectively easier to port an extension written in FFI in Perl or another language to FFI in another language or Perl. One goal of the Platypus Project is to reduce common interface specifications to a common format like JSON that could be shared between different languages. =item FFI / Platypus could be a bridge to Perl 6 One of those "other" languages could be Perl 6 and Perl 6 already has an FFI interface I am told. =item FFI / Platypus can be reimplemented In a bright future with multiple implementations of Perl 5, each interpreter will have its own implementation of Platypus, allowing extensions to be written once and used on multiple platforms, in much the same way that Ruby-FFI extensions can be use in Ruby, JRuby and Rubinius. =item FFI / Platypus is pure perl (sorta) One Platypus script or module works on any platform where the libraries it uses are available. That means you can deploy your Platypus script in a shared filesystem where they may be run on different platforms. It also means that Platypus modules do not need to be installed in the platform specific Perl library path. =item FFI / Platypus is not C or C++ centric XS is implemented primarily as a bunch of C macros, which requires at least some understanding of C, the C pre-processor, and some C++ caveats (since on some platforms Perl is compiled and linked with a C++ compiler). Platypus on the other hand could be used to call other compiled languages, like L, L, L, L, or even L, allowing you to focus on your strengths. =item FFI / Platypus does not require a parser L isolates the extension developer from XS to some extent, but it also requires a parser. The various L language bindings are a great technical achievement, but I think writing a parser for every language that you want to interface with is a bit of an anti-pattern. =back This document consists of an API reference, a set of examples, some support and development (for contributors) information. If you are new to Platypus or FFI, you may want to skip down to the L to get a taste of what you can do with Platypus. Platypus has extensive documentation of types at L and its custom types API at L. =for stopwords ØMQ =head1 CONSTRUCTORS =head2 new my $ffi = FFI::Platypus->new(%options); Create a new instance of L. Any types defined with this instance will be valid for this instance only, so you do not need to worry about stepping on the toes of other CPAN FFI / Platypus Authors. Any functions found will be out of the list of libraries specified with the L attribute. =head3 options =over 4 =item lib Either a pathname (string) or a list of pathnames (array ref of strings) to pre-populate the L attribute. =item ignore_not_found [version 0.15] Set the L attribute. =item lang [version 0.18] Set the L attribute. =back =head1 ATTRIBUTES =head2 lib $ffi->lib($path1, $path2, ...); my @paths = $ffi->lib; The list of libraries to search for symbols in. The most portable and reliable way to find dynamic libraries is by using L, like this: use FFI::CheckLib 0.06; $ffi->lib(find_lib_or_die lib => 'archive'); # finds libarchive.so on Linux # libarchive.bundle on OS X # libarchive.dll (or archive.dll) on Windows # cygarchive-13.dll on Cygwin # ... # and will die if it isn't found L has a number of options, such as checking for specific symbols, etc. You should consult the documentation for that module. As a special case, if you add C as a "library" to be searched, Platypus will also search the current process for symbols. This is mostly useful for finding functions in the standard C library, without having to know the name of the standard c library for your platform (as it turns out it is different just about everywhere!). You may also use the L method as a shortcut: $ffi->find_lib( lib => 'archive' ); =head2 ignore_not_found [version 0.15] $ffi->ignore_not_found(1); my $ignore_not_found = $ffi->ignore_not_found; Normally the L and L methods will throw an exception if it cannot find the name of the function you provide it. This will change the behavior such that L will return C when the function is not found and L will ignore functions that are not found. This is useful when you are writing bindings to a library and have many optional functions and you do not wish to wrap every call to L or L in an C. =head2 lang [version 0.18] $ffi->lang($language); Specifies the foreign language that you will be interfacing with. The default is C. The foreign language specified with this attribute changes the default native types (for example, if you specify L, you will get C as an alias for C instead of C as you do with L). If the foreign language plugin supports it, this will also enable Platypus to find symbols using the demangled names (for example, if you specify L for C++ you can use method names like C with L or L. =head1 METHODS =head2 type $ffi->type($typename); $ffi->type($typename => $alias); Define a type. The first argument is the native or C name of the type. The second argument (optional) is an alias name that you can use to refer to this new type. See L for legal type definitions. Examples: $ffi->type('sint32'); # oly checks to see that sint32 is a valid type $ffi->type('sint32' => 'myint'); # creates an alias myint for sint32 $ffi->type('bogus'); # dies with appropriate diagnostic =head2 custom_type $ffi->custom_type($alias => { native_type => $native_type, native_to_perl => $coderef, perl_to_native => $coderef, perl_to_native_post => $coderef, }); Define a custom type. See L for details. =head2 load_custom_type $ffi->load_custom_type($name => $alias, @type_args); Load the custom type defined in the module I<$name>, and make an alias I<$alias>. If the custom type requires any arguments, they may be passed in as I<@type_args>. See L for details. If I<$name> contains C<::> then it will be assumed to be a fully qualified package name. If not, then C will be prepended to it. =head2 types my @types = $ffi->types; my @types = FFI::Platypus->types; Returns the list of types that FFI knows about. This will include the native C types (example: C, C and C) and the normal C types (example: C, C), any types that you have defined using the L method, and custom types. The list of types that Platypus knows about varies somewhat from platform to platform, L includes a list of the core types that you can always count on having access to. It can also be called as a class method, in which case, no user defined or custom types will be included in the list. =head2 type_meta my $meta = $ffi->type_meta($type_name); my $meta = FFI::Platypus->type_meta($type_name); Returns a hash reference with the meta information for the given type. It can also be called as a class method, in which case, you won't be able to get meta data on user defined types. The format of the meta data is implementation dependent and subject to change. It may be useful for display or debugging. Examples: my $meta = $ffi->type_meta('int'); # standard int type my $meta = $ffi->type_meta('int[64]'); # array of 64 ints $ffi->type('int[128]' => 'myintarray'); my $meta = $ffi->type_meta('myintarray'); # array of 128 ints =head2 function my $function = $ffi->function($name => \@argument_types => $return_type); my $function = $ffi->function($address => \@argument_types => $return_type); Returns an object that is similar to a code reference in that it can be called like one. Caveat: many situations require a real code reference, so at the price of a performance penalty you can get one like this: my $function = $ffi->function(...); my $coderef = sub { $function->(@_) }; It may be better, and faster to create a real Perl function using the L method. In addition to looking up a function by name you can provide the address of the symbol yourself: my $address = $ffi->find_symbol('my_functon'); my $function = $ffi->function($address => ...); Under the covers, L uses L when you provide it with a name, but it is useful to keep this in mind as there are alternative ways of obtaining a functions address. Example: a C function could return the address of another C function that you might want to call, or modules such as L produce machine code at runtime that you can call from Platypus. Examples: my $function = $ffi->function('my_function_name', ['int', 'string'] => 'string'); my $return_string = $function->(1, "hi there"); =head2 attach $ffi->attach($name => \@argument_types => $return_type); $ffi->attach([$c_name => $perl_name] => \@argument_types => $return_type); $ffi->attach([$address => $perl_name] => \@argument_types => $return_type); $ffi->attach($name => \@argument_types => $return_type, sub { ... }); $ffi->attach([$c_name => $perl_name] => \@argument_types => $return_type, sub { ... }); $ffi->attach([$address => $perl_name] => \@argument_types => $return_type, sub { ... }); Find and attach a C function as a real live Perl xsub. The advantage of attaching a function over using the L method is that it is much much much faster since no object resolution needs to be done. The disadvantage is that it locks the function and the L instance into memory permanently, since there is no way to deallocate an xsub. If just one I<$name> is given, then the function will be attached in Perl with the same name as it has in C. The second form allows you to give the Perl function a different name. You can also provide an address (the third form), just like with the L method. Examples: $ffi->attach('my_functon_name', ['int', 'string'] => 'string'); $ffi->attach(['my_c_functon_name' => 'my_perl_function_name'], ['int', 'string'] => 'string'); my $string1 = my_function_name($int); my $string2 = my_perl_function_name($int); [version 0.20] If the last argument is a code reference, then it will be used as a wrapper around the attached xsub. The first argument to the wrapper will be the inner xsub. This can be used if you need to verify/modify input/output data. Examples: $ffi->attach('my_function', ['int', 'string'] => 'string', sub { my($my_function_xsub, $integer, $string) = @_; $integer++; $string .= " and another thing"; my $return_string = $my_function_xsub->($integer, $string); $return_string =~ s/Belgium//; # HHGG remove profanity $return_string; }); =head2 closure my $closure = $ffi->closure($coderef); Prepares a code reference so that it can be used as a FFI closure (a Perl subroutine that can be called from C code). For details on closures, see L. =head2 cast my $converted_value = $ffi->cast($original_type, $converted_type, $original_value); The C function converts an existing I<$original_value> of type I<$original_type> into one of type I<$converted_type>. Not all types are supported, so care must be taken. For example, to get the address of a string, you can do this: my $address = $ffi->cast('string' => 'opaque', $string_value); Something that won't work is trying to cast an array to anything: my $address = $ffi->cast('int[10]' => 'opaque', \@list); # WRONG =head2 attach_cast $ffi->attach_cast("cast_name", $original_type, $converted_type); my $converted_value = cast_name($original_value); This function attaches a cast as a permanent xsub. This will make it faster and may be useful if you are calling a particular cast a lot. =head2 sizeof my $size = $ffi->sizeof($type); Returns the total size of the given type in bytes. For example to get the size of an integer: my $intsize = $ffi->sizeof('int'); # usually 4 my $longsize = $ffi->sizeof('long'); # usually 4 or 8 depending on platform You can also get the size of arrays my $intarraysize = $ffi->sizeof('int[64]'); # usually 4*64 my $intarraysize = $ffi->sizeof('long[64]'); # usually 4*64 or 8*64 # depending on platform Keep in mind that "pointer" types will always be the pointer / word size for the platform that you are using. This includes strings, opaque and pointers to other types. This function is not very fast, so you might want to save this value as a constant, particularly if you need the size in a loop with many iterations. =head2 alignof [version 0.21] my $align = $ffi->alignof($type); Returns the alignment of the given type in bytes. =head2 find_lib [version 0.20] $ffi->find_lib( lib => $libname ); This is just a shortcut for calling L and updating the L attribute appropriately. Care should be taken though, as this method simply passes its arguments to L, so if your module or script is depending on a specific feature in L then make sure that you update your prerequisites appropriately. =head2 find_symbol my $address = $ffi->find_symbol($name); Return the address of the given symbol (usually function). =head2 package [version 0.15] $ffi->package($package, $file); # usually __PACKAGE__ and __FILE__ can be used $ffi->package; # autodetect If you have used L to bundle C code with your distribution, you can use this method to tell the L instance to look for symbols that came with the dynamic library that was built when your distribution was installed. =head2 abis my $href = $ffi->abis; my $href = FFI::Platypus->abis; Get the legal ABIs supported by your platform and underlying implementation. What is supported can vary a lot by CPU and by platform, or even between 32 and 64 bit on the same CPU and platform. They keys are the "ABI" names, also known as "calling conventions". The values are integers used internally by the implementation to represent those ABIs. =head2 abi $ffi->abi($name); Set the ABI or calling convention for use in subsequent calls to L or L. May be either a string name or integer value from the L method above. =head1 EXAMPLES Here are some examples. These examples are provided in full with the Platypus distribution in the "examples" directory. There are also some more examples in L that are related to types. =head2 Integer conversions use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->attach(puts => ['string'] => 'int'); $ffi->attach(atoi => ['string'] => 'int'); puts(atoi('56')); B: C and C should be part of the standard C library on all platforms. C prints a string to standard output, and C converts a string to integer. Specifying C as a library tells Platypus to search the current process for symbols, which includes the standard c library. =head2 libnotify use FFI::CheckLib; use FFI::Platypus; # NOTE: I ported this from the like named eg/notify.pl that came with FFI::Raw # and it seems to work most of the time, but also seems to SIGSEGV sometimes. # I saw the same behavior in the FFI::Raw version, and am not really familiar # with the libnotify API to say what is the cause. Patches welcome to fix it. my $ffi = FFI::Platypus->new; $ffi->lib(find_lib_or_exit lib => 'notify'); $ffi->attach(notify_init => ['string'] => 'void'); $ffi->attach(notify_uninit => [] => 'void'); $ffi->attach([notify_notification_new => 'notify_new'] => ['string', 'string', 'string'] => 'opaque'); $ffi->attach([notify_notification_update => 'notify_update'] => ['opaque', 'string', 'string', 'string'] => 'void'); $ffi->attach([notify_notification_show => 'notify_show'] => ['opaque', 'opaque'] => 'void'); notify_init('FFI::Platypus'); my $n = notify_new('','',''); notify_update($n, 'FFI::Platypus', 'It works!!!', 'media-playback-start'); notify_show($n, undef); notify_uninit(); B: libnotify is a desktop GUI notification library for the GNOME Desktop environment. This script sends a notification event that should show up as a balloon, for me it did so in the upper right hand corner of my screen. The most portable way to find the correct name and location of a dynamic library is via the L family of functions. If you are putting together a CPAN distribution, you should also consider using L function in your C or C file (If you are using L, check out the L plugin). This will provide a user friendly diagnostic letting the user know that the required library is missing, and reduce the number of bogus CPAN testers results that you will get. Also in this example, we rename some of the functions when they are placed into Perl space to save typing: attach [notify_notification_new => 'notify_new'] => [string,string,string] => opaque; When you specify a list reference as the "name" of the function the first element is the symbol name as understood by the dynamic library. The second element is the name as it will be placed in Perl space. Later, when we call C: my $n = notify_new('','',''); We are really calling the C function C. =head2 Allocating and freeing memory use FFI::Platypus; use FFI::Platypus::Memory qw( malloc free memcpy ); my $ffi = FFI::Platypus->new; my $buffer = malloc 12; memcpy $buffer, $ffi->cast('string' => 'opaque', "hello there"), length "hello there\0"; print $ffi->cast('opaque' => 'string', $buffer), "\n"; free $buffer; B: C and C are standard memory allocation functions available from the standard c library and. Interfaces to these and other memory related functions are provided by the L module. =head2 structured data records package My::UnixTime; use FFI::Platypus::Record; record_layout(qw( int tm_sec int tm_min int tm_hour int tm_mday int tm_mon int tm_year int tm_wday int tm_yday int tm_isdst long tm_gmtoff string tm_zone )); my $ffi = FFI::Platypus->new; $ffi->lib(undef); # define a record class My::UnixTime and alias it to "tm" $ffi->type("record(My::UnixTime)" => 'tm'); # attach the C localtime function as a constructor $ffi->attach( localtime => ['time_t*'] => 'tm', sub { my($inner, $class, $time) = @_; $time = time unless defined $time; $inner->(\$time); }); package main; # now we can actually use our My::UnixTime class my $time = My::UnixTime->localtime; printf "time is %d:%d:%d %s\n", $time->tm_hour, $time->tm_min, $time->tm_sec, $time->tm_zone; B: C and other machine code languages frequently provide interfaces that include structured data records (known as "structs" in C). They sometimes provide an API in which you are expected to manipulate these records before and/or after passing them along to C functions. There are a few ways of dealing with such interfaces, but the easiest way is demonstrated here defines a record class using a specific layout. For more details see L. (L includes some other ways of manipulating structured data records). =head2 libuuid use FFI::CheckLib; use FFI::Platypus; use FFI::Platypus::Memory qw( malloc free ); my $ffi = FFI::Platypus->new; $ffi->lib(find_lib_or_exit lib => 'uuid'); $ffi->type('string(37)' => 'uuid_string'); $ffi->type('record(16)' => 'uuid_t'); $ffi->attach(uuid_generate => ['uuid_t'] => 'void'); $ffi->attach(uuid_unparse => ['uuid_t','uuid_string'] => 'void'); my $uuid = "\0" x 16; # uuid_t uuid_generate($uuid); my $string = "\0" x 37; # 36 bytes to store a UUID string # + NUL termination uuid_unparse($uuid, $string); print "$string\n"; B: libuuid is a library used to generate unique identifiers (UUID) for objects that may be accessible beyond the local system. The library is or was part of the Linux e2fsprogs package. Knowing the size of objects is sometimes important. In this example, we use the L function to get the size of 16 characters (in this case it is simply 16 bytes). We also know that the strings "deparsed" by C are exactly 37 bytes. =head2 puts and getpid use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->attach(puts => ['string'] => 'int'); $ffi->attach(getpid => [] => 'int'); puts(getpid()); B: C is part of standard C library on all platforms. C is available on Unix type platforms. =head2 Math library use FFI::Platypus; use FFI::CheckLib; my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->attach(puts => ['string'] => 'int'); $ffi->attach(fdim => ['double','double'] => 'double'); puts(fdim(7.0, 2.0)); $ffi->attach(cos => ['double'] => 'double'); puts(cos(2.0)); $ffi->attach(fmax => ['double', 'double'] => 'double'); puts(fmax(2.0,3.0)); B: On UNIX the standard c library math functions are frequently provided in a separate library C, so you could search for those symbols in "libm.so", but that won't work on non-UNIX platforms like Microsoft Windows. Fortunately Perl uses the math library so these symbols are already in the current process so you can use C as the library to find them. =head2 Strings use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->attach(puts => ['string'] => 'int'); $ffi->attach(strlen => ['string'] => 'int'); puts(strlen('somestring')); $ffi->attach(strstr => ['string','string'] => 'string'); puts(strstr('somestring', 'string')); #attach puts => [string] => int; puts(puts("lol")); $ffi->attach(strerror => ['int'] => 'string'); puts(strerror(2)); B: Strings are not a native type to C but the are handled seamlessly by Platypus. =head2 Attach function from pointer use FFI::TinyCC; use FFI::Platypus; my $ffi = FFI::Platypus->new; my $tcc = FFI::TinyCC->new; $tcc->compile_string(q{ int add(int a, int b) { return a+b; } }); my $address = $tcc->get_symbol('add'); $ffi->attach( [ $address => 'add' ] => ['int','int'] => 'int' ); print add(1,2), "\n"; B: Sometimes you will have a pointer to a function from a source other than Platypus that you want to call. You can use that address instead of a function name for either of the L or L methods. In this example we use L to compile a short piece of C code and to give us the address of one of its functions, which we then use to create a perl xsub to call it. L embeds the Tiny C Compiler (tcc) to provide a just-in-time (JIT) compilation service for FFI. =head2 libzmq use constant ZMQ_IO_THREADS => 1; use constant ZMQ_MAX_SOCKETS => 2; use constant ZMQ_REQ => 3; use constant ZMQ_REP => 4; use FFI::CheckLib qw( find_lib_or_exit ); use FFI::Platypus; use FFI::Platypus::Memory qw( malloc ); use FFI::Platypus::Buffer qw( scalar_to_buffer buffer_to_scalar ); my $endpoint = "ipc://zmq-ffi-$$"; my $ffi = FFI::Platypus->new; $ffi->lib(undef); # for puts $ffi->attach(puts => ['string'] => 'int'); $ffi->lib(find_lib_or_exit lib => 'zmq'); $ffi->attach(zmq_version => ['int*', 'int*', 'int*'] => 'void'); my($major,$minor,$patch); zmq_version(\$major, \$minor, \$patch); puts("libzmq version $major.$minor.$patch"); die "this script only works with libzmq 3 or better" unless $major >= 3; $ffi->type('opaque' => 'zmq_context'); $ffi->type('opaque' => 'zmq_socket'); $ffi->type('opaque' => 'zmq_msg_t'); $ffi->attach(zmq_ctx_new => [] => 'zmq_context'); $ffi->attach(zmq_ctx_set => ['zmq_context', 'int', 'int'] => 'int'); $ffi->attach(zmq_socket => ['zmq_context', 'int'] => 'zmq_socket'); $ffi->attach(zmq_connect => ['opaque', 'string'] => 'int'); $ffi->attach(zmq_bind => ['zmq_socket', 'string'] => 'int'); $ffi->attach(zmq_send => ['zmq_socket', 'opaque', 'size_t', 'int'] => 'int'); $ffi->attach(zmq_msg_init => ['zmq_msg_t'] => 'int'); $ffi->attach(zmq_msg_recv => ['zmq_msg_t', 'zmq_socket', 'int'] => 'int'); $ffi->attach(zmq_msg_data => ['zmq_msg_t'] => 'opaque'); $ffi->attach(zmq_errno => [] => 'int'); $ffi->attach(zmq_strerror => ['int'] => 'string'); my $context = zmq_ctx_new(); zmq_ctx_set($context, ZMQ_IO_THREADS, 1); my $socket1 = zmq_socket($context, ZMQ_REQ); zmq_connect($socket1, $endpoint); my $socket2 = zmq_socket($context, ZMQ_REP); zmq_bind($socket2, $endpoint); do { # send our $sent_message = "hello there"; my($pointer, $size) = scalar_to_buffer $sent_message; my $r = zmq_send($socket1, $pointer, $size, 0); die zmq_strerror(zmq_errno()) if $r == -1; }; do { # recv my $msg_ptr = malloc 100; zmq_msg_init($msg_ptr); my $size = zmq_msg_recv($msg_ptr, $socket2, 0); die zmq_strerror(zmq_errno()) if $size == -1; my $data_ptr = zmq_msg_data($msg_ptr); my $recv_message = buffer_to_scalar $data_ptr, $size; print "recv_message = $recv_message\n"; }; B: ØMQ is a high-performance asynchronous messaging library. There are a few things to note here. Firstly, sometimes there may be multiple versions of a library in the wild and you may need to verify that the library on a system meets your needs (alternatively you could support multiple versions and configure your bindings dynamically). Here we use C to ask libzmq which version it is. C returns the version number via three integer pointer arguments, so we use the pointer to integer type: C. In order to pass pointer types, we pass a reference. In this case it is a reference to an undefined value, because zmq_version will write into the pointers the output values, but you can also pass in references to integers, floating point values and opaque pointer types. When the function returns the C<$major> variable (and the others) has been updated and we can use it to verify that it supports the API that we require. Notice that we define three aliases for the C type: C, C and C. While this isn't strictly necessary, since Platypus and C treat all three of these types the same, it is useful form of documentation that helps describe the functionality of the interface. Finally we attach the necessary functions, send and receive a message. If you are interested, there is a fully fleshed out ØMQ Perl interface implemented using FFI called L. =head2 libarchive use FFI::Platypus (); use FFI::Platypus::API (); use FFI::CheckLib (); # This example uses FreeBSD's libarchive to list the contents of any # archive format that it suppors. We've also filled out a part of # the ArchiveWrite class that could be used for writing archive formats # supported by libarchive my $ffi = My::Platypus->new; $ffi->lib(FFI::CheckLib::find_lib_or_exit lib => 'archive'); $ffi->custom_type(archive => { native_type => 'opaque', perl_to_native => sub { ${$_[0]} }, native_to_perl => sub { # this works because archive_read_new ignores any arguments # and we pass in the class name which we can get here. my $class = FFI::Platypus::API::arguments_get_string(0); bless \$_[0], $class; }, }); $ffi->custom_type(archive_entry => { native_type => 'opaque', perl_to_native => sub { ${$_[0]} }, native_to_perl => sub { # works likewise for archive_entry objects my $class = FFI::Platypus::API::arguments_get_string(0); bless \$_[0], $class, }, }); package My::Platypus; use base qw( FFI::Platypus ); sub find_symbol { my($self, $name) = @_; my $prefix = lcfirst caller(2); $prefix =~ s{([A-Z])}{"_" . lc $1}eg; $self->SUPER::find_symbol(join '_', $prefix, $name); } package Archive; # base class is "abstract" having no constructor or destructor $ffi->attach( error_string => ['archive'] => 'string' ); package ArchiveRead; our @ISA = qw( Archive ); $ffi->attach( new => ['string'] => 'archive' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive'] => 'void' ); $ffi->attach( support_filter_all => ['archive'] => 'int' ); $ffi->attach( support_format_all => ['archive'] => 'int' ); $ffi->attach( open_filename => ['archive','string','size_t'] => 'int' ); $ffi->attach( next_header2 => ['archive', 'archive_entry' ] => 'int' ); $ffi->attach( data_skip => ['archive'] => 'int' ); # ... define additional read methods package ArchiveWrite; our @ISA = qw( Archive ); $ffi->attach( new => ['string'] => 'archive' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive'] => 'void' ); # ... define additional write methods package ArchiveEntry; $ffi->attach( new => ['string'] => 'archive_entry' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive_entry'] => 'void' ); $ffi->attach( pathname => ['archive_entry'] => 'string' ); # ... define additional entry methods package main; use constant ARCHIVE_OK => 0; # this is a Perl version of the C code here: # https://github.com/libarchive/libarchive/wiki/Examples#List_contents_of_Archive_stored_in_File my $archive_filename = shift @ARGV; unless(defined $archive_filename) { print "usage: $0 archive.tar\n"; exit; } my $archive = ArchiveRead->new; $archive->support_filter_all; $archive->support_format_all; my $r = $archive->open_filename($archive_filename, 1024); die "error opening $archive_filename: ", $archive->error_string unless $r == ARCHIVE_OK; my $entry = ArchiveEntry->new; while($archive->next_header2($entry) == ARCHIVE_OK) { print $entry->pathname, "\n"; $archive->data_skip; } B: libarchive is the implementation of C for FreeBSD provided as a library and available on a number of platforms. One interesting thing about libarchive is that it provides a kind of object oriented interface via opaque pointers. This example creates an abstract class C, and concrete classes C, C and C. The concrete classes can even be inherited from and extended just like any Perl classes because of the way the custom types are implemented. For more details on custom types see L and L. Another advanced feature of this example is that we extend the L class to define our own find_symbol method that prefixes the symbol names depending on the class in which they are defined. This means we can do this when we define a method for Archive: $ffi->attach( support_filter_all => ['archive'] => 'int' ); Rather than this: $ffi->attach( [ archive_read_support_filter_all => 'support_read_filter_all' ] => ['archive'] => 'int' ); ); If you didn't want to create an entire new class just for this little trick you could also use something like L to extend C. =head2 bzip2 use FFI::Platypus 0.20 (); # 0.20 required for using wrappers use FFI::CheckLib qw( find_lib_or_die ); use FFI::Platypus::Buffer qw( scalar_to_buffer buffer_to_scalar ); use FFI::Platypus::Memory qw( malloc free ); my $ffi = FFI::Platypus->new; $ffi->lib(find_lib_or_die lib => 'bz2'); $ffi->attach( [ BZ2_bzBuffToBuffCompress => 'compress' ] => [ 'opaque', # dest 'unsigned int *', # dest length 'opaque', # source 'unsigned int', # source length 'int', # blockSize100k 'int', # verbosity 'int', # workFactor ] => 'int', sub { my $sub = shift; my($source,$source_length) = scalar_to_buffer $_[0]; my $dest_length = int(length($source)*1.01) + 1 + 600; my $dest = malloc $dest_length; my $r = $sub->($dest, \$dest_length, $source, $source_length, 9, 0, 30); die "bzip2 error $r" unless $r == 0; my $compressed = buffer_to_scalar($dest, $dest_length); free $dest; $compressed; }, ); $ffi->attach( [ BZ2_bzBuffToBuffDecompress => 'decompress' ] => [ 'opaque', # dest 'unsigned int *', # dest length 'opaque', # source 'unsigned int', # source length 'int', # small 'int', # verbosity ] => 'int', sub { my $sub = shift; my($source, $source_length) = scalar_to_buffer $_[0]; my $dest_length = $_[1]; my $dest = malloc $dest_length; my $r = $sub->($dest, \$dest_length, $source, $source_length, 0, 0); die "bzip2 error $r" unless $r == 0; my $decompressed = buffer_to_scalar($dest, $dest_length); free $dest; $decompressed; }, ); my $original = "hello compression world\n"; my $compressed = compress($original); print decompress($compressed, length $original); B: bzip2 is a compression library. For simple one shot attempts at compression/decompression when you expect the original and the result to fit within memory it provides two convenience functions C and C. The first four arguments of both of these C functions are identical, and represent two buffers. One buffer is the source, the second is the destination. For the destination, the length is passed in as a pointer to an integer. On input this integer is the size of the destination buffer, and thus the maximum size of the compressed or decompressed data. When the function returns the actual size of compressed or compressed data is stored in this integer. This is normal stuff for C, but in Perl our buffers are scalars and they already know how large they are. In this sort of situation, wrapping the C function in some Perl code can make your interface a little more Perl like. In order to do this, just provide a code reference as the last argument to the L method. The first argument to this wrapper will be a code reference to the C function. The Perl arguments will come in after that. This allows you to modify / convert the arguments to conform to the C API. What ever value you return from the wrapper function will be returned back to the original caller. =head2 Java Java: // On Linux build .so with // % gcj -fPIC -shared -o libexample.so Example.java public class Example { public static void print_hello() { System.out.println("hello world"); } public static int add(int a, int b) { return a + b; } } C++: #include #include #include #include extern "C" void gcj_start() { using namespace java::lang; JvCreateJavaVM(NULL); JvInitClass(&System::class$); } extern "C" void gcj_end() { JvDetachCurrentThread(); } Perl: use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib('./libexample.so'); # Java methods are mangled by gcj using the same format as g++ $ffi->attach( [ _ZN7Example11print_helloEJvv => 'print_hello' ] => [] => 'void' ); $ffi->attach( [ _ZN7Example3addEJiii => 'add' ] => ['int', 'int'] => 'int' ); # Initialize the Java runtime $ffi->function( gcj_start => [] => 'void' )->call; print_hello(); print add(1,2), "\n"; # Wind the java runtime down $ffi->function( gcj_end => [] => 'void' )->call; Makefile: GCJ=gcj CXX=g++ CFLAGS=-fPIC LDFLAGS=-shared RM=rm -f libexample.so: between.o Example.o $(GCJ) $(LDFLAGS) -o libexample.so between.o Example.o between.o: between.cpp $(CXX) $(CFLAGS) -c -o between.o between.cpp Example.o: Example.java $(GCJ) $(CFLAGS) -c -o Example.o Example.java clean: $(RM) *.o *.so Output: % make g++ -fPIC -c -o between.o between.cpp gcj -fPIC -c -o Example.o Example.java gcj -shared -o libexample.so between.o Example.o % perl example.pl hello world 3 B: You can't call Java .class files directly from FFI / Platypus, but you can compile Java source and .class files into a shared library using the GNU Java Compiler C. Because we are calling Java functions from a program (Perl!) that was not started from a Java C we have to initialize the Java runtime ourselves (L). This can most easily be accomplished from C++. The GNU Java Compiler uses the same format to mangle method names as GNU C++. The L for handles this more transparently by extracting the symbols from the shared library and using either L or C to determined the unmangled names. Although the Java source is compiled ahead of time with optimizations, it will not necessarily perform better than a real JVM just because it is compiled. In fact the gcj developers warn than gcj will optimize Java source better than Java .class files. The GNU Java Compiler also lags behind modern Java. Even so this enables you to call Java from Perl and potentially other Java based languages such as Scala, Groovy or JRuby. =head1 CAVEATS Platypus and Native Interfaces like libffi rely on the availability of dynamic libraries. Things not supported include: =over 4 =item Systems that lack dynamic library support Like MS-DOS =item Systems that are not supported by libffi Like OpenVMS =item Languages that do not support using dynamic libraries from other languages Like Google's Go. Although I believe that XS won't help in this regard. =item Languages that do not compile to machine code Like .NET based languages and Java that can't be understood by gcj. =back The documentation has a bias toward using FFI / Platypus with C. This is my fault, as my background in mainly in C/C++ programmer (when I am not writing Perl). In many places I use "C" as a short form for "any language that can generate machine code and is callable from C". I welcome pull requests to the Platypus core to address this issue. In an attempt to ease usage of Platypus by non C programmers, I have written a number of foreign language plugins for various popular languages (see the SEE ALSO below). These plugins come with examples specific to those languages, and documentation on common issues related to using those languages with FFI. In most cases these are available for easy adoption for those with the know-how or the willingness to learn. If your language doesn't have a plugin YET, that is just because you haven't written it yet. =head1 SUPPORT IRC: #native on irc.perl.org L<(click for instant chat room login)|http://chat.mibbit.com/#native@irc.perl.org> If something does not work the way you think it should, or if you have a feature request, please open an issue on this project's GitHub Issue tracker: L =head1 CONTRIBUTING If you have implemented a new feature or fixed a bug then you may make a pull request on this project's GitHub repository: L This project is developed using L. The project's git repository also comes with C and C files necessary for building, testing (and even installing if necessary) without L. Please keep in mind though that these files are generated so if changes need to be made to those files they should be done through the project's C file. If you do use L and already have the necessary plugins installed, then I encourage you to run C before making any pull requests. This is not a requirement, however, I am happy to integrate especially smaller patches that need tweaking to fit the project standards. I may push back and ask you to write a test case or alter the formatting of a patch depending on the amount of time I have and the amount of code that your patch touches. This project's GitHub issue tracker listed above is not Write-Only. If you want to contribute then feel free to browse through the existing issues and see if there is something you feel you might be good at and take a whack at the problem. I frequently open issues myself that I hope will be accomplished by someone in the future but do not have time to immediately implement myself. Another good area to help out in is documentation. I try to make sure that there is good document coverage, that is there should be documentation describing all the public features and warnings about common pitfalls, but an outsider's or alternate view point on such things would be welcome; if you see something confusing or lacks sufficient detail I encourage documentation only pull requests to improve things. The Platypus distribution comes with a test library named C that is normally automatically built by C<./Build test>. If you prefer to use C or run tests directly, you can use the C<./Build libtest> command to build it. Example: % perl Build.PL % ./Build % ./Build libtest % prove -bv t # or an individual test % perl -Mblib t/ffi_platypus_memory.t The build process also respects these environment variables: =over 4 =item FFI_PLATYPUS_DEBUG Build the XS code portion of Platypus with -g3 instead of what ever optimizing flags that your Perl normally uses. This is useful if you need to debug the C or XS code that comes with Platypus, but do not have a debugging Perl. % env FFI_PLATYPUS_DEBUG=1 perl Build.PL DEBUG: - $Config{lddlflags} = -shared -O2 -L/usr/local/lib -fstack-protector + $Config{lddlflags} = -shared -g3 -L/usr/local/lib -fstack-protector - $Config{optimize} = -O2 + $Config{optimize} = -g3 Created MYMETA.yml and MYMETA.json Creating new 'Build' script for 'FFI-Platypus' version '0.10' =item FFI_PLATYPUS_DEBUG_FAKE32 When building Platypus on 32 bit Perls, it will use the L C API and make L a prerequisite. Setting this environment variable will force Platypus to build with both of those options on a 64 bit Perl as well. % env FFI_PLATYPUS_DEBUG_FAKE32=1 perl Build.PL DEBUG_FAKE32: + making Math::Int64 a prerequisite (not normally done on 64 bit Perls) + using Math::Int64's C API to manipulate 64 bit values (not normally done on 64 bit Perls) Created MYMETA.yml and MYMETA.json Creating new 'Build' script for 'FFI-Platypus' version '0.10' =item FFI_PLATYPUS_NO_ALLOCA Platypus uses the non-standard and somewhat controversial C function C by default on platforms that support it. I believe that Platypus uses it responsibly to allocate small amounts of memory for argument type parameters, and does not use it to allocate large structures like arrays or buffers. If you prefer not to use C despite these precautions, then you can turn its use off by setting this environment variable when you run C: % env FFI_PLATYPUS_NO_ALLOCA=1 perl Build.PL NO_ALLOCA: + alloca() will not be used, even if your platform supports it. Created MYMETA.yml and MYMETA.json Creating new 'Build' script for 'FFI-Platypus' version '0.10' =back =head2 Coding Guidelines =over 4 =item Do not hesitate to make code contribution. Making useful contributions is more important than following byzantine bureaucratic coding regulations. We can always tweak things later. =item Please make an effort to follow existing coding style when making pull requests. =item Platypus supports all production Perl releases since 5.8.1. For that reason, please do not introduce any code that requires a newer version of Perl. =back =head2 Performance Testing As Mark Twain was fond of saying there are four types of lies: lies, damn lies, statistics and benchmarks. That being said, it can sometimes be helpful to compare the runtime performance of Platypus if you are making significant changes to the Platypus Core. For that I use `FFI-Performance`, which can be found in my GitHub repository here: =over 4 =item L =back =head2 System integrators If you are including Platypus in a larger system (for example a Linux distribution), and you already have libffi as part of your system, you may be interested in L. This is an alternative to L that does not require L. In fact it has zero non-Core dependencies, and doesn't even need to be installed. Simply include L's C directory in your C path when you build Platypus. For example: % export PERL5LIB=/path/to/Alt-Alien-FFI-System/lib % cpanm FFI::Platypus =head1 SEE ALSO =over 4 =item L Promising interface to Platypus inspired by Perl 6. =item L Type definitions for Platypus. =item L Define structured data records (C "structs") for use with Platypus. =item L The custom types API for Platypus. =item L Memory functions for FFI. =item L Find dynamic libraries in a portable way. =item L Bundle C code with your FFI extension. =item L JIT compiler for FFI. =item L Documentation and tools for using Platypus with the C programming language =item L Documentation and tools for using Platypus with the C++ programming language =item L Documentation and tools for using Platypus with Fortran =item L Documentation and tools for using Platypus with Free Pascal =item L Documentation and tools for using Platypus with the Rust programming language =item L Documentation and tools for using Platypus with the Assembly =item L A great interface for decoding C data structures, including Cs, Cs, C<#define>s and more. =item L Native to Perl functions that can be used to decode C C types. =item L This module can extract constants and other useful objects from C header files that may be relevant to an FFI application. One downside is that its use may require development packages to be installed. =item L Alternate interface to libffi with fewer features. It notably lacks the ability to create real xsubs, which may make L much faster. Also lacking are pointers to native types, arrays and custom types. In its favor, it has been around for longer that Platypus, and has been battle tested to some success. =item L Microsoft Windows specific FFI style interface. =item L Ctypes was intended as a FFI style interface for Perl, but was never part of CPAN, and at least the last time I tried it did not work with recent versions of Perl. =item L Foreign function interface based on (nomenclature is everything) FSF's C. It hasn't worked for quite some time, and C is no longer supported or distributed. =item L Another FFI for Perl that doesn't appear to have worked for a long time. =item L Embed a tiny C compiler into your Perl scripts. =item L Provides libffi for Platypus during its configuration and build stages. =item L An alternative for L intended mainly for system integrators. =item L Yet another FFI like interface that does not appear to be supported or under development anymore. =back =head1 ACKNOWLEDGMENTS In addition to the contributors mentioned below, I would like to acknowledge Brock Wilcox (AWWAIID) and Meredith Howard (MHOWARD) whose work on L not only helped me get started with FFI but significantly influenced the design of Platypus. In addition I'd like to thank Alessandro Ghedini (ALEXBIO) who was always responsive to bug reports and pull requests for L, which was important in the development of the ideas on which Platypus is based. =head1 AUTHOR Author: Graham Ollis Eplicease@cpan.orgE Contributors: Bakkiaraj Murugesan (bakkiaraj) Dylan Cali (calid) pipcet Zaki Mughal (zmughal) Fitz Elliott (felliott) Vickenty Fesunov (vyf) Gregor Herrmann (gregoa) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Graham Ollis. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut no_tabs.t100644001750001750 52413065045605 17451 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xt/authoruse strict; use warnings; use Test::More; BEGIN { plan skip_all => 'test requires Test::NoTabs' unless eval q{ use Test::NoTabs; 1 }; }; use Test::NoTabs; use FindBin; use File::Spec; chdir(File::Spec->catdir($FindBin::Bin, File::Spec->updir, File::Spec->updir)); all_perl_files_ok( grep { -e $_ } qw( bin lib t Makefile.PL )); version.t100644001750001750 214413065045605 17531 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xt/authoruse strict; use warnings; use Test::More; use FindBin (); BEGIN { plan skip_all => "test requires Test::Version 2.00" unless eval q{ use Test::Version 2.00 qw( version_all_ok ), { has_version => 1, filename_match => sub { $_[0] !~ m{/(ConfigData|Install/Files)\.pm$} }, }; 1 }; plan skip_all => "test requires Path::Class" unless eval q{ use Path::Class qw( file dir ); 1 }; plan skip_all => 'test requires YAML' unless eval q{ use YAML; 1; }; } use YAML qw( LoadFile ); use FindBin; use File::Spec; plan skip_all => "test not built yet (run dzil test)" unless -e dir( $FindBin::Bin)->parent->parent->file('Makefile.PL') || -e dir( $FindBin::Bin)->parent->parent->file('Build.PL'); my $config_filename = File::Spec->catfile( $FindBin::Bin, File::Spec->updir, File::Spec->updir, 'author.yml' ); my $config; $config = LoadFile($config_filename) if -r $config_filename; if($config->{version}->{dir}) { note "using dir " . $config->{version}->{dir} } version_all_ok($config->{version}->{dir} ? ($config->{version}->{dir}) : ()); done_testing; ffi_platypus_abi.t100644001750001750 107713065045605 17676 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More; use FFI::Platypus; my $ffi = FFI::Platypus->new; my %abis = %{ $ffi->abis }; plan tests => 2 + scalar keys %abis; ok defined $abis{default_abi}, 'has a default ABI'; foreach my $abi (keys %abis) { subtest $abi => sub { eval { $ffi->abi($abi) }; is $@, '', 'string'; eval { $ffi->abi($abis{$abi}) }; is $@, '', 'integer'; }; } subtest 'bogus' => sub { eval { $ffi->abi('bogus') }; like $@, qr{no such ABI: bogus}, 'string'; eval { $ffi->abi(999999) }; like $@, qr{no such ABI: 999999}, 'integer'; }; ffi_platypus_lib.t100644001750001750 54013065045605 17663 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 3; use File::Spec; use FFI::Platypus; use FFI::CheckLib; my $ffi = FFI::Platypus->new; my($lib) = find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; ok -e $lib, "exists $lib"; eval { $ffi->lib($lib) }; is $@, '', 'ffi.lib (set)'; is_deeply [eval { $ffi->lib }], [$lib], 'ffi.lib (get)'; ffi_platypus_new.t100644001750001750 134513065045605 17732 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 3; use FFI::Platypus; subtest 'no arguments' => sub { plan tests => 2; my $ffi = FFI::Platypus->new; isa_ok $ffi, 'FFI::Platypus', 'FFI::Platypus.new'; is_deeply [$ffi->lib], [], 'ffi.lib'; }; subtest 'with single lib' => sub { plan tests => 2; my $ffi = FFI::Platypus->new( lib => "libfoo.so" ); isa_ok $ffi, 'FFI::Platypus', 'FFI::Platypus.new'; is_deeply [$ffi->lib], ['libfoo.so'], 'ffi.lib'; }; subtest 'with multiple lib' => sub { plan tests => 2; my $ffi = FFI::Platypus->new( lib => ["libfoo.so", "libbar.so", "libbaz.so" ] ); isa_ok $ffi, 'FFI::Platypus', 'FFI::Platypus.new'; is_deeply [$ffi->lib], ['libfoo.so', 'libbar.so', 'libbaz.so'], 'ffi.lib'; }; var_array.c100644001750001750 20013065045605 17641 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesint sum(int *array, int size) { int total,i; for(i=0,total=0; i * * Generated on: 2014-10-30 11:43:56 * Math::Int64 version: 0.33 * Module::CAPIMaker version: 0.02 */ #include "EXTERN.h" #include "perl.h" #include "ppport.h" #ifdef __MINGW32__ #include #endif #ifdef _MSC_VER #include typedef __int64 int64_t; typedef unsigned __int64 uint64_t; #endif /* you may need to add a typemap for int64_t here if it is not defined by default in your C header files */ HV *math_int64_c_api_hash; int math_int64_c_api_min_version; int math_int64_c_api_max_version; int64_t (*math_int64_c_api_SvI64)(pTHX_ SV*); int (*math_int64_c_api_SvI64OK)(pTHX_ SV*); uint64_t (*math_int64_c_api_SvU64)(pTHX_ SV*); int (*math_int64_c_api_SvU64OK)(pTHX_ SV*); SV * (*math_int64_c_api_newSVi64)(pTHX_ int64_t); SV * (*math_int64_c_api_newSVu64)(pTHX_ uint64_t); uint64_t (*math_int64_c_api_randU64)(pTHX); int perl_math_int64_load(int required_version) { dTHX; SV **svp; eval_pv("require Math::Int64", TRUE); if (SvTRUE(ERRSV)) return 0; math_int64_c_api_hash = get_hv("Math::Int64::C_API", 0); if (!math_int64_c_api_hash) { sv_setpv(ERRSV, "Unable to load Math::Int64 C API"); SvSETMAGIC(ERRSV); return 0; } svp = hv_fetch(math_int64_c_api_hash, "min_version", 11, 0); if (!svp) svp = hv_fetch(math_int64_c_api_hash, "version", 7, 1); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to retrieve C API version for Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_min_version = SvIV(*svp); svp = hv_fetch(math_int64_c_api_hash, "max_version", 11, 0); if (!svp) svp = hv_fetch(math_int64_c_api_hash, "version", 7, 1); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to retrieve C API version for Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_max_version = SvIV(*svp); if ((required_version < math_int64_c_api_min_version) || (required_version > math_int64_c_api_max_version)) { sv_setpvf(ERRSV, "Math::Int64 C API version mismatch. " "The installed module supports versions %d to %d but %d is required", math_int64_c_api_min_version, math_int64_c_api_max_version, required_version); SvSETMAGIC(ERRSV); return 0; } svp = hv_fetch(math_int64_c_api_hash, "SvI64", 5, 0); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to fetch pointer 'SvI64' C function from Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_SvI64 = INT2PTR(void *, SvIV(*svp)); svp = hv_fetch(math_int64_c_api_hash, "SvI64OK", 7, 0); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to fetch pointer 'SvI64OK' C function from Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_SvI64OK = INT2PTR(void *, SvIV(*svp)); svp = hv_fetch(math_int64_c_api_hash, "SvU64", 5, 0); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to fetch pointer 'SvU64' C function from Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_SvU64 = INT2PTR(void *, SvIV(*svp)); svp = hv_fetch(math_int64_c_api_hash, "SvU64OK", 7, 0); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to fetch pointer 'SvU64OK' C function from Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_SvU64OK = INT2PTR(void *, SvIV(*svp)); svp = hv_fetch(math_int64_c_api_hash, "newSVi64", 8, 0); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to fetch pointer 'newSVi64' C function from Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_newSVi64 = INT2PTR(void *, SvIV(*svp)); svp = hv_fetch(math_int64_c_api_hash, "newSVu64", 8, 0); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to fetch pointer 'newSVu64' C function from Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_newSVu64 = INT2PTR(void *, SvIV(*svp)); svp = hv_fetch(math_int64_c_api_hash, "randU64", 7, 0); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to fetch pointer 'randU64' C function from Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_randU64 = INT2PTR(void *, SvIV(*svp)); return 1; } #endif longdouble.c100644001750001750 157513065045605 17675 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/libtest#include "libtest.h" #ifdef FFI_PL_PROBE_LONGDOUBLE EXTERN long double longdouble_add(long double a, long double b) { return a + b; } EXTERN int longdouble_pointer_test(long double *a, long double *b) { if(*a + *b != 4.0L) return 0; *a = 4.0L; *b = 8.0L; return 1; } EXTERN long double * longdouble_pointer_return_test(long double a) { static long double *keep = NULL; if(keep == NULL) keep = malloc(sizeof(long double)); *keep = a; return keep; } EXTERN int longdouble_array_test(long double *a, int n) { long double sum; int i; int ret; for(sum=0.0,i=0; i < n; i++) { sum += a[i]; } if(sum == 100.00) ret = 1; else ret = 0; for(i=0; i < n; i++) a[i] = (long double) i+1; return ret; } EXTERN long double * longdouble_array_return_test() { static long double keep[3] = { 1.0, 2.0, 3.0 }; return keep; } #endif changes.t100644001750001750 111513065045605 17567 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xt/releaseuse strict; use warnings; use Test::More; BEGIN { plan skip_all => 'test requires Test::CPAN::Changes' unless eval q{ use Test::CPAN::Changes; 1 }; }; use Test::CPAN::Changes; use FindBin; use File::Spec; chdir(File::Spec->catdir($FindBin::Bin, File::Spec->updir, File::Spec->updir)); do { my $old = \&Test::Builder::carp; my $new = sub { my($self, @messages) = @_; return if $messages[0] =~ /^Date ".*" is not in the recommend format/; $old->($self, @messages); }; no warnings 'redefine'; *Test::Builder::carp = $new; }; changes_file_ok; done_testing; ffi_platypus_cast.t100644001750001750 377013065045605 20077 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 3; use FFI::Platypus; use FFI::CheckLib; my $ffi = FFI::Platypus->new; $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'); subtest 'cast from string to pointer' => sub { plan tests => 2; my $string = "foobarbaz"; my $pointer = $ffi->cast(string => opaque => $string); is $ffi->function(string_matches_foobarbaz => ['opaque'] => 'int')->call($pointer), 1, 'dynamic'; $ffi->attach_cast(cast1 => string => 'opaque'); my $pointer2 = cast1($string); is $ffi->function(string_matches_foobarbaz => ['opaque'] => 'int')->call($pointer2), 1, 'static'; }; subtest 'cast from pointer to string' => sub { plan tests => 2; my $pointer = $ffi->function(string_return_foobarbaz => [] => 'opaque')->call(); my $string = $ffi->cast(opaque => string => $pointer); is $string, "foobarbaz", "dynamic"; $ffi->attach_cast(cast2 => pointer => 'string'); my $string2 = cast2($pointer); is $string2, "foobarbaz", "static"; }; subtest 'cast closure to opaque' => sub { plan tests => 4; my $testname = 'dynamic'; my $closure = $ffi->closure(sub { is $_[0], "testvalue", $testname }); my $pointer = $ffi->cast('(string)->void' => opaque => $closure); $ffi->function(string_set_closure => ['opaque'] => 'void')->call($pointer); $ffi->function(string_call_closure => ['string'] => 'void')->call("testvalue"); $ffi->function(string_set_closure => ['(string)->void'] => 'void')->call($pointer); $ffi->function(string_call_closure => ['string'] => 'void')->call("testvalue"); $ffi->attach_cast('cast3', '(string)->void' => 'opaque'); my $pointer2 = cast3($closure); $testname = 'static'; $ffi->function(string_set_closure => ['opaque'] => 'void')->call($pointer2); $ffi->function(string_call_closure => ['string'] => 'void')->call("testvalue"); $ffi->function(string_set_closure => ['(string)->void'] => 'void')->call($pointer2); $ffi->function(string_call_closure => ['string'] => 'void')->call("testvalue"); }; ffi_platypus_lang.t100644001750001750 556413065045605 20071 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 5; use FFI::CheckLib; use FFI::Platypus; my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; subtest C => sub { plan tests => 4; my $ffi = FFI::Platypus->new; $ffi->lib($libtest); eval { $ffi->type('int') }; is $@, '', 'int is an okay type'; eval { $ffi->type('foo_t') }; isnt $@, '', 'foo_t is not an okay type'; note $@; eval { $ffi->type('sint16') }; is $@, '', 'sint16 is an okay type'; is $ffi->find_symbol('UnMangled::Name(int i)'), undef, 'unable to find unmangled name'; }; subtest ASM => sub { plan tests => 4; my $ffi = FFI::Platypus->new(lang => 'ASM'); $ffi->lib($libtest); eval { $ffi->type('int') }; isnt $@, '', 'int is not an okay type'; note $@; eval { $ffi->type('foo_t') }; isnt $@, '', 'foo_t is not an okay type'; note $@; eval { $ffi->type('sint16') }; is $@, '', 'sint16 is an okay type'; is $ffi->find_symbol('UnMangled::Name(int i)'), undef, 'unable to find unmangled name'; }; subtest 'Foo constructor' => sub { plan tests => 6; my $ffi = FFI::Platypus->new(lang => 'Foo'); $ffi->lib($libtest); eval { $ffi->type('int') }; isnt $@, '', 'int is not an okay type'; note $@; eval { $ffi->type('foo_t') }; is $@, '', 'foo_t is an okay type'; eval { $ffi->type('sint16') }; is $@, '', 'sint16 is an okay type'; is $ffi->sizeof('foo_t'), 2, 'sizeof foo_t = 2'; is $ffi->sizeof('bar_t'), 4, 'sizeof foo_t = 4'; is $ffi->function('UnMangled::Name(int i)' => ['myint'] => 'myint')->call(22), 22; }; subtest 'Foo attribute' => sub { plan tests => 6; my $ffi = FFI::Platypus->new; $ffi->lib($libtest); $ffi->lang('Foo'); eval { $ffi->type('int') }; isnt $@, '', 'int is not an okay type'; note $@; eval { $ffi->type('foo_t') }; is $@, '', 'foo_t is an okay type'; eval { $ffi->type('sint16') }; is $@, '', 'sint16 is an okay type'; is $ffi->sizeof('foo_t'), 2, 'sizeof foo_t = 2'; is $ffi->sizeof('bar_t'), 4, 'sizeof foo_t = 4'; is $ffi->function('UnMangled::Name(int i)' => ['myint'] => 'myint')->call(22), 22; }; subtest 'MyLang::Roger' => sub { my $ffi = FFI::Platypus->new; $ffi->lang('=MyLang::Roger'); eval { $ffi->type('int') }; isnt $@, '', 'int is not an okay type'; note $@; is $ffi->sizeof('foo_t'), 4, 'sizeof foo_t = 4'; }; package MyLang::Roger; sub native_type_map { { foo_t => 'sint32', } } package FFI::Platypus::Lang::Foo; sub native_type_map { { foo_t => 'sint16', bar_t => 'uint32', myint => 'sint32', } } sub mangler { die "not a class method of FFI::Platypus::Lang::Foo" unless $_[0] eq 'FFI::Platypus::Lang::Foo'; die "libtest not passed in as second argument" unless $_[1] eq $libtest; my %mangle = ( 'UnMangled::Name(int i)' => 'f0', ); sub { defined $mangle{$_[0]} ? $mangle{$_[0]} : $_[0]; }; } ffi_platypus_type.t100644001750001750 1301213065045605 20134 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 8; use FFI::Platypus; use JSON::PP qw( encode_json ); BEGIN { eval q{ use YAML () } }; sub xdump ($) { my($object) = @_; YAML->can('Dump') ? YAML::Dump($object) : encode_json($object); } subtest 'simple type' => sub { plan tests => 2; my $ffi = FFI::Platypus->new; eval { $ffi->type('sint8') }; is $@, '', 'ffi.type(sint8)'; isa_ok $ffi->{types}->{sint8}, 'FFI::Platypus::Type'; }; subtest 'aliased type' => sub { plan tests => 4; my $ffi = FFI::Platypus->new; eval { $ffi->type('sint8', 'my_integer_8') }; is $@, '', 'ffi.type(sint8 => my_integer_8)'; isa_ok $ffi->{types}->{my_integer_8}, 'FFI::Platypus::Type'; isa_ok $ffi->{types}->{sint8}, 'FFI::Platypus::Type'; ok scalar(grep { $_ eq 'my_integer_8' } $ffi->types), 'ffi.types returns my_integer_8'; }; my @list = grep { FFI::Platypus::_have_type($_) } qw( sint8 uint8 sint16 uint16 sint32 uint32 sint64 uint64 float double opaque string longdouble complex_float complex_double ); subtest 'ffi basic types' => sub { plan tests => scalar @list; foreach my $name (@list) { subtest $name => sub { plan tests => 3; my $ffi = FFI::Platypus->new; eval { $ffi->type($name) }; is $@, '', "ffi.type($name)"; isa_ok $ffi->{types}->{$name}, 'FFI::Platypus::Type'; my $meta = $ffi->type_meta($name); note xdump( $meta); cmp_ok $meta->{size}, '>', 0, "size = " . $meta->{size}; }; } }; subtest 'ffi pointer types' => sub { plan tests => scalar @list; foreach my $name (map { "$_ *" } @list) { subtest $name => sub { plan skip_all => 'ME GRIMLOCK SAY STRING CAN NO BE POINTER' if $name eq 'string *'; plan tests => 3; my $ffi = FFI::Platypus->new; eval { $ffi->type($name) }; is $@, '', "ffi.type($name)"; isa_ok $ffi->{types}->{$name}, 'FFI::Platypus::Type'; my $meta = $ffi->type_meta($name); note xdump( $meta); cmp_ok $meta->{size}, '>', 0, "size = " . $meta->{size}; } } }; subtest 'ffi array types' => sub { plan tests => scalar @list; my $size = 5; foreach my $basic (@list) { my $name = "$basic [$size]"; subtest $name => sub { plan skip_all => 'ME GRIMLOCK SAY STRING CAN NO BE ARRAY' if $name =~ /^string \[[0-9]+\]$/; # TODO: actually this should be doable plan tests => 4; my $ffi = FFI::Platypus->new; eval { $ffi->type($name) }; is $@, '', "ffi.type($name)"; isa_ok $ffi->{types}->{$name}, 'FFI::Platypus::Type'; my $meta = $ffi->type_meta($name); note xdump( $meta); cmp_ok $meta->{size}, '>', 0, "size = " . $meta->{size}; is $meta->{element_count}, $size, "size = $size"; }; $size += 2; } }; subtest 'closure types' => sub { plan tests => 6; my $ffi = FFI::Platypus->new; $ffi->type('int[22]' => 'my_int_array'); $ffi->type('int' => 'myint'); $ffi->type('(int)->int' => 'foo'); is $ffi->type_meta('foo')->{type}, 'closure', '(int)->int is a legal closure type'; note xdump($ffi->type_meta('foo')); SKIP: { skip "arrays not currently supported as closure argument types", 1; $ffi->type('(my_int_array)->myint' => 'bar'); is $ffi->type_meta('bar')->{type}, 'closure', '(int)->int is a legal closure type'; note xdump($ffi->type_meta('bar')); } eval { $ffi->type('((int)->int)->int') }; isnt $@, '', 'inline closure illegal'; eval { $ffi->type('(foo)->int') }; isnt $@, '', 'argument type closure illegal'; eval { $ffi->type('(int)->foo') }; isnt $@, '', 'return type closure illegal'; $ffi->type('(int,int,int,char,string,opaque)->void' => 'baz'); is $ffi->type_meta('baz')->{type}, 'closure', 'a more complicated closure'; note xdump($ffi->type_meta('baz')); }; subtest 'record' => sub { plan tests => 4; my $ffi = FFI::Platypus->new; $ffi->type('record(1)' => 'my_record_1'); note xdump($ffi->type_meta('my_record_1')); $ffi->type('record (32)' => 'my_record_32'); note xdump($ffi->type_meta('my_record_32')); is $ffi->type_meta('my_record_1')->{size}, 1, "sizeof my_record_1 = 1"; is $ffi->type_meta('my_record_32')->{size}, 32, "sizeof my_record_32 = 32"; $ffi->type('record(My::Record22)' => 'my_record_22'); note xdump($ffi->type_meta('my_record_22')); $ffi->type('record (My::Record44)' => 'my_record_44'); note xdump($ffi->type_meta('my_record_44')); is $ffi->type_meta('my_record_22')->{size}, 22, "sizeof my_record_22 = 22"; is $ffi->type_meta('my_record_44')->{size}, 44, "sizeof my_record_44 = 44"; }; subtest 'string' => sub { my $ffi = FFI::Platypus->new; my $ptr_size = $ffi->sizeof('opaque'); foreach my $type ('string', 'string_rw', 'string_ro', 'string rw', 'string ro') { subtest $type => sub { plan tests => 3; my $meta = $ffi->type_meta($type); is $meta->{size}, $ptr_size, "sizeof $type = $ptr_size"; is $meta->{fixed_size}, 0, 'not fixed size'; my $access = $type =~ /rw$/ ? 'rw' : 'ro'; is $meta->{access}, $access, "access = $access"; note xdump($meta); } } foreach my $type ('string (10)', 'string(10)') { subtest $type => sub { my $meta = $ffi->type_meta($type); is $meta->{size}, 10, "sizeof $type = 10"; is $meta->{fixed_size}, 1, "fixed size"; is $meta->{access}, 'rw', 'access = rw'; note xdump($meta); }; } }; package My::Record22; use constant ffi_record_size => 22; package My::Record44; use constant _ffi_record_size => 44; var_array.pl100644001750001750 33413065045605 20042 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib('./var_array.so'); $ffi->attach( sum => [ 'int[]', 'int' ] => 'int' ); my @list = (1..100); print sum(\@list, scalar @list), "\n"; ShareConfig.pm100644001750001750 120613065045605 17604 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/Mypackage My::ShareConfig; use strict; use warnings; use JSON::PP; sub new { my %data; if(-e 'share/config.json') { %data = %{ JSON::PP->new->decode(do { local $/; my $fh; open $fh, '<', 'share/config.json'; my $data = <$fh>; close $fh; $data; }) }; } bless \%data, __PACKAGE__; } sub get { my($self, $name) = @_; $self->{$name}; } sub set { my($self, $name, $value) = @_; $self->{$name} = $value; my %data = %$self; my $data = JSON::PP->new->pretty->encode(\%data); my $fh; open($fh, '>', 'share/config.json'); print $fh $data; close $fh; } 1; ModuleBuild.pm100644001750001750 1571213065045605 17650 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/Mypackage My::ModuleBuild; use strict; use warnings; use 5.008001; use Alien::FFI; use My::LibTest; use My::AutoConf; use My::Dev; use ExtUtils::CBuilder; use File::Glob qw( bsd_glob ); use Config; use Text::ParseWords qw( shellwords ); use base qw( Module::Build ); use My::ShareConfig; sub new { my($class, %args) = @_; my %diag; my $share_config = My::ShareConfig->new; $args{c_source} = 'xs'; $args{include_dirs} = 'include'; $args{extra_compiler_flags} = Alien::FFI->cflags; $args{extra_linker_flags} = Alien::FFI->libs; $args{requires}->{'Math::Int64'} = '0.34' if $ENV{FFI_PLATYPUS_DEBUG_FAKE32} || $Config{uvsize} < 8; if($^O eq 'MSWin32' && $Config{cc} =~ /cl(\.exe)?$/i) { $args{extra_linker_flags} .= ' psapi.lib'; } elsif($^O =~ /^(MSWin32|cygwin|msys)$/) { # TODO: ac this bad boy ? $args{extra_linker_flags} .= " -L/usr/lib/w32api" if $^O =~ /^(cygwin|msys)$/; $args{extra_linker_flags} .= " -lpsapi"; } my $lddlflags = $Config{lddlflags}; my $ldflags = $Config{ldflags}; my $ccflags = $Config{ccflags}; if($^O eq 'darwin') { # strip the -arch flags on darwin / os x. my @lddlflags_in = shellwords $lddlflags; my @lddlflags; while(@lddlflags_in) { my $arg = shift @lddlflags_in; if($arg eq '-arch') { shift @lddlflags_in; } else { push @lddlflags, $arg; } } $lddlflags = "@lddlflags"; my @ldflags_in = shellwords $ldflags; my @ldflags; while(@ldflags_in) { my $arg = shift @ldflags_in; if($arg eq '-arch') { shift @ldflags_in; } else { push @ldflags, $arg; } } $ldflags = "@ldflags"; my @ccflags_in = shellwords $ccflags; my @ccflags; while(@ccflags_in) { my $arg = shift @ccflags_in; if($arg eq '-arch') { shift @ccflags_in; } else { push @ccflags, $arg; } } $ccflags = "@ccflags"; } # on some configurations (eg. Solaris 64 bit, Strawberry Perl) # -L flags are included in the lddlflags configuration, but we # need to make sure OUR -L comes first my @libdirflags = grep /^-L/, shellwords(Alien::FFI->libs); if(@libdirflags) { $lddlflags = join ' ', @libdirflags, $lddlflags; } if($^O eq 'MSWin32') { # needed by My/Probe.pm on any MSWin32 platform $args{build_requires}->{'Win32::ErrorMode'} = 0; } $diag{args}->{extra_compiler_flags} = $args{extra_compiler_flags}; $diag{args}->{extra_linker_flags} = $args{extra_linker_flags}; my $self = $class->SUPER::new(%args); print "\n\n"; print "CONFIGURE\n"; print " + \$args{extra_compiler_flags} = $args{extra_compiler_flags}\n"; print " + \$args{extra_linker_flags} = $args{extra_linker_flags}\n"; print "\n\n"; if($ENV{FFI_PLATYPUS_DEBUG}) { my $config = $self->config; print "\n\n"; print "DEBUG:\n"; foreach my $key (keys %Config) { my $value = $Config{$key}; next unless defined $value; if($value =~ s/-O[0-9]?/-g3/g) { print " - \$Config{$key} = ", $config->{$key}, "\n"; print " + \$Config{$key} = $value\n"; $self->config($key, $value); $diag{config}->{$key} = $value; } } print "\n\n"; } if($ENV{FFI_PLATYPUS_DEBUG_FAKE32} && $Config{uvsize} == 8) { print "\n\n"; print "DEBUG_FAKE32:\n"; print " + making Math::Int64 a prerequisite (not normally done on 64 bit Perls)\n"; print " + using Math::Int64's C API to manipulate 64 bit values (not normally done on 64 bit Perls)\n"; print "\n\n"; $share_config->set(config_debug_fake32 => 1); $diag{config}->{config_debug_fake32} = 1; } if($ENV{FFI_PLATYPUS_NO_ALLOCA}) { print "\n\n"; print "NO_ALLOCA:\n"; print " + alloca() will not be used, even if your platform supports it.\n"; print "\n\n"; $share_config->set(config_no_alloca => 1); $diag{config}->{config_no_alloca} = 1; } if($lddlflags ne $Config{lddlflags}) { $self->config(lddlflags => $lddlflags); $diag{config}->{lddlflags} = $lddlflags; print "\n\n"; print "Adjusted lddlflags:\n"; print " - \$Config{lddlflags} = $Config{lddlflags}\n"; print " + \$Config{lddlflags} = $lddlflags\n"; print "\n\n"; } if($ldflags ne $Config{ldflags}) { $self->config(ldflags => $ldflags); $diag{config}->{ldflags} = $ldflags; print "\n\n"; print "Adjusted ldflags:\n"; print " - \$Config{ldflags} = $Config{ldflags}\n"; print " + \$Config{ldflags} = $ldflags\n"; print "\n\n"; } if($ccflags ne $Config{ccflags}) { $self->config(ccflags => $ccflags); $diag{config}->{ccflags} = $ccflags; print "\n\n"; print "Adjusted ccflags:\n"; print " - \$Config{ccflags} = $Config{ccflags}\n"; print " + \$Config{ccflags} = $ccflags\n"; print "\n\n"; } $self->add_to_cleanup( 'libtest/*.o', 'libtest/*.obj', 'libtest/*.so', 'libtest/*.dll', 'libtest/*.bundle', 'examples/*.o', 'examples/*.so', 'examples/*.dll', 'examples/*.bundle', 'examples/java/*.so', 'examples/java/*.o', 'xs/ffi_platypus_config.h', 'config.log', 'test*.o', 'test*.c', '*.core', 'Build.bat', 'build.bat', 'core', 'share/config.json', 'include/ffi_platypus_config.h', ); # dlext as understood by MB and MM my @dlext = ($Config{dlext}); # extra dlext as understood by the OS push @dlext, 'dll' if $^O =~ /^(cygwin|MSWin32|msys)$/; push @dlext, 'xs.dll' if $^O =~ /^(MSWin32)$/; push @dlext, 'so' if $^O =~ /^(cygwin|darwin)$/; push @dlext, 'bundle', 'dylib' if $^O =~ /^(darwin)$/; # uniq'ify it @dlext = do { my %seen; grep { !$seen{$_}++ } @dlext }; #print "dlext[]=$_\n" for @dlext; $share_config->set(diag => \%diag); $share_config->set(config_dlext => \@dlext); $self; } sub ACTION_ac { my($self) = @_; My::AutoConf->configure; } sub ACTION_ac_clean { my($self) = @_; My::AutoConf->clean; } sub ACTION_probe { my($self) = @_; $self->depends_on('ac'); require My::Probe; My::Probe->probe($self); } sub ACTION_build { my $self = shift; my $b = ExtUtils::CBuilder->new; My::Dev->generate; my($header_time) = reverse sort map { (stat $_)[9] } map { bsd_glob($_) } qw( include/*.h xs/*.xs); my $c = File::Spec->catfile(qw(lib FFI Platypus.c)); my($obj) = $b->object_file($c); my $obj_time = (stat $obj)[9]; $obj_time ||= 0; if($obj_time < $header_time) { unlink $obj; unlink $c; } $self->depends_on('ac'); $self->depends_on('probe'); $self->SUPER::ACTION_build(@_); } sub ACTION_libtest { my($self) = @_; $self->depends_on('ac'); $self->depends_on('probe'); My::LibTest->build($self); } sub ACTION_test { my $self = shift; $self->depends_on('libtest'); $self->SUPER::ACTION_test(@_); } sub ACTION_distclean { my($self) = @_; $self->depends_on('realclean'); } 1; bigendian.c100644001750001750 65413065045605 17652 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/probe#include "ffi_platypus.h" unsigned char my_foo(void) { return 0xaa; } int main(int argc, char *argv[]) { ffi_cif cif; ffi_type *args[1]; void *values[1]; unsigned char bytes[4] = { 0x00, 0x00, 0x00, 0x00 }; if(ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 0, &ffi_type_uint8, args) ==FFI_OK) { ffi_call(&cif, (void *) my_foo, &bytes, values); if(bytes[3] == 0xaa) { return 0; } } return 2; } align_array.c100644001750001750 275513065045605 20034 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/libtest#include "libtest.h" typedef struct _my_struct { char x1; uint64_t my_uint64[3]; char x2; uint32_t my_uint32[3]; char x3; uint16_t my_uint16[3]; char x4; uint8_t my_uint8[3]; char x5; int64_t my_sint64[3]; char x6; int32_t my_sint32[3]; char x7; int16_t my_sint16[3]; char x8; int8_t my_sint8[3]; char x9; float my_float[3]; char x10; double my_double[3]; char x11; void *my_opaque[3]; } my_struct; EXTERN uint64_t * align_array_get_uint64(my_struct *my_struct) { return my_struct->my_uint64; } EXTERN uint32_t * align_array_get_uint32(my_struct *my_struct) { return my_struct->my_uint32; } EXTERN uint16_t * align_array_get_uint16(my_struct *my_struct) { return my_struct->my_uint16; } EXTERN uint8_t * align_array_get_uint8(my_struct *my_struct) { return my_struct->my_uint8; } EXTERN int64_t * align_array_get_sint64(my_struct *my_struct) { return my_struct->my_sint64; } EXTERN int32_t * align_array_get_sint32(my_struct *my_struct) { return my_struct->my_sint32; } EXTERN int16_t * align_array_get_sint16(my_struct *my_struct) { return my_struct->my_sint16; } EXTERN int8_t * align_array_get_sint8(my_struct *my_struct) { return my_struct->my_sint8; } EXTERN float * align_array_get_float(my_struct *my_struct) { return my_struct->my_float; } EXTERN double * align_array_get_double(my_struct *my_struct) { return my_struct->my_double; } EXTERN void ** align_array_get_opaque(my_struct *my_struct) { return my_struct->my_opaque; } align_fixed.c100644001750001750 26213065045605 17764 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/libtest#include "libtest.h" typedef struct { char mess_up_alignment; const char value[10]; } foo_t; EXTERN const char * align_fixed_get_value(foo_t *foo) { return foo->value; } ffi_platypus_types.t100644001750001750 52513065045605 20264 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 1; use FFI::Platypus; subtest 'class or instance method' => sub { plan tests => 1; my @class = FFI::Platypus->types; my @instance = FFI::Platypus->new->types; is_deeply \@class, \@instance, 'class and instance methods are identical'; note "type: $_" foreach sort @class; }; type_complex_float.t100644001750001750 266113065045605 20253 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib; BEGIN { plan skip_all => 'test requires support for float complex' unless FFI::Platypus::_have_type('complex_float'); } use FFI::Platypus::Declare 'complex_float', 'float', 'string'; plan tests => 1; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach ['complex_float_get_real' => 'creal'] => [complex_float] => float; attach ['complex_float_get_imag' => 'cimag'] => [complex_float] => float; attach ['complex_float_to_string' => 'to_string'] => [complex_float] => string; subtest 'standard argument' => sub { plan tests => 3; subtest 'with a real number' => sub { plan tests => 2; note "to_string(10.5) = ", to_string(10.5); is creal(10.5), 10.5, "creal(10.5) = 10.5"; is cimag(10.5), 0.0, "cimag(10.5) = 0.0"; }; subtest 'with an array ref' => sub { plan tests => 2; note "to_string([10.5,20.5]) = ", to_string([10.5,20.5]); is creal([10.5,20.5]), 10.5, "creal([10.5,20.5]) = 10.5"; is cimag([10.5,20.5]), 20.5, "cimag([10.5,20.5]) = 20.5"; }; subtest 'with Math::Complex' => sub { plan skip_all => 'test requires Math::Complex' unless eval q{ use Math::Complex (); 1 }; plan tests => 2; my $c = Math::Complex->make(10.5, 20.5); note "to_string(\$c) = ", to_string($c); is creal($c), 10.5, "creal(\$c) = 10.5"; is cimag($c), 20.5, "cimag(\$c) = 20.5"; }; }; get_uptime.pl100644001750001750 365213065045605 20244 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examples#!perl #Description: Get linux system uptime using GNOME libgtop library and FFI::Platypus #Refer: https://developer.gnome.org/libgtop/stable/libgtop-Uptime.html #Author: Bakkiaraj M use strict; use warnings; use FFI::Platypus; use FFI::CheckLib; use Convert::Binary::C; use Time::Seconds; #Find the lib my $lib_path = find_lib(lib=>'gtop-2.0',libpath=>'/usr/lib64'); print "\n Found libgtop in :", $lib_path; #Create FFI::Platypus object my $ffi = FFI::Platypus->new(); $ffi->lib($lib_path); #Create Convert::Binary::C object to import the structures my $c_struct = Convert::Binary::C->new(); $c_struct->configure( 'Alignment' => 0 ); #import glibtop_uptime struct using Convert::Binary::C #Note: guint64 is unsigned long as per #http://www.freedesktop.org/software/gstreamer-sdk/data/docs/latest/glib/glib-Basic-Types.html#guint64 $c_struct->parse(<pack('glibtop_uptime',{}); #Get size of the glibtop_uptime my $glibtop_uptime_size = $c_struct->sizeof('glibtop_uptime'); #typecast the glibtop_uptime as a FFI::Platypus record $ffi->type("record($glibtop_uptime_size)"=>'glibtop_uptime'); #import glibtop_get_uptime function from libgtop to perl $ffi->attach('glibtop_get_uptime',['glibtop_uptime'],'void'); #Call glibtop_get_uptime glibtop_get_uptime ($packed_glibtop_uptime_struct); #unpack the structure my $glibtop_uptime_struct = $c_struct->unpack('glibtop_uptime',$packed_glibtop_uptime_struct); #print "\n", Dumper($glibtopUptimeStruct); print "\n System is upfor: ", $glibtop_uptime_struct->{'uptime'}," Sec"; my $time = Time::Seconds->new($glibtop_uptime_struct->{'uptime'}); print "\n System is upfor: ",$time->pretty; #using uptime command print "\n\n System is upfor:"; system('uptime -p'); win32_beep.pl100644001750001750 36213065045605 20012 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use FFI::Platypus; my($freq, $duration) = @_; $freq ||= 750; $duration ||= 300; FFI::Platypus ->new(lib=>[undef], lang => 'Win32') ->function( Beep => ['DWORD','DWORD']=>'BOOL') ->call($freq, $duration); java000755001750001750 013065045605 16320 5ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesMakefile100644001750001750 47013065045605 20101 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examples/javaGCJ=gcj CXX=g++ CFLAGS=-fPIC LDFLAGS=-shared RM=rm -f libexample.so: between.o Example.o $(GCJ) $(LDFLAGS) -o libexample.so between.o Example.o between.o: between.cpp $(CXX) $(CFLAGS) -c -o between.o between.cpp Example.o: Example.java $(GCJ) $(CFLAGS) -c -o Example.o Example.java clean: $(RM) *.o *.so travis_cpan.pl100644001750001750 105013065045605 20140 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/runuse strict; use warnings; use File::Temp qw( tempdir ); my $module = shift @ARGV; my $skip; unless($] > 5.010) { $skip = "ZMQ::FFI requires Perl 5.10" if $module eq 'ZMQ::FFI'; } if($skip) { print $skip, "\n"; exit; } my $lib = tempdir( CLEANUP => 1 ); my @cmd = ( 'cpanm', '-n', '-l' => $lib, '--installdeps', $module ); print "+@cmd\n"; system @cmd; exit 2 if $?; @cmd = ( 'cpanm', '-l' => $lib, '-v', '--reinstall', $module ); print "+@cmd\n"; system @cmd; if($?) { system 'tail', -f => '/home/travis/.cpanm/build.log'; exit 2 } longdouble.c100644001750001750 126113065045605 20077 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/probe#include "ffi_platypus.h" long double my_long_double(long double a, long double b) { if(a != 1.0L || b != 3.0L) exit(2); return a+b; } int main(int argc, char *argv[]) { ffi_cif cif; ffi_type *args[2]; void *values[2]; if(&ffi_type_longdouble == &ffi_type_double) return 2; args[0] = &ffi_type_longdouble; args[1] = &ffi_type_longdouble; if(ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 2, &ffi_type_longdouble, args) == FFI_OK) { long double answer; long double a = 1.0L; long double b = 3.0L; values[0] = &a; values[1] = &b; ffi_call(&cif, (void*) my_long_double, &answer, values); if(answer == 4.0L) return 0; } return 2; } ffi_platypus.h100644001750001750 1640013065045605 20243 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/include#ifndef FFI_PLATYPUS_H #define FFI_PLATYPUS_H #include #include "ffi_platypus_config.h" #include "ffi_platypus_probe.h" #ifdef HAVE_DLFCN_H #ifndef PERL_OS_WINDOWS #include #endif #endif #ifdef HAVE_UNISTD_H #include #endif #ifdef HAVE_STDLIB_H #include #endif #ifdef HAVE_STDDEF_H #include #endif #ifdef HAVE_STDINT_H #include #endif #ifdef HAVE_INTTYPES_H #include #endif #ifdef HAVE_ALLOCA_H #include #endif #ifdef HAVE_STRING_H #include #endif #ifdef HAVE_COMPLEX_H #include #endif #ifdef __cplusplus extern "C" { #endif #ifndef RTLD_LAZY #define RTLD_LAZY 0 #endif #ifdef PERL_OS_WINDOWS void *windlopen(const char *, int); const char *windlerror(void); void *windlsym(void *, const char *); int windlclose(void *); #define dlopen(filename, flag) windlopen(filename, flag) #define dlerror() windlerror() #define dlsym(handle, symbol) windlsym(handle, symbol) #define dlclose(handle) windlclose(handle) #endif typedef enum _platypus_type { FFI_PL_NATIVE = 0, FFI_PL_STRING, FFI_PL_POINTER, FFI_PL_ARRAY, FFI_PL_CLOSURE, FFI_PL_CUSTOM_PERL, FFI_PL_RECORD, FFI_PL_EXOTIC_FLOAT } platypus_type; typedef enum _platypus_string_type { FFI_PL_STRING_RO = 0, FFI_PL_STRING_RW, FFI_PL_STRING_FIXED } platypus_string_type; typedef struct _ffi_pl_type_extra_record { size_t size; void *stash; /* really a HV* pointing to the package stash, or NULL */ } ffi_pl_type_extra_record; typedef struct _ffi_pl_type_extra_custom_perl { void *perl_to_native; void *native_to_perl; void *perl_to_native_post; int argument_count; } ffi_pl_type_extra_custom_perl; typedef struct _ffi_pl_type_extra_array { int element_count; } ffi_pl_type_extra_array; struct _ffi_pl_type; typedef struct _ffi_pl_type_extra_closure { ffi_cif ffi_cif; int flags; struct _ffi_pl_type *return_type; struct _ffi_pl_type *argument_types[0]; } ffi_pl_type_extra_closure; typedef struct _ffi_pl_type_extra_string { platypus_string_type platypus_string_type; size_t size; } ffi_pl_type_extra_string; typedef union _ffi_pl_type_extra { ffi_pl_type_extra_custom_perl custom_perl; ffi_pl_type_extra_array array; ffi_pl_type_extra_closure closure; ffi_pl_type_extra_record record; ffi_pl_type_extra_string string; } ffi_pl_type_extra; typedef struct _ffi_pl_type { ffi_type *ffi_type; platypus_type platypus_type; ffi_pl_type_extra extra[0]; } ffi_pl_type; typedef struct _ffi_pl_function { void *address; void *platypus_sv; /* really a Perl SV* */ ffi_cif ffi_cif; ffi_pl_type *return_type; ffi_pl_type *argument_types[0]; } ffi_pl_function; typedef struct _ffi_pl_closure { ffi_closure *ffi_closure; void *function_pointer; /* C function pointer */ void *coderef; /* Perl HV* pointing to FFI::Platypus::Closure object */ ffi_pl_type *type; } ffi_pl_closure; typedef const char *ffi_pl_string; typedef union _ffi_pl_result { void *pointer; const char *string; int8_t sint8; uint8_t uint8; #if defined FFI_PL_PROBE_BIGENDIAN int8_t sint8_array[4]; uint8_t uint8_array[4]; #elif defined FFI_PL_PROBE_BIGENDIAN64 int8_t sint8_array[8]; uint8_t uint8_array[8]; #endif int16_t sint16; uint16_t uint16; #if defined FFI_PL_PROBE_BIGENDIAN int16_t sint16_array[2]; uint16_t uint16_array[2]; #elif defined FFI_PL_PROBE_BIGENDIAN64 int16_t sint16_array[4]; uint16_t uint16_array[4]; #endif int32_t sint32; uint32_t uint32; #if defined FFI_PL_PROBE_BIGENDIAN64 uint32_t uint32_array[2]; int32_t sint32_array[2]; #endif int64_t sint64; uint64_t uint64; float xfloat; double xdouble; #ifdef FFI_PL_PROBE_LONGDOUBLE long double longdouble; #endif #ifdef FFI_TARGET_HAS_COMPLEX_TYPE #ifdef SIZEOF_FLOAT_COMPLEX float complex complex_float; #endif #ifdef SIZEOF_DOUBLE_COMPLEX double complex complex_double; #endif #endif } ffi_pl_result; typedef union _ffi_pl_argument { void *pointer; const char *string; int8_t sint8; uint8_t uint8; int16_t sint16; uint16_t uint16; int32_t sint32; uint32_t uint32; int64_t sint64; uint64_t uint64; float xfloat; double xdouble; } ffi_pl_argument; typedef struct _ffi_pl_arguments { int count; int reserved; ffi_pl_argument slot[0]; } ffi_pl_arguments; typedef struct _ffi_pl_record_member { int offset; int count; } ffi_pl_record_member; #define ffi_pl_arguments_count(arguments) (arguments->count) #define ffi_pl_arguments_set_pointer(arguments, i, value) (arguments->slot[i].pointer = value) #define ffi_pl_arguments_get_pointer(arguments, i) (arguments->slot[i].pointer) #define ffi_pl_arguments_set_string(arguments, i, value) (arguments->slot[i].string = value) #define ffi_pl_arguments_get_string(arguments, i) (arguments->slot[i].string) #define ffi_pl_arguments_set_sint8(arguments, i, value) (arguments->slot[i].sint8 = value) #define ffi_pl_arguments_get_sint8(arguments, i) (arguments->slot[i].sint8) #define ffi_pl_arguments_set_uint8(arguments, i, value) (arguments->slot[i].uint8 = value) #define ffi_pl_arguments_get_uint8(arguments, i) (arguments->slot[i].uint8) #define ffi_pl_arguments_set_sint16(arguments, i, value) (arguments->slot[i].sint16 = value) #define ffi_pl_arguments_get_sint16(arguments, i) (arguments->slot[i].sint16) #define ffi_pl_arguments_set_uint16(arguments, i, value) (arguments->slot[i].uint16 = value) #define ffi_pl_arguments_get_uint16(arguments, i) (arguments->slot[i].uint16) #define ffi_pl_arguments_set_sint32(arguments, i, value) (arguments->slot[i].sint32 = value) #define ffi_pl_arguments_get_sint32(arguments, i) (arguments->slot[i].sint32) #define ffi_pl_arguments_set_uint32(arguments, i, value) (arguments->slot[i].uint32 = value) #define ffi_pl_arguments_get_uint32(arguments, i) (arguments->slot[i].uint32) #define ffi_pl_arguments_set_sint64(arguments, i, value) (arguments->slot[i].sint64 = value) #define ffi_pl_arguments_get_sint64(arguments, i) (arguments->slot[i].sint64) #define ffi_pl_arguments_set_uint64(arguments, i, value) (arguments->slot[i].uint64 = value) #define ffi_pl_arguments_get_uint64(arguments, i) (arguments->slot[i].uint64) #define ffi_pl_arguments_set_float(arguments, i, value) (arguments->slot[i].xfloat = value) #define ffi_pl_arguments_get_float(arguments, i) (arguments->slot[i].xfloat) #define ffi_pl_arguments_set_double(arguments, i, value) (arguments->slot[i].xdouble = value) #define ffi_pl_arguments_get_double(arguments, i) (arguments->slot[i].xdouble) #define ffi_pl_arguments_pointers(arguments) ((void**)&arguments->slot[arguments->count]) #if defined(_MSC_VER) #define Newx_or_alloca(ptr, count, type) ptr = _alloca(sizeof(type)*count) #define Safefree_or_alloca(ptr) #define HAVE_ALLOCA 1 #elif defined(HAVE_ALLOCA) #define Newx_or_alloca(ptr, count, type) ptr = alloca(sizeof(type)*count) #define Safefree_or_alloca(ptr) #else #define Newx_or_alloca(ptr, count, type) Newx(ptr, count, type) #define Safefree_or_alloca(ptr) Safefree(ptr) #endif ffi_type *ffi_pl_name_to_type(const char *); #ifdef __cplusplus } #endif extern int have_pm(const char *pm_name); #endif align_string.c100644001750001750 61013065045605 20170 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/libtest#include "libtest.h" typedef struct { char mess_up_alignment; const char *value; } foo_t; EXTERN const char * align_string_get_value(foo_t *foo) { return foo->value; } EXTERN void align_string_set_value(foo_t *foo, const char *value) { static char buffer[512]; if(value != NULL) { strcpy(buffer, value); foo->value = buffer; } else { foo->value = NULL; } } ffi_platypus_sizeof.t100644001750001750 510413065045605 20435 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 5; use FFI::Platypus; my $ffi = FFI::Platypus->new; subtest integers => sub { plan tests => 8; is $ffi->sizeof('uint8'), 1, 'sizeof uint8 = 1'; is $ffi->sizeof('uint16'), 2, 'sizeof uint16 = 2'; is $ffi->sizeof('uint32'), 4, 'sizeof uint32 = 4'; is $ffi->sizeof('uint64'), 8, 'sizeof uint64 = 8'; is $ffi->sizeof('sint8'), 1, 'sizeof sint8 = 1'; is $ffi->sizeof('sint16'), 2, 'sizeof sint16 = 2'; is $ffi->sizeof('sint32'), 4, 'sizeof sint32 = 4'; is $ffi->sizeof('sint64'), 8, 'sizeof sint64 = 8'; }; subtest floats => sub { plan tests => 2; is $ffi->sizeof('float'), 4, 'sizeof float = 4'; is $ffi->sizeof('double'), 8, 'sizeof double = 8'; }; subtest pointers => sub { plan tests => 14; my $pointer_size = $ffi->sizeof('opaque'); ok $pointer_size == 4 || $pointer_size == 8, "sizeof opaque = $pointer_size"; is $ffi->sizeof('uint8*'), $pointer_size, "sizeof uint8* = $pointer_size"; is $ffi->sizeof('uint16*'), $pointer_size, "sizeof uint16* = $pointer_size"; is $ffi->sizeof('uint32*'), $pointer_size, "sizeof uint32* = $pointer_size"; is $ffi->sizeof('uint64*'), $pointer_size, "sizeof uint64* = $pointer_size"; is $ffi->sizeof('sint8*'), $pointer_size, "sizeof sint8* = $pointer_size"; is $ffi->sizeof('sint16*'), $pointer_size, "sizeof sint16* = $pointer_size"; is $ffi->sizeof('sint32*'), $pointer_size, "sizeof sint32* = $pointer_size"; is $ffi->sizeof('sint64*'), $pointer_size, "sizeof sint64* = $pointer_size"; is $ffi->sizeof('float*'), $pointer_size, "sizeof float* = $pointer_size"; is $ffi->sizeof('double*'), $pointer_size, "sizeof double* = $pointer_size"; is $ffi->sizeof('opaque*'), $pointer_size, "sizeof opaque* = $pointer_size"; is $ffi->sizeof('string'), $pointer_size, "sizeof string = $pointer_size"; is $ffi->sizeof('(int)->int'), $pointer_size, "sizeof (int)->int = $pointer_size"; }; subtest arrays => sub { plan tests => 110; foreach my $type (qw( uint8 uint16 uint32 uint64 sint8 sint16 sint32 sint64 float double opaque )) { my $unit_size = $ffi->sizeof($type); foreach my $size (1..10) { is $ffi->sizeof("$type [$size]"), $unit_size*$size, "sizeof $type [32] = @{[$unit_size*$size]}"; } } }; subtest custom_type => sub { foreach my $type (qw( uint8 uint16 uint32 uint64 sint8 sint16 sint32 sint64 float double opaque )) { my $expected = $ffi->sizeof($type); $ffi->custom_type( "my_$type" => { native_type => $type, native_to_perl => sub {} } ); is $ffi->sizeof("my_$type"), $expected, "sizeof my_$type = $expected"; } }; ffi_platypus_record.t100644001750001750 2227413065045605 20443 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use FFI::Platypus::Memory qw( malloc free ); use Test::More tests => 8; do { package Foo1; use FFI::Platypus::Record; record_layout( uint8 => 'first', uint32 => 'second', ); }; subtest 'integer accessor' => sub { plan tests => 8; my $foo = Foo1->new( first => 1, second => 2 ); isa_ok $foo, 'Foo1'; my $size = $foo->_ffi_record_size; like $size, qr{^[0-9]+$}, "foo._record_size = $size"; is $foo->first, 1, 'foo.first = 1'; is $foo->second, 2, 'foo.second = 2'; $foo->first(22); is $foo->first, 22, 'foo.first = 22'; $foo->second(42); is $foo->second, 42, 'foo.second = 42'; $foo = Foo1->new( { first => 3, second => 4 } ); is $foo->first, 3, 'foo.first = 3'; is $foo->second, 4, 'foo.second = 4'; }; do { package Color; use FFI::Platypus; use FFI::Platypus::Record; my $ffi = FFI::Platypus->new; $ffi->find_lib(lib => 'test', symbol => 'f0', libpath => 'libtest'); record_layout($ffi, qw( uint8 red uint8 green uint8 blue )); $ffi->type('record(Color)' => 'Color'); $ffi->attach( [ color_get_red => 'get_red' ] => [ 'Color' ] => 'int' ); $ffi->attach( [ color_get_green => 'get_green' ] => [ 'Color' ] => 'int' ); $ffi->attach( [ color_get_blue => 'get_blue' ] => [ 'Color' ] => 'int' ); }; subtest 'values match in C' => sub { plan tests => 4; my $color = Color->new( red => 50, green => 100, blue => 150, ); isa_ok $color, 'Color'; is $color->get_red, 50, "color.get_red = 50"; is $color->get_green, 100, "color.get_green = 100"; is $color->get_blue, 150, "color.get_blue = 150"; }; do { package Foo2; use FFI::Platypus::Record; record_layout(qw( char : uint64_t uint64 char : uint32_t uint32 char : uint16_t uint16 char : uint8_t uint8 char : int64_t sint64 char : int32_t sint32 char : int16_t sint16 char : int8_t sint8 char : float float char : double double char : opaque opaque )); my $ffi = FFI::Platypus->new; $ffi->find_lib(lib => 'test', symbol => 'f0', libpath => 'libtest'); $ffi->attach(["align_get_$_" => "get_$_"] => [ 'record(Foo2)' ] => $_) for qw( uint8 sint8 uint16 sint16 uint32 sint32 uint64 sint64 float double opaque ); }; subtest 'complex alignment' => sub { plan tests => 15; my $foo = Foo2->new; isa_ok $foo, 'Foo2'; $foo->uint64(512); is $foo->get_uint64, 512, "uint64 = 512"; $foo->sint64(-512); is $foo->get_sint64, -512, "sint64 = -512"; $foo->uint32(1024); is $foo->get_uint32, 1024, "uint32 = 1024"; $foo->sint32(-1024); is $foo->get_sint32, -1024, "sint32 = -1024"; $foo->uint16(2048); is $foo->get_uint16, 2048, "uint16 = 2048"; $foo->sint16(-2048); is $foo->get_sint16, -2048, "sint16 = -2048"; $foo->uint8(48); is $foo->get_uint8, 48, "uint8 = 48"; $foo->sint8(-48); is $foo->get_sint8, -48, "sint8 = -48"; $foo->float(1.5); is $foo->get_float, 1.5, "float = 1.5"; $foo->double(-1.5); is $foo->get_double, -1.5, "double = -1.5"; my $ptr = malloc 32; $foo->opaque($ptr); is $foo->get_opaque, $ptr, "get_opaque = $ptr"; is $foo->opaque, $ptr, "opaque = $ptr"; $foo->opaque(undef); is $foo->get_opaque, undef, "get_opaque = undef"; is $foo->opaque, undef, "opaque = undef"; free $ptr; }; subtest 'same name' => sub { plan tests => 1; eval { package Foo3; use FFI::Platypus::Record; record_layout int => 'foo', int => 'foo', ; }; isnt $@, '', 'two members of the same name not allowed'; note $@ if $@; }; do { package Foo4; use FFI::Platypus::Record; record_layout(qw( char : uint64_t[3] uint64 char : uint32_t[3] uint32 char : uint16_t[3] uint16 char : uint8_t[3] uint8 char : int64_t[3] sint64 char : int32_t[3] sint32 char : int16_t[3] sint16 char : int8_t[3] sint8 char : float[3] float char : double[3] double char : opaque[3] opaque )); my $ffi = FFI::Platypus->new; $ffi->find_lib(lib => 'test', symbol => 'f0', libpath => 'libtest'); $ffi->attach(["align_array_get_$_" => "get_$_"] => [ 'record(Foo4)' ] => "${_}[3]" ) for qw( uint8 sint8 uint16 sint16 uint32 sint32 uint64 sint64 float double opaque ); }; subtest 'array alignment' => sub { plan tests => 14; my $foo = Foo4->new; isa_ok $foo, 'Foo4'; foreach my $bits (qw( 8 16 32 64 )) { subtest "unsigned $bits integer" => sub { plan tests => 4; my $acc1 = "uint$bits"; my $acc2 = "get_uint$bits"; $foo->$acc1([1,2,3]); is_deeply $foo->$acc1, [1,2,3], "$acc1 = 1,2,3"; is_deeply $foo->$acc2, [1,2,3], "$acc2 = 1,2,3"; is $foo->$acc1(1), 2, "$acc1(1) = 2"; $foo->$acc1(1,20); is_deeply $foo->$acc1, [1,20,3], "$acc1 = 1,20,3"; }; subtest "signed $bits integer" => sub { plan tests => 4; my $acc1 = "sint$bits"; my $acc2 = "get_sint$bits"; $foo->$acc1([-1,2,-3]); is_deeply $foo->$acc1, [-1,2,-3], "$acc1 = -1,2,-3"; is_deeply $foo->$acc2, [-1,2,-3], "$acc2 = -1,2,-3"; is $foo->$acc1(2), -3, "$acc1(2) = -3"; $foo->$acc1(1,-20); is_deeply $foo->$acc1, [-1,-20,-3], "$acc1 = -1,-20,-3"; }; } foreach my $type (qw( float double )) { subtest $type => sub { plan tests => 5; $foo->$type([1.5,undef,-1.5]); is_deeply $foo->$type, [1.5,0.0,-1.5], "$type = 1.5,0,-1.5"; is $foo->$type(0), 1.5; is $foo->$type(1), 0.0; is $foo->$type(2), -1.5; $foo->$type(1,20.0); is_deeply $foo->$type, [1.5,20.0,-1.5], "$type = 1.5,20,-1.5"; }; } subtest 'opaque' => sub { plan tests => 6; my $ptr1 = malloc 32; my $ptr2 = malloc 64; $foo->opaque([$ptr1,undef,$ptr2]); is_deeply $foo->opaque, [$ptr1,undef,$ptr2], "opaque = $ptr1,undef,$ptr2"; $foo->opaque(1,$ptr1); is_deeply $foo->opaque, [$ptr1,$ptr1,$ptr2], "opaque = $ptr1,$ptr1,$ptr2"; $foo->opaque(0,undef); is_deeply $foo->opaque, [undef,$ptr1,$ptr2], "opaque = undef,$ptr1,$ptr2"; is $foo->opaque(0), undef; is $foo->opaque(1), $ptr1; is $foo->opaque(2), $ptr2; free $ptr1; free $ptr2; }; my $align = $foo->_ffi_record_align; like $align, qr{^[0-9]+$}, "align = $align"; ok $align > 0, "align is positive"; }; do { package Foo5; use FFI::Platypus::Record; record_layout(qw( char : string value )); my $ffi = FFI::Platypus->new; $ffi->find_lib(lib => 'test', symbol => 'f0', libpath => 'libtest'); $ffi->attach( [align_string_get_value => 'get_value'] => ['record(Foo5)'] => 'string', ); $ffi->attach( [align_string_set_value => 'set_value'] => ['record(Foo5)','string'] => 'void', ); }; subtest 'string ro' => sub { plan tests => 8; my $foo = Foo5->new; isa_ok $foo, 'Foo5'; is $foo->value, undef, 'foo.value = undef'; is $foo->get_value, undef, 'foo.get_value = undef'; $foo->set_value("my value"); is $foo->value, 'my value', 'foo.value = my value'; is $foo->get_value, 'my value', 'foo.get_value = my value'; eval { $foo->value("stuff") }; isnt $@, '', 'value is ro'; note $@ if $@; $foo->set_value(undef); is $foo->value, undef, 'foo.value = undef'; is $foo->get_value, undef, 'foo.get_value = undef'; }; do { package Foo6; use FFI::Platypus::Record; record_layout(qw( char : string(10) value )); my $ffi = FFI::Platypus->new; $ffi->find_lib(lib => 'test', symbol => 'f0', libpath => 'libtest'); $ffi->attach([align_fixed_get_value=>'get_value'] => ['record(Foo6)'] => 'string'); }; subtest 'fixed string' => sub { plan tests => 6; my $foo = Foo6->new; isa_ok $foo, 'Foo6'; is $foo->value, "\0\0\0\0\0\0\0\0\0\0", 'foo.value = "\\0\\0\\0\\0\\0\\0\\0\\0\\0\\0"'; is $foo->get_value, "", 'foo.get_value = ""'; $foo->value("one two three four five six seven eight"); is $foo->value, "one two th", 'foo.value = "one two th"'; $foo->value("123456789\0"); is $foo->value, "123456789\0", "foo.value = 123456789\\0"; is $foo->get_value, "123456789", "foo.get_value = 123456789"; }; do { package Foo7; use FFI::Platypus::Record; record_layout(qw( char : string_rw value )); my $ffi = FFI::Platypus->new; $ffi->find_lib(lib => 'test', symbol => 'f0', libpath => 'libtest'); $ffi->attach( [align_string_get_value => 'get_value'] => ['record(Foo7)'] => 'string' ); }; subtest 'string rw' => sub { plan tests => 7; my $foo = Foo7->new; isa_ok $foo, 'Foo7'; $foo->value('hi there'); is $foo->value, "hi there", "foo.value = hi there"; is $foo->get_value, 'hi there', 'foo.get_value = hi there'; $foo->value(undef); is $foo->value, undef, 'foo.value = undef'; is $foo->get_value, undef, 'foo.get_value = undef'; $foo->value('starscream!!!'); is $foo->value, "starscream!!!", "foo.value = starscream!!!"; is $foo->get_value, 'starscream!!!', 'foo.get_value = starscream!!!'; }; type_complex_double.t100644001750001750 267713065045605 20427 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib; BEGIN { plan skip_all => 'test requires support for double complex' unless FFI::Platypus::_have_type('complex_double'); } use FFI::Platypus::Declare 'complex_double', 'double', 'string'; plan tests => 1; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach ['complex_double_get_real' => 'creal'] => [complex_double] => double; attach ['complex_double_get_imag' => 'cimag'] => [complex_double] => double; attach ['complex_double_to_string' => 'to_string'] => [complex_double] => string; subtest 'standard argument' => sub { plan tests => 3; subtest 'with a real number' => sub { plan tests => 2; note "to_string(10.5) = ", to_string(10.5); is creal(10.5), 10.5, "creal(10.5) = 10.5"; is cimag(10.5), 0.0, "cimag(10.5) = 0.0"; }; subtest 'with an array ref' => sub { plan tests => 2; note "to_string([10.5,20.5]) = ", to_string([10.5,20.5]); is creal([10.5,20.5]), 10.5, "creal([10.5,20.5]) = 10.5"; is cimag([10.5,20.5]), 20.5, "cimag([10.5,20.5]) = 20.5"; }; subtest 'with Math::Complex' => sub { plan skip_all => 'test requires Math::Complex' unless eval q{ use Math::Complex (); 1 }; plan tests => 2; my $c = Math::Complex->make(10.5, 20.5); note "to_string(\$c) = ", to_string($c); is creal($c), 10.5, "creal(\$c) = 10.5"; is cimag($c), 20.5, "cimag(\$c) = 20.5"; }; }; ffi_platypus_memory.t100644001750001750 131013065045605 20441 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More; use FFI::Platypus; use FFI::Platypus::Memory; my $ffi = FFI::Platypus->new; $ffi->lib(undef); # TODO: break this subtest up into one for # malloc, calloc, memset and free subtest 'malloc calloc memset free' => sub { my $ptr1 = malloc 22; ok $ptr1, "malloc returns $ptr1"; memset $ptr1, 0, 22; memset $ptr1, ord 'x', 8; memset $ptr1, ord 'y', 4; my $ptr2 = calloc 9, $ffi->sizeof('char'); ok $ptr2, "calloc returns $ptr2"; my $string = $ffi->function(strcpy => ['opaque', 'opaque'] => 'string')->call($ptr2, $ptr1); is $string, 'yyyyxxxx', 'string = yyyyxxxx'; free $ptr1; ok 1, 'free $ptr1'; free $ptr2; ok 1, 'free $ptr2'; }; done_testing; ffi_platypus_attach.t100644001750001750 143613065045605 20406 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 5; use FFI::Platypus; use FFI::CheckLib; my $ffi = FFI::Platypus->new; $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'); $ffi->attach('f0' => ['uint8'] => 'uint8'); $ffi->attach([f0=>'f1'] => ['uint8'] => 'uint8'); $ffi->attach([f0=>'Roger::f1'] => ['uint8'] => 'uint8'); is f0(22), 22, 'f0(22) = 22'; is f1(22), 22, 'f1(22) = 22'; is Roger::f1(22), 22, 'Roger::f1(22) = 22'; $ffi->attach([f0 => 'f0_wrap'] => ['uint8'] => uint8 => sub { my($inner, $value) = @_; return $inner->($value+1)+2; }); $ffi->attach([f0 => 'f0_wrap2'] => ['uint8'] => uint8 => '$' => sub { my($inner, $value) = @_; return $inner->($value+1)+2; }); is f0_wrap(22), 25, 'f0_wrap(22) = 25'; is f0_wrap2(22), 25, 'f0_wrap(22) = 25'; ffi_platypus_buffer.t100644001750001750 136713065045605 20416 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use utf8; use open ':std', ':encoding(utf8)'; use Test::More tests => 2; use Encode qw( decode ); use FFI::Platypus::Buffer qw( scalar_to_buffer buffer_to_scalar ); subtest simple => sub { plan tests => 3; my $orig = 'me grimlock king'; my($ptr, $size) = scalar_to_buffer($orig); ok $ptr, "ptr = $ptr"; is $size, 16, 'size = 16'; my $scalar = buffer_to_scalar($ptr, $size); is $scalar, 'me grimlock king', "scalar = $scalar"; }; subtest unicode => sub { plan tests => 3; my $orig = 'привет'; my($ptr, $size) = scalar_to_buffer($orig); ok $ptr, "ptr = $ptr"; ok $size, "size = $size"; my $scalar = decode('UTF-8', buffer_to_scalar($ptr, $size)); is $scalar, 'привет', "scalar = $scalar"; }; time_record.pl100644001750001750 154013065045605 20370 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; package My::UnixTime; use FFI::Platypus::Record; record_layout(qw( int tm_sec int tm_min int tm_hour int tm_mday int tm_mon int tm_year int tm_wday int tm_yday int tm_isdst long tm_gmtoff string tm_zone )); my $ffi = FFI::Platypus->new; $ffi->lib(undef); # define a record class My::UnixTime and alias it to "tm" $ffi->type("record(My::UnixTime)" => 'tm'); # attach the C localtime function as a constructor $ffi->attach( localtime => ['time_t*'] => 'tm', sub { my($inner, $class, $time) = @_; $time = time unless defined $time; $inner->(\$time); }); package main; # now we can actually use our My::UnixTime class my $time = My::UnixTime->localtime; printf "time is %d:%d:%d %s\n", $time->tm_hour, $time->tm_min, $time->tm_sec, $time->tm_zone; after_build2.pl100644001750001750 45113065045605 20155 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/runuse strict; use warnings; use autodie qw( :all ); my $content; open my $in, '<', 'Build.PL'; while(<$in>) { s/^(# This file was automatically generated by Dist::Zilla::Plugin::ModuleBuild).*$/$1/; $content .= $_; } close $in; open my $out, '>', 'Build.PL'; print $out $content; close $out; before_build.pl100644001750001750 462713065045605 20265 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/runuse strict; use warnings; use lib '.'; use inc::My::Dev; use File::Spec; if(@ARGV > 0) { if(-e 'Build') { if($^O eq 'MSWin32') { print "> Build distclean\n"; system 'Build', 'distclean'; } else { print "% ./Build distclean\n"; system './Build', 'distclean'; } } My::Dev->clean; } foreach my $bits (qw( 16 32 64 )) { foreach my $orig (qw( libtest/uint8.c libtest/sint8.c t/type_uint8.t t/type_sint8.t )) { my $new = $orig; $new =~ s/8/$bits/; open my $in, '<', $orig; open my $out, '>', $new; if($orig =~ /\.c$/) { print $out join "\n", "/*", " * DO NOT MODIFY THIS FILE.", " * Thisfile generated from similar file $orig", " * all instances of \"int8\" have been changed to \"int$bits\"", " */", ""; } else { print $out join "\n", "#", "# DO NOT MODIFY THIS FILE.", "# Thisfile generated from similar file $orig", "# all instances of \"int8\" have been changed to \"int$bits\"", "#", ""; } while(<$in>) { s/int8/"int$bits"/eg; print $out $_; } close $out; close $in; } } foreach my $type (qw( double )) { foreach my $orig (qw( libtest/float.c t/type_float.t )) { my $new = $orig; $new =~ s/float/$type/; open my $in, '<', $orig; open my $out, '>', $new; if($orig =~ /\.c$/) { print $out join "\n", "/*", " * DO NOT MODIFY THIS FILE.", " * Thisfile generated from similar file $orig", " * all instances of \"float\" have been changed to \"$type\"", " */", ""; } else { print $out join "\n", "#", "# DO NOT MODIFY THIS FILE.", "# Thisfile generated from similar file $orig", "# all instances of \"float\" have been changed to \"$type\"", "#", ""; } while(<$in>) { s/float/$type/eg; print $out $_; } close $out; close $in; } } bigendian64.c100644001750001750 70413065045605 20020 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/probe#include "ffi_platypus.h" unsigned char my_foo(void) { return 0xaa; } int main(int argc, char *argv[]) { ffi_cif cif; ffi_type *args[1]; void *values[1]; unsigned char bytes[8] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 }; if(ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 0, &ffi_type_uint8, args) ==FFI_OK) { ffi_call(&cif, (void *) my_foo, &bytes, values); if(bytes[7] == 0xaa) { return 0; } } return 2; } Platypus000755001750001750 013065045605 16554 5ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFIAPI.pm100644001750001750 1220613065045605 17704 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFI/Platypuspackage FFI::Platypus::API; use strict; use warnings; use FFI::Platypus; use base qw( Exporter ); our @EXPORT = grep /^arguments_/, keys %FFI::Platypus::API::; # ABSTRACT: Platypus arguments and return value API for custom types our $VERSION = '0.47'; # VERSION 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::API - Platypus arguments and return value API for custom types =head1 VERSION version 0.47 =head1 SYNOPSIS package FFI::Platypus::Type::MyCustomType; use FFI::Platypus::API; sub ffi_custom_type_api_1 { { native_type => 'uint32', perl_to_native => sub { my($value, $i) = @_; # Translates ($value) passed in from Perl # into ($value+1, $value+2) arguments_set_uint32($i, $value+1); arguments_set_uint32($i+1, $value+2); }, argument_count => 2, } } =head1 DESCRIPTION The custom types API for L allows you to set multiple C arguments from a single Perl argument as a common type. This is sometimes useful for pointer / size pairs which are a common pattern in C, but are usually represented by a single value (a string scalar) in Perl. The custom type API is somewhat experimental, and you should expect some changes as needs arise (I won't break compatibility lightly, however). =head1 FUNCTIONS These functions are only valid within a custom type callback. =head2 arguments_count my $count = argument_count; Returns the total number of native arguments. =head2 arguments_get_sint8 my $sint8 = arguments_get_sint8 $i; Get the 8 bit signed integer argument from position I<$i>. =head2 arguments_set_sint8 arguments_set_sint8 $i, $sint8; Set the 8 bit signed integer argument at position I<$i> to I<$sint8>. =head2 arguments_get_uint8 my $uint8 = arguments_get_uint8 $i; Get the 8 bit unsigned integer argument from position I<$i>. =head2 arguments_set_uint8 arguments_set_uint8 $i, $uint8; Set the 8 bit unsigned integer argument at position I<$i> to I<$uint8>. =head2 arguments_get_sint16 my $sint16 = arguments_get_sint16 $i; Get the 16 bit signed integer argument from position I<$i>. =head2 arguments_set_sint16 arguments_set_sint16 $i, $sint16; Set the 16 bit signed integer argument at position I<$i> to I<$sint16>. =head2 arguments_get_uint16 my $uint16 = arguments_get_uint16 $i; Get the 16 bit unsigned integer argument from position I<$i>. =head2 arguments_set_uint16 arguments_set_uint16 $i, $uint16; Set the 16 bit unsigned integer argument at position I<$i> to I<$uint16>. =head2 arguments_get_sint32 my $sint32 = arguments_get_sint32 $i; Get the 32 bit signed integer argument from position I<$i>. =head2 arguments_set_sint32 arguments_set_sint32 $i, $sint32; Set the 32 bit signed integer argument at position I<$i> to I<$sint32>. =head2 arguments_get_uint32 my $uint32 = arguments_get_uint32 $i; Get the 32 bit unsigned integer argument from position I<$i>. =head2 arguments_set_uint32 arguments_set_uint32 $i, $uint32; Set the 32 bit unsigned integer argument at position I<$i> to I<$uint32>. =head2 arguments_get_sint64 my $sint64 = arguments_get_sint64 $i; Get the 64 bit signed integer argument from position I<$i>. =head2 arguments_set_sint64 arguments_set_sint64 $i, $sint64; Set the 64 bit signed integer argument at position I<$i> to I<$sint64>. =head2 arguments_get_uint64 my $uint64 = arguments_get_uint64 $i; Get the 64 bit unsigned integer argument from position I<$i>. =head2 arguments_set_uint64 arguments_set_uint64 $i, $uint64; Set the 64 bit unsigned integer argument at position I<$i> to I<$uint64>. =head2 arguments_get_float my $float = arguments_get_float $i; Get the floating point argument from position I<$i>. =head2 arguments_set_float arguments_set_float $i, $float; Set the floating point argument at position I<$i> to I<$float> =head2 arguments_get_double my $double = arguments_get_double $i; Get the double precision floating point argument from position I<$i>. =head2 arguments_set_double arguments_set_double $i, $double; Set the double precision floating point argument at position I<$i> to I<$double> =head2 arguments_get_pointer my $pointer = arguments_get_pointer $i; Get the pointer argument from position I<$i>. =head2 arguments_set_pointer arguments_set_pointer $i, $pointer; Set the pointer argument at position I<$i> to I<$pointer>. =head2 arguments_get_string my $string = arguments_get_string $i; Get the string argument from position I<$i>. =head2 arguments_set_string arguments_set_string $i, $string; Set the string argument at position I<$i> to I<$string>. =head1 SEE ALSO =over 4 =item L =back Examples of use: =over 4 =item L =back =head1 AUTHOR Author: Graham Ollis Eplicease@cpan.orgE Contributors: Bakkiaraj Murugesan (bakkiaraj) Dylan Cali (calid) pipcet Zaki Mughal (zmughal) Fitz Elliott (felliott) Vickenty Fesunov (vyf) Gregor Herrmann (gregoa) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Graham Ollis. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut complex_float.c100644001750001750 57113065045605 20352 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/libtest#include "libtest.h" #if SIZEOF_FLOAT_COMPLEX EXTERN float complex_float_get_real(float complex f) { return crealf(f); } EXTERN float complex_float_get_imag(float complex f) { return cimagf(f); } EXTERN const char * complex_float_to_string(float complex f) { static char buffer[1024]; sprintf(buffer, "%g + %g * i", crealf(f), cimagf(f)); return buffer; } #endif ffi_platypus_closure.t100644001750001750 75113065045605 20575 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 6; use FFI::Platypus; my $ffi = FFI::Platypus->new; my $closure = $ffi->closure(sub { $_[0] + 1}); isa_ok $closure, 'FFI::Platypus::Closure'; is $closure->(1), 2, 'closure.(1) = 2'; my $c = sub { $_[0] + 2 }; $closure = $ffi->closure($c); isa_ok $closure, 'FFI::Platypus::Closure'; is $closure->(1), 3, 'closure.(1) = 3'; $closure = $ffi->closure($c); isa_ok $closure, 'FFI::Platypus::Closure'; is $closure->(1), 3, 'closure.(1) = 3'; ffi_platypus_alignof.t100644001750001750 276313065045605 20565 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 4; use FFI::Platypus; my $ffi = FFI::Platypus->new; my $pointer_align = $ffi->alignof('opaque'); subtest 'ffi types' => sub { plan tests => 45; foreach my $type (qw( sint8 uint8 sint16 uint16 sint32 uint32 sint64 uint64 float double opaque string )) { my $align = $ffi->alignof($type); like $align, qr{^[0-9]$}, "alignof $type = $align"; next if $type eq 'string'; my $align2 = $ffi->alignof("$type [2]"); is $align2, $align, "alignof $type [2] = $align"; my $align3 = $ffi->alignof("$type *"); is $align3, $pointer_align, "alignof $type * = $pointer_align"; $ffi->custom_type("custom_$type" => { native_type => $type, native_to_perl => sub {}, }); my $align4 = $ffi->alignof("custom_$type"); is $align4, $align, "alignof custom_$type = $align"; } }; subtest 'aliases' => sub { plan tests => 2; $ffi->type('ushort' => 'foo'); my $align = $ffi->alignof('ushort'); like $align, qr{^[0-9]$}, "alignof ushort = $align"; my $align2 = $ffi->alignof('foo'); is $align2, $align, "alignof foo = $align"; }; subtest 'closure' => sub { plan tests => 1; $ffi->type('(int)->int' => 'closure_t'); my $align = $ffi->alignof('closure_t'); is $align, $pointer_align, "sizeof closure_t = $pointer_align"; }; subtest 'record' => sub { plan tests => 1; eval { $ffi->alignof('record(22)') }; isnt $@, '', "generic record alignment not supported"; note $@; }; ffi_platypus_declare.t100644001750001750 262713065045605 20544 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 3; do { package Normal; use FFI::CheckLib; use FFI::Platypus::Declare; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach 'f0', ['uint8'] => 'uint8'; attach [f0 => 'f1'], ['uint8'] => 'uint8'; attach [f0 => 'f0_wrap'] => ['uint8'] => 'uint8' => sub { my($inner, $value) = @_; $inner->($value+1)+2; }; attach [f0 => 'f0_wrap2'] => ['uint8'] => 'uint8' => '$' => sub { my($inner, $value) = @_; $inner->($value+1)+2; }; }; subtest normal => sub { plan tests => 4; is Normal::f0(22), 22, 'f0(22) = 22'; is Normal::f1(22), 22, 'f1(22) = 22'; is Normal::f0_wrap(22), 25, 'f0_wrap(22) = 25'; is Normal::f0_wrap2(22), 25, 'f0_wrap2(22) = 25'; }; do { package WithTypeAliases; use FFI::CheckLib; use FFI::Platypus::Declare 'string', [int => 'myint']; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach [my_atoi=>'atoi'], [string] => myint; }; subtest 'with type aliases' => sub { plan tests => 1; is WithTypeAliases::atoi("42"), 42, 'atoi("42") = 42'; }; do { package ClosureSimple; use FFI::Platypus::Declare; our $closure = closure { $_[0]+1 }; }; subtest 'simple closure test' => sub { plan tests => 2; isa_ok $ClosureSimple::closure, 'FFI::Platypus::Closure'; is $ClosureSimple::closure->(1), 2, 'closure.(1) = 2'; }; example.pl100644001750001750 103213065045605 20444 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examples/javause strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib('./libexample.so'); # Java methods are mangled by gcj using the same format as g++ $ffi->attach( [ _ZN7Example11print_helloEJvv => 'print_hello' ] => [] => 'void' ); $ffi->attach( [ _ZN7Example3addEJiii => 'add' ] => ['int', 'int'] => 'int' ); # Initialize the Java runtime $ffi->function( gcj_start => [] => 'void' )->call; print_hello(); print add(1,2), "\n"; # Wind the java runtime down $ffi->function( gcj_end => [] => 'void' )->call; accessor.tt100644001750001750 424313065045605 20463 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/template XS(ffi_pl_record_accessor_[% ffi_type %]) { ffi_pl_record_member *member; SV *self; char *ptr1; [% c_type %] *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); if(!SvOK(self)) croak("Null record error"); ptr1 = (char*) SvPV_nolen(self); ptr2 = ([% c_type %]*) &ptr1[member->offset]; if(items > 1) *ptr2 = ([% c_type %]) Sv[% perl_type %](ST(1)); if(GIMME_V == G_VOID) XSRETURN_EMPTY; XSRETURN_[% perl_type %](*ptr2); } XS(ffi_pl_record_accessor_[% ffi_type %]_array) { ffi_pl_record_member *member; SV *self; SV *arg; SV **item; AV *av; char *ptr1; int i; [% c_type %] *ptr2; dVAR; dXSARGS; if(items == 0) croak("This is a method, you must provide at least the object"); member = (ffi_pl_record_member*) CvXSUBANY(cv).any_ptr; self = ST(0); if(SvROK(self)) self = SvRV(self); ptr1 = (char*) SvPV_nolen(self); ptr2 = ([% c_type %]*) &ptr1[member->offset]; if(items > 2) { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { arg = ST(2); ptr2[i] = Sv[% perl_type %](arg); } else { warn("illegal index %d", i); } } else if(items > 1) { arg = ST(1); if(SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) { av = (AV*) SvRV(arg); for(i=0; i < member->count; i++) { item = av_fetch(av, i, 0); if(item != NULL && SvOK(*item)) { ptr2[i] = Sv[% perl_type %](*item); } else { ptr2[i] = [% zero %]; } } } else { i = SvIV(ST(1)); if(i >= 0 && i < member->count) { XSRETURN_[% perl_type %](ptr2[i]); } else { warn("illegal index %d", i); XSRETURN_EMPTY; } } } if(GIMME_V == G_VOID) XSRETURN_EMPTY; av = newAV(); av_fill(av, member->count-1); for(i=0; i < member->count; i++) { sv_set[% perl_type | lower %](*av_fetch(av, i, 1), ptr2[i]); } ST(0) = newRV_inc((SV*)av); XSRETURN(1); } test_examples.pl100644001750001750 205513065045605 20512 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/runuse strict; use warnings; use File::chdir; use File::Glob qw( bsd_glob ); use File::Temp qw( tempdir ); my $lib = tempdir( CLEANUP => 1 ); my @cmd = ( 'cpanm', '-n', '-l' => $lib, 'FFI::TinyCC', 'FFI::Platypus::Type::StringArray', ); print "+ @cmd\n"; system @cmd; exit 2 if $?; do { local $CWD = 'examples'; foreach my $cfile (bsd_glob '*.c') { my $sofile = $cfile; $sofile =~ s{\.c$}{.so}; my @cmd = ('cc', '-fPIC', '-shared', -o => $sofile, $cfile); print "+ @cmd\n"; system @cmd; exit 2 if $?; } foreach my $plfile (bsd_glob '*.pl') { next if $plfile =~ /^win32_/; my @cmd = ( $^X, "-Mlocal::lib=$lib", $plfile ); print "+ @cmd\n"; system @cmd; exit 2 if $?; } }; do { local $CWD = 'examples/java'; do { my @cmd = ('make'); print "+ @cmd\n"; system @cmd; exit 2 if $?; }; foreach my $plfile (bsd_glob '*.pl') { next if $plfile =~ /^win32_/; my @cmd = ( $^X, "-Mlocal::lib=$lib", $plfile ); print "+ @cmd\n"; system @cmd; exit 2 if $?; } }; complex_double.c100644001750001750 57613065045605 20524 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/libtest#include "libtest.h" #if SIZEOF_DOUBLE_COMPLEX EXTERN double complex_double_get_real(double complex f) { return creal(f); } EXTERN double complex_double_get_imag(double complex f) { return cimag(f); } EXTERN const char * complex_double_to_string(double complex f) { static char buffer[1024]; sprintf(buffer, "%g + %g * i", creal(f), cimag(f)); return buffer; } #endif pod_coverage.t100644001750001750 363013065045605 20502 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xt/authoruse strict; use warnings; use Test::More; BEGIN { plan skip_all => 'test requires 5.010 or better' unless $] >= 5.010; plan skip_all => 'test requires Test::Pod::Coverage' unless eval q{ use Test::Pod::Coverage; 1 }; plan skip_all => 'test requires YAML' unless eval q{ use YAML; 1; }; }; use Test::Pod::Coverage; use YAML qw( LoadFile ); use FindBin; use File::Spec; my $config_filename = File::Spec->catfile( $FindBin::Bin, File::Spec->updir, File::Spec->updir, 'author.yml' ); my $config; $config = LoadFile($config_filename) if -r $config_filename; plan skip_all => 'disabled' if $config->{pod_coverage}->{skip}; chdir(File::Spec->catdir($FindBin::Bin, File::Spec->updir, File::Spec->updir)); my @private_classes; my %private_methods; push @{ $config->{pod_coverage}->{private} }, 'Alien::.*::Install::Files#Inline'; foreach my $private (@{ $config->{pod_coverage}->{private} }) { my($class,$method) = split /#/, $private; if(defined $class && $class ne '') { my $regex = eval 'qr{^' . $class . '$}'; if(defined $method && $method ne '') { push @private_classes, { regex => $regex, method => $method }; } else { push @private_classes, { regex => $regex, all => 1 }; } } elsif(defined $method && $method ne '') { $private_methods{$_} = 1 for split /,/, $method; } } my @classes = all_modules; plan tests => scalar @classes; foreach my $class (@classes) { SKIP: { my($is_private_class) = map { 1 } grep { $class =~ $_->{regex} && $_->{all} } @private_classes; skip "private class: $class", 1 if $is_private_class; my %methods = map {; $_ => 1 } map { split /,/, $_->{method} } grep { $class =~ $_->{regex} } @private_classes; $methods{$_} = 1 for keys %private_methods; my $also_private = eval 'qr{^' . join('|', keys %methods ) . '$}'; pod_coverage_ok $class, { also_private => [$also_private] }; }; } ffi_platypus_function.t100644001750001750 176513065045605 20774 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 2; use FFI::Platypus; use FFI::CheckLib; subtest 'built in type' => sub { plan tests => 4; my $ffi = FFI::Platypus->new; $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'); my $function = eval { $ffi->function('f0', [ 'uint8' ] => 'uint8') }; is $@, '', 'ffi.function(f0, [uint8] => uint8)'; isa_ok $function, 'FFI::Platypus::Function'; is $function->call(22), 22, 'function.call(22) = 22'; is $function->(22), 22, 'function.(22) = 22'; }; subtest 'custom type' => sub { plan tests => 4; my $ffi = FFI::Platypus->new; $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'); $ffi->type('uint8' => 'my_int_8'); my $function = eval { $ffi->function('f0', [ 'my_int_8' ] => 'my_int_8') }; is $@, '', 'ffi.function(f0, [my_int_8] => my_int_8)'; isa_ok $function, 'FFI::Platypus::Function'; is $function->call(22), 22, 'function.call(22) = 22'; is $function->(22), 22, 'function.(22) = 22'; } ffi_platypus_find_lib.t100644001750001750 40713065045605 20665 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 1; use File::Spec; use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->find_lib(lib => 'test', symbol => 'f0', libpath => 'libtest'); my $address = $ffi->find_symbol('f0'); ok $address, "found f0 = $address"; between.cpp100644001750001750 44713065045605 20602 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examples/java#include #include #include #include extern "C" void gcj_start() { using namespace java::lang; JvCreateJavaVM(NULL); JvInitClass(&System::class$); } extern "C" void gcj_end() { JvDetachCurrentThread(); } perl_math_int64.h100644001750001750 414413065045605 20517 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/include/* * perl_math_int64.h - This file is in the public domain * Author: Salvador Fandino * Version: 2.1 * * Generated on: 2014-10-30 11:43:56 * Math::Int64 version: 0.33 * Module::CAPIMaker version: 0.02 */ #if !defined (PERL_MATH_INT64_H_INCLUDED) #define PERL_MATH_INT64_H_INCLUDED #define MATH_INT64_C_API_REQUIRED_VERSION 2 #define MATH_INT64_VERSION MATH_INT64_C_API_REQUIRED_VERSION int perl_math_int64_load(int required_version); #define PERL_MATH_INT64_LOAD perl_math_int64_load(MATH_INT64_C_API_REQUIRED_VERSION) #define PERL_MATH_INT64_LOAD_OR_CROAK \ if (PERL_MATH_INT64_LOAD); \ else croak(NULL); #define MATH_INT64_BOOT PERL_MATH_INT64_LOAD_OR_CROAK extern HV *math_int64_c_api_hash; extern int math_int64_c_api_min_version; extern int math_int64_c_api_max_version; #define math_int64_capi_version math_int64_c_api_max_version #if (defined(MATH_INT64_NATIVE_IF_AVAILABLE) && (IVSIZE == 8)) #define MATH_INT64_NATIVE 1 #endif extern int64_t (*math_int64_c_api_SvI64)(pTHX_ SV*); #define SvI64(a) ((*math_int64_c_api_SvI64)(aTHX_ (a))) extern int (*math_int64_c_api_SvI64OK)(pTHX_ SV*); #define SvI64OK(a) ((*math_int64_c_api_SvI64OK)(aTHX_ (a))) extern uint64_t (*math_int64_c_api_SvU64)(pTHX_ SV*); #define SvU64(a) ((*math_int64_c_api_SvU64)(aTHX_ (a))) extern int (*math_int64_c_api_SvU64OK)(pTHX_ SV*); #define SvU64OK(a) ((*math_int64_c_api_SvU64OK)(aTHX_ (a))) extern SV * (*math_int64_c_api_newSVi64)(pTHX_ int64_t); #define newSVi64(a) ((*math_int64_c_api_newSVi64)(aTHX_ (a))) extern SV * (*math_int64_c_api_newSVu64)(pTHX_ uint64_t); #define newSVu64(a) ((*math_int64_c_api_newSVu64)(aTHX_ (a))) extern uint64_t (*math_int64_c_api_randU64)(pTHX); #define randU64() ((*math_int64_c_api_randU64)(aTHX)) #if MATH_INT64_NATIVE #undef newSVi64 #define newSVi64 newSViv #undef newSVu64 #define newSVu64 newSVuv #define sv_seti64 sv_setiv_mg #define sv_setu64 sv_setuv_mg #else #define sv_seti64(target, i64) (sv_setsv_mg(target, sv_2mortal(newSVi64(i64)))) #define sv_setu64(target, u64) (sv_setsv_mg(target, sv_2mortal(newSVu64(u64)))) #endif #endifType.pod100644001750001750 7431213065045605 20370 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFI/Platypus# PODNAME: FFI::Platypus::Type # ABSTRACT: Defining types for FFI::Platypus # VERSION __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Type - Defining types for FFI::Platypus =head1 VERSION version 0.47 =head1 SYNOPSIS OO Interface: use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->type('int' => 'my_int'); =head1 DESCRIPTION This document describes how to define types using L. Types may be "defined" ahead of time, or simply used when defining or attaching functions. # OO example of defining types use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->type('int'); $ffi->type('string'); # OO example of simply using types in function declaration or attachment my $f = $ffi->function(puts => ['string'] => 'int'); $ffi->attach(puts => ['string'] => 'int'); If you are using the declarative interface, you can either pass the types you need to the L C invocation, or you can use the L function. The advantage of the former is that it creates a Perl constant for that type so that you do not need to use quotation marks when using the type. # Declarative with use use FFI::Platypus::Declare 'string', 'int'; attach puts => [string] => int; # Declarative with type use FFI::Platypus::Declare; type 'string'; type 'int'; attach puts => ['string'] => 'int'; Unless you are using aliases the L method or L function are not necessary, but they will throw an exception if the type is incorrectly specified or not supported, which may be helpful. Note: This document sometimes uses the term "C Function" as short hand for function implemented in a compiled language. Unless the term is referring literally to a C function example code, you can assume that it should also work with another compiled language. =head2 meta information about types You can get the size of a type using the L method. # OO interface my $intsize = $ffi->sizeof('int'); my intarraysize = $ffi->sizeof('int[64]'); # Declare interface my $intsize = sizeof 'int'; my intarraysize = sizeof 'int[64]'; =head2 converting types Sometimes it is necessary to convert types. In particular various pointer types often need to be converted for consumption in Perl. For this purpose the L method is provided. It needs to be used with care though, because not all type combinations are supported. Here are some useful ones: # OO interface my $address = $ffi->cast('string' => 'opaque', $string); my $string = $ffi->cast('opaque' => 'string', $pointer); # Declare interface use FFI::Platypus::Declare; my $address = cast 'string' => 'opaque', $string; my $string = cast 'opaque' => 'string', $pointer; =head2 aliases Some times using alternate names is useful for documenting the purpose of an argument or return type. For this "aliases" can be helpful. The second argument to the L method or L function can be used to define a type alias that can later be used by function declaration and attachment. # OO style use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->type('int' => 'myint'); $ffi->type('string' => 'mystring'); my $f = $ffi->function( puts => ['mystring'] => 'myint' ); $ffi->attach( puts => ['mystring'] => 'myint' ); # Declarative style use FFI::Platypus::Declare; type 'int' => 'myint'; type 'string' => 'mystring'; attach puts => ['mystring'] => 'myint'; # Declarative style with use (and with fewer quotes) use FFI::Platypus::Declare [ int => 'myint' ], [ string => 'mystring' ]; attach puts => [mystring] => myint; Aliases are contained without the L object, or the current package if you are using L, so feel free to define your own crazy types without stepping on the toes of other CPAN Platypus developers. =for stopwords tm =head1 TYPE CATEGORIES =head2 Native types So called native types are the types that the CPU understands that can be passed on the argument stack or returned by a function. It does not include more complicated types like arrays or structs, which can be passed via pointers (see the opaque type below). Generally native types include void, integers, floats and pointers. =head3 the void type This can be used as a return value to indicate a function does not return a value (or if you want the return value to be ignored). =head3 integer types The following native integer types are always available (parentheticals indicates the usual corresponding C type): =over 4 =item sint8 Signed 8 bit byte (C, C). =item uint8 Unsigned 8 bit byte (C, C). =item sint16 Signed 16 bit integer (C, C) =item uint16 Unsigned 16 bit integer (C, C) =item sint32 Signed 32 bit integer (C, C) =item uint32 Unsigned 32 bit integer (C, C) =item sint64 Signed 64 bit integer (C or C, C) =item uint64 Unsigned 64 bit integer (C or C, C) =back You may also use C, C, C and C as short names for C, C, C and C. These integer types are also available, but there actual size and sign may depend on the platform. =over 4 =item char Somewhat confusingly, C is an integer type! This is really an alias for either C or C depending on your platform. If you want to pass a character (not integer) in to a C function that takes a character you want to use the perl L function. Here is an example that uses the standard libc C, C type functions: use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->type('int' => 'character'); my @list = qw( alnum alpha ascii blank cntrl digit lower print punct space upper xdigit ); $ffi->attach("is$_" => ['character'] => 'int') for @list; my $char = shift(@ARGV) || 'a'; no strict 'refs'; printf "'%s' is %s %s\n", $char, $_, &{'is'.$_}(ord $char) for @list; =item size_t This is usually an C, but it is up to the compiler to decide. The C function is defined in terms of C: use FFI::Platypus::Declare qw( size_t opaque ); attach malloc => [size_t] => opaque; (Note that you can get C from L). =back There are a number of other types that may or may not be available if they are detected when L is installed. This includes things like C, C, C. You can use this script to list all the integer types that L knows about, plus how they are implemented. use FFI::Platypus; my $ffi = FFI::Platypus->new; foreach my $type_name (sort FFI::Platypus->types) { my $meta = $ffi->type_meta($type_name); next unless $meta->{element_type} eq 'int'; printf "%20s %s\n", $type_name, $meta->{ffi_type}; } If you need a common system type that is not provided, please open a ticket in the Platypus project's GitHub issue tracker. Be sure to include the usual header file the type can be found in. =head3 floating point types The following native floating point types are always available (parentheticals indicates the usual corresponding C type): =over 4 =item float Single precision floating point (I) =item double Double precision floating point (I) =item longdouble Floating point that may be larger than C (I). This type is only available if supported by the C compiler used to build L. There may be a performance penalty for using this type, even if your Perl uses long doubles internally for its number value (NV) type, because of the way L interacts with C. As an argument type either regular number values (NV) or instances of L are accepted. When used as a return type, L will be used, if you have that module installed. Otherwise the return type will be downgraded to whatever your Perl's number value (NV) is. =item complex_float Complex single precision floating point (I) =item complex_double Complex double precision floating point (I) C and C are only available if supported by your C compiler and by libffi. Complex numbers are only supported in very recent versions of libffi, and as of this writing the latest production version doesn't work on x86_64. It does seem to work with the latest production version of libffi on 32 bit Intel (x86), and with the latest libffi version in git on x86_64. =back Support for C, C and C are limited at the moment. Complex types can only be used as simple arguments (not return types, pointers, arrays or record members) and the C can only be used as simple argument or return values (not pointers, arrays or record members). Adding support for these is not difficult, but time consuming, so if you are in need of these features please do not hesitate to open a support ticket on the project's github issue tracker: L In particular I am hesitant to implementing complex return types, as there are performance and interface ramifications, and I would appreciate talking to someone who is actually going to use these features. =head3 opaque pointers Opaque pointers are simply a pointer to a region of memory that you do not manage, and do not know the structure of. It is like a C in C. These types are represented in Perl space as integers and get converted to and from pointers by L. You may use C as an alias for C. (The Platypus documentation uses the convention of using "pointer" to refer to pointers to known types (see below) and "opaque" as short hand for opaque pointer). As an example, libarchive defines C type in its header files, but does not define its content. Internally it is defined as a C type, but the caller does not see this. It is therefore opaque to its caller. There are C and C functions to create a new instance of this opaque object and C and C to destroy this objects when you are done. use FFI::Platypus::Declare qw( opaque int ); attach archive_read_new => [] => opaque; attach archive_write_new => [] => opaque; attach archive_read_free => [opaque] => int; attach archive_write_free => [opaque] => int; As a special case, when you pass C into a function that takes an opaque type it will be translated into C for C. When a C function returns a NULL pointer, it will be translated back to C. =head2 Strings From the CPU's perspective, strings are just pointers. From Perl and C's perspective, those pointers point to a series of characters. For C they are null terminates ("\0"). L handles the details where they differ. Basically when you see C or C used in a C header file you can expect to be able to use the C type. use FFI::Platypus::Declare qw( string int ); attach puts => [string] => int; Currently strings are only supported as simple argument and return types and as argument (but not return types) for closures. In the future pointers to strings or arrays of strings may be supported. =head2 Pointer / References In C you can pass a pointer to a variable to a function in order accomplish the task of pass by reference. In Perl the same is task is accomplished by passing a reference (although you can also modify the argument stack thus Perl supports proper pass by reference as well). With L you can define a pointer types to any of the native types described above (that is all the types we have covered so far except for strings). When using this you must make sure to pass in a reference to a scalar, or C (C will be translated into C). If the C code makes a change to the value pointed to by the pointer, the scalar will be updated before returning to Perl space. Example, with C code. /* foo.c */ void increment_int(int *value) { if(value != NULL) (*value)++; else fprintf(stderr, "NULL pointer!\n"); } # foo.pl use FFI::Platypus::Declare 'void', ['int*' =>'int_p']; lib 'libfoo.so'; # change to reflect the dynamic lib # that contains foo.c attach increment_int => [int_p] => void; my $i = 0; increment_int(\$i); # $i == 1 increment_int(\$i); # $i == 2 increment_int(\$i); # $i == 3 increment_int(undef); # prints "NULL pointer!\n" =head2 Records Records are structured data of a fixed length. In C they are called Cs To declare a record type, use C: $ffi->type( 'record (42)' => 'my_record_of_size_42_bytes' ); The easiest way to mange records with Platypus is by using L to define a record layout for a record class. Here is a brief example: package My::UnixTime; use FFI::Platypus::Record; record_layout(qw( int tm_sec int tm_min int tm_hour int tm_mday int tm_mon int tm_year int tm_wday int tm_yday int tm_isdst long tm_gmtoff string tm_zone )); my $ffi = FFI::Platypus->new; $ffi->lib(undef); # define a record class My::UnixTime and alias it to "tm" $ffi->type("record(My::UnixTime)" => 'tm'); # attach the C localtime function as a constructor $ffi->attach( localtime => ['time_t*'] => 'tm', sub { my($inner, $class, $time) = @_; $time = time unless defined $time; $inner->(\$time); }); package main; # now we can actually use our My::UnixTime class my $time = My::UnixTime->localtime; printf "time is %d:%d:%d %s\n", $time->tm_hour, $time->tm_min, $time->tm_sec, $time->tm_zone; For more detailed usage, see L. Platypus does not manage the structure of a record (that is up to you), it just keeps track of their size and makes sure that they are copied correctly when used as a return type. A record in Perl is just a string of bytes stored as a scalar. In addition to defining a record layout for a record class, there are a number of tools you can use manipulate records in Perl, two notable examples are L and L. Here is an example with commentary that uses L to extract the component time values from the C C function, and then smushes them back together to get the original C (an integer). use Convert::Binary::C; use FFI::Platypus; use Data::Dumper qw( Dumper ); my $c = Convert::Binary::C->new; # Alignment of zero (0) means use # the alignment of your CPU $c->configure( Alignment => 0 ); # parse the tm record structure so # that Convert::Binary::C knows # what to spit out and suck in $c->parse(<sizeof("tm"); # create the Platypus instance and create the appropriate # types and functions my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->type("record($tm_size)" => 'tm'); $ffi->attach( [ localtime => 'my_localtime' ] => ['time_t*'] => 'tm' ); $ffi->attach( [ time => 'my_time' ] => ['tm'] => 'time_t' ); # =============================================== # get the tm struct from the C localtime function # note that we pass in a reference to the value that time # returns because localtime takes a pointer to time_t # for some reason. my $time_hashref = $c->unpack( tm => my_localtime(\time) ); # tm_zone comes back from Convert::Binary::C as an opaque, # cast it into a string. We localize it to just this do # block so that it will be a pointer when we pass it back # to C land below. do { local $time_hashref->{tm_zone} = $ffi->cast(opaque => string => $time_hashref->{tm_zone}); print Dumper($time_hashref); }; # =============================================== # convert the tm struct back into an epoch value my $time = my_time( $c->pack( tm => $time_hashref ) ); print "time = $time\n"; print "perl time = ", time, "\n"; You can also link a record type to a class. It will then be accepted when blessed into that class as an argument passed into a C function, and when it is returned from a C function it will be blessed into that class. Basically: $ffi->type( 'record(My::Class)' => 'my_class' ); $ffi->attach( my_function1 => [ 'my_class' ] => 'void' ); $ffi->attach( my_function2 => [ ] => 'my_class' ); The only thing that your class MUST provide is either a C or C<_ffi_record_size> class method that returns the size of the record in bytes. Here is a longer practical example, once again using the tm struct: package My::UnixTime; use FFI::Platypus; use FFI::TinyCC; use FFI::TinyCC::Inline 'tcc_eval'; # store the source of the tm struct # for repeated use later my $tm_source = <new; $ffi->lib(undef); # define a record class My::UnixTime and alias it # to "tm" $ffi->type("record(My::UnixTime)" => 'tm'); # attach the C localtime function as a constructor $ffi->attach( [ localtime => '_new' ] => ['time_t*'] => 'tm' ); # the constructor needs to be wrapped in a Perl sub, # because localtime is expecting the time_t (if provided) # to come in as the first argument, not the second. # We could also acomplish something similar using # custom types. sub new { _new(\($_[1] || time)) } # for each attribute that we are interested in, create # get and set accessors. We just make accessors for # hour, minute and second, but we could make them for # all the fields if we needed. foreach my $attr (qw( hour min sec )) { my $tcc = FFI::TinyCC->new; $tcc->compile_string(qq{ $tm_source int get_$attr (struct tm *tm) { return tm->tm_$attr; } void set_$attr (struct tm *tm, int value) { tm->tm_$attr = value; } }); $ffi->attach( [ $tcc->get_symbol("get_$attr") => "get_$attr" ] => [ 'tm' ] => 'int' ); $ffi->attach( [ $tcc->get_symbol("set_$attr") => "set_$attr" ] => [ 'tm' ] => 'int' ); } package main; # now we can actually use our My::UnixTime class my $time = My::UnixTime->new; printf "time is %d:%d:%d\n", $time->get_hour, $time->get_min, $time->get_sec; Contrast a record type which is stored as a scalar string of bytes in Perl to an opaque pointer which is stored as an integer in Perl. Both are treated as pointers in C functions. The situations when you usually want to use a record are when you know ahead of time what the size of the object that you are working with and probably something about its structure. Because a function that returns a structure copies the structure into a Perl data structure, you want to make sure that it is okay to copy the record objects that you are dealing with if any of your functions will be returning one of them. Opaque pointers should be used when you do not know the size of the object that you are using, or if the objects are created and free'd through an API interface other than C and C. =head2 Fixed length arrays Fixed length arrays of native types are supported by L. Like pointers, if the values contained in the array are updated by the C function these changes will be reflected when it returns to Perl space. An example of using this is the Unix C command which returns a list of two file descriptors as an array. use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->attach([pipe=>'mypipe'] => ['int[2]'] => 'int'); my @fd = (0,0); mypipe(\@fd); my($fd1,$fd2) = @fd; print "$fd1 $fd2\n"; =head2 Variable length arrays [version 0.22] Variable length arrays are supported for argument types can also be specified by using the C<[]> notation but by leaving the size empty: $ffi->type('int[]' => 'var_int_array'); When used as an argument type it will probe the array reference that you pass in to determine the correct size. Usually you will need to communicate the size of the array to the C code. One way to do this is to pass the length of the array in as an additional argument. For example the C code: int sum(int *array, int size) { int total,i; for(i=0,total=0; inew; $ffi->lib('./var_array.so'); $ffi->attach( sum => [ 'int[]', 'int' ] => 'int' ); my @list = (1..100); print sum(\@list, scalar @list), "\n"; Another method might be to have a special value, such as 0 or NULL indicate the termination of the array. =head2 Closures A closure (called a "callback" by L, we use the C terminology) is a Perl subroutine that can be called from C. In order to be called from C it needs to be passed to a C function. To define the closure type you need to provide a list of argument types and a return type. As of this writing only native types and strings are supported as closure argument types and only native types are supported as closure return types. Here is an example, with C code: /* * closure.c - on Linux compile with: gcc closure.c -shared -o closure.so -fPIC */ #include typedef int (*closure_t)(int); closure_t my_closure = NULL; void set_closure(closure_t value) { my_closure = value; } int call_closure(int value) { if(my_closure != NULL) return my_closure(value); else fprintf(stderr, "closure is NULL\n"); } And the Perl code: use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib('./closure.so'); $ffi->type('(int)->int' => 'closure_t'); $ffi->attach(set_closure => ['closure_t'] => 'void'); $ffi->attach(call_closure => ['int'] => 'int'); my $closure1 = $ffi->closure(sub { $_[0] * 2 }); set_closure($closure1); print call_closure(2), "\n"; # prints "4" my $closure2 = $ffi->closure(sub { $_[0] * 4 }); set_closure($closure2); print call_closure(2), "\n"; # prints "8" If you have a pointer to a function in the form of an C type, you can pass this in place of a closure type: use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib('./closure.so'); $ffi->type('(int)->int' => 'closure_t'); $ffi->attach(set_closure => ['closure_t'] => 'void'); $ffi->attach(call_closure => ['int'] => 'int'); my $closure = $ffi->closure(sub { $_[0] * 6 }); my $opaque = $ffi->cast(closure_t => 'opaque', $closure); set_closure($opaque); print call_closure(2), "\n"; # prints "12" The syntax for specifying a closure type is a list of comma separated types in parentheticals followed by a narrow arrow C<-E>, followed by the return type for the closure. For example a closure that takes a pointer, an integer and a string and returns an integer would look like this: $ffi->type('(opaque, int, string) -> int' => 'my_closure_type'); Care needs to be taken with scoping and closures, because of the way Perl and C handle responsibility for allocating memory differently. Perl keeps reference counts and frees objects when nothing is referencing them. In C the code that allocates the memory is considered responsible for explicitly free'ing the memory for objects it has created when they are no longer needed. When you pass a closure into a C function, the C code has a pointer or reference to that object, but it has no way up letting Perl know when it is no longer using it. As a result, if you do not keep a reference to your closure around it will be free'd by Perl and if the C code ever tries to call the closure it will probably SIGSEGV. Thus supposing you have a C function C that takes a Perl closure, this is almost always wrong: set_closure(closure { $_[0] * 2 }); # BAD In some cases, you may want to create a closure shouldn't ever be free'd. For example you are passing a closure into a C function that will retain it for the lifetime of your application. You can use the sticky keyword to indicate this, without the need to keep a reference of the closure: set_closure(sticky closure { $_[0] * 2 }); # OKAY =head2 Custom Types =head3 Custom Types in Perl Platypus custom types are the rough analogue to typemaps in the XS world. They offer a method for converting Perl types into native types that the C can understand and pass on to the C code. =head4 Example 1: Integer constants Say you have a C header file like this: /* possible foo types: */ #define FOO_STATIC 1 #define FOO_DYNAMIC 2 #define FOO_OTHER 3 typedef int foo_t; void foo(foo_t foo); foo_t get_foo(); One common way of implementing this would be to create and export constants in your Perl module, like this: package Foo; use FFI::Platypus::Declare qw( void int ); use base qw( Exporter ); our @EXPORT_OK = qw( FOO_STATIC FOO_DYNAMIC FOO_OTHER foo get_foo ); use constant FOO_STATIC => 1; use constant FOO_DYNAMIC => 2; use constant FOO_OTHER => 3; attach foo => [int] => void; attach get_foo => [] => int; Then you could use the module thus: use Foo qw( foo FOO_STATIC ); foo(FOO_STATIC); If you didn't want to rely on integer constants or exports, you could also define a custom type, and allow strings to be passed into your function, like this: package Foo; use FFI::Platypus::Declare qw( void ); use base qw( Exporter ); our @EXPORT_OK = qw( foo get_foo ); my %foo_types = ( static => 1, dynamic => 2, other => 3, ); my %foo_types_reverse = reverse %foo_types; custom_type foo_t => { native_type => 'int', native_to_perl => sub { $foo_types{$_[0]}; }, perl_to_native => sub { $foo_types_reverse{$_[0]}; }, }; attach foo => ['foo_t'] => void; attach get_foo => [] => foo_t; Now when an argument of type C is called for it will be converted from an appropriate string representation, and any function that returns a C type will return a string instead of the integer representation: use Foo; foo('static'); =head4 Example 2: Blessed references Supposing you have a C library that uses an opaque pointer with a pseudo OO interface, like this: typedef struct foo_t; foo_t *foo_new(); void foo_method(foo_t *, int argument); void foo_free(foo_t *); One approach to adapting this to Perl would be to create a OO Perl interface like this: package Foo; use FFI::Platypus::Declare 'void', 'int'; use FFI::Platypus::API qw( arguments_get_string ); custom_type foo_t => { native_type => 'opaque', native_to_perl => sub { my $class = arguments_get_string(0); bless \$_[0], $class; } perl_to_native => sub { ${$_[0]} }, }; attach [ foo_new => 'new' ] => [ string ] => 'foo_t' ); attach [ foo_method => 'method' ] => [ 'foo_t', int ] => void; attach [ foo_free => 'DESTROY' ] => [ 'foo_t' ] => void; my $foo = Foo->new; Here we are blessing a reference to the opaque pointer when we return the custom type for C, and dereferencing that reference before we pass it back in. The function C queries the C arguments to get the class name to make sure the object is blessed into the correct class (for more details on the custom type API see L), so you can inherit and extend this class like a normal Perl class. This works because the C "constructor" ignores the class name that we pass in as the first argument. If you have a C "constructor" like this that takes arguments you'd have to write a wrapper for new. I good example of a C library that uses this pattern, including inheritance is C. Platypus comes with a more extensive example in C that demonstrates this. =head4 Example 3: Pointers with pack / unpack TODO See example L. =head4 Example 4: Custom Type modules and the Custom Type API TODO See example L. =head4 Example 5: Custom Type on CPAN You can distribute your own Platypus custom types on CPAN, if you think they may be applicable to others. The default namespace is prefix with C, though you can stick it anywhere (under your own namespace may make more sense if the custom type is specific to your application). A good example and pattern to follow is L. =head3 Custom Types in C/XS Custom types written in C or XS are a future goal of the L project. They should allow some of the flexibility of custom types written in Perl, with potential performance improvements of native code. =head1 SEE ALSO =over 4 =item L Main platypus documentation. =item L Declarative interface for L. =item L Custom types API. =item L String pointer type. =back =head1 AUTHOR Author: Graham Ollis Eplicease@cpan.orgE Contributors: Bakkiaraj Murugesan (bakkiaraj) Dylan Cali (calid) pipcet Zaki Mughal (zmughal) Fitz Elliott (felliott) Vickenty Fesunov (vyf) Gregor Herrmann (gregoa) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Graham Ollis. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut closure-opaque.pl100644001750001750 64313065045605 21023 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib('./closure.so'); $ffi->type('(int)->int' => 'closure_t'); $ffi->attach(set_closure => ['closure_t'] => 'void'); $ffi->attach(call_closure => ['int'] => 'int'); my $closure = $ffi->closure(sub { $_[0] * 6 }); my $opaque = $ffi->cast(closure_t => 'opaque', $closure); set_closure($opaque); print call_closure(2), "\n"; # prints "12" Example.java100644001750001750 37513065045605 20703 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examples/java// On Linux build .so with // % gcj -fPIC -shared -o libexample.so Example.java public class Example { public static void print_hello() { System.out.println("hello world"); } public static int add(int a, int b) { return a + b; } } Memory.pm100644001750001750 1150413065045605 20543 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFI/Platypuspackage FFI::Platypus::Memory; use strict; use warnings; use FFI::Platypus; use base qw( Exporter ); # ABSTRACT: Memory functions for FFI our $VERSION = '0.47'; # VERSION our @EXPORT = qw( malloc free calloc realloc memcpy memset strdup ); my $ffi = FFI::Platypus->new; $ffi->lib(undef); $ffi->type($_) foreach qw( opaque size_t void int ); $ffi->attach(malloc => ['size_t'] => 'opaque' => '$'); $ffi->attach(free => ['opaque'] => 'void' => '$'); $ffi->attach(calloc => ['size_t', 'size_t'] => 'opaque' => '$$'); $ffi->attach(realloc => ['opaque', 'size_t'] => 'opaque' => '$$'); $ffi->attach(memcpy => ['opaque', 'opaque', 'size_t'] => 'opaque' => '$$$'); $ffi->attach(memset => ['opaque', 'int', 'size_t'] => 'opaque' => '$$$'); # This global may be removed at any time, do not use it # externally. It is used by t/ffi_platypus_memory__strdup.t # for a diagnostic. our $_strdup_impl = 'not-loaded'; eval { die "do not use c impl" if ($ENV{FFI_PLATYPUS_MEMORY_STRDUP_IMPL}||'c') eq 'perl'; $ffi->attach(strdup => ['string'] => 'opaque' => '$'); }; if($@) { $_strdup_impl = 'perl'; *strdup = sub ($) { my($string) = @_; my $ptr = malloc(length($string)+1); memcpy($ptr, $ffi->cast('string' => 'opaque', $string), length($string)+1); }; } else { $_strdup_impl = 'c'; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Memory - Memory functions for FFI =head1 VERSION version 0.47 =head1 SYNOPSIS use FFI::Platypus::Memory; # allocate 64 bytes of memory using the # libc malloc function. my $pointer = malloc 64; # use that memory wisely ... # free the memory when you are done. free $pointer; =head1 DESCRIPTION This module provides an interface to common memory functions provided by the standard C library. They may be useful when constructing interfaces to C libraries with FFI. =head1 FUNCTIONS =head2 calloc my $pointer = calloc $count, $size; The C function contiguously allocates enough space for I<$count> objects that are I<$size> bytes of memory each. =head2 free free $pointer; The C function frees the memory allocated by C, C, C or C. It is important to only free memory that you yourself have allocated. A good way to crash your program is to try and free a pointer that some C library has returned to you. =head2 malloc my $pointer = malloc $size; The C function allocates I<$size> bytes of memory. =head2 memcpy memcpy $dst_pointer, $src_pointer, $size; The C function copies I<$size> bytes from I<$src_pointer> to I<$dst_pointer>. It also returns I<$dst_pointer>. =head2 memset memset $buffer, $value, $length; The C function writes I<$length> bytes of I<$value> to the address specified by I<$buffer>. =head2 realloc my $new_pointer = realloc $old_pointer, $size; The C function reallocates enough memory to fit I<$size> bytes. It copies the existing data and frees I<$old_pointer>. If you pass C in as I<$old_pointer>, then it behaves exactly like C: my $pointer = realloc undef, 64; # same as malloc 64 =head2 strdup my $pointer = strdup $string; The C function allocates enough memory to contain I<$string> and then copies it to that newly allocated memory. This version of C returns an opaque pointer type, not a string type. This may seem a little strange, but returning a string type would not be very useful in Perl. Platforms that do not support C will be provided with an equivalent using C and C written in Perl. This version is slower. =head1 ENVIRONMENT =head2 FFI_PLATYPUS_MEMORY_STRDUP_IMPL C isn't always supported by all platforms. On platforms that do not support it, it is emulated using calls to C and C which are part of the standard C library. Because this requires two function calls it is probably not as fast on most platforms. If you experience problems with the C provided by your platform, you can force the emulated implementation using the FFI_PLATYPUS_MEMORY_STRDUP_IMPL environment variable. # bash: $ export FFI_PLATYPUS_MEMORY_STRDUP_IMPL=perl # tcsh: % setenv FFI_PLATYPUS_MEMORY_STRDUP_IMPL perl # Windows: > SET FFI_PLATYPUS_MEMORY_STRDUP_IMPL=perl =head1 SEE ALSO =over 4 =item L Main Platypus documentation. =back =head1 AUTHOR Author: Graham Ollis Eplicease@cpan.orgE Contributors: Bakkiaraj Murugesan (bakkiaraj) Dylan Cali (calid) pipcet Zaki Mughal (zmughal) Fitz Elliott (felliott) Vickenty Fesunov (vyf) Gregor Herrmann (gregoa) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Graham Ollis. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Record.pm100644001750001750 1772513065045605 20524 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFI/Platypuspackage FFI::Platypus::Record; use strict; use warnings; use Carp qw( croak ); use FFI::Platypus; use base qw( Exporter ); use constant 1.32 (); our @EXPORT = qw( record_layout ); # ABSTRACT: FFI support for structured records data our $VERSION = '0.47'; # VERSION sub record_layout { my $ffi = ref($_[0]) ? shift : FFI::Platypus->new; my $offset = 0; my $record_align = 0; croak "uneven number of arguments!" if scalar(@_) % 2; my($caller, $filename, $line) = caller; if($caller->can("_ffi_record_size") || $caller->can("ffi_record_size")) { croak "record already defined for the class $caller"; } my @destroy; while(@_) { my $type = shift; my $name = shift; croak "illegal name $name" unless $name =~ /^[A-Za-z_][A-Za-z_0-9]*$/ || $name eq ':'; croak "accessor/method $name already exists" if $caller->can($name); my $size = $ffi->sizeof($type); my $align = $ffi->alignof($type); $record_align = $align if $align > $record_align; my $meta = $ffi->type_meta($type); $offset++ while $offset % $align; if($name ne ':') { if($meta->{type} eq 'string' && $meta->{access} eq 'rw' && $meta->{fixed_size} == 0) { push @destroy, eval '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) .qq{ sub { shift->$name(undef); }; }; die $@ if $@; } $name = join '::', $caller, $name; my $error_str =_accessor $name, "$filename:$line", $ffi->_type_lookup($type), $offset; croak($error_str) if $error_str; }; $offset += $size; } my $size = $offset; no strict 'refs'; constant->import("${caller}::_ffi_record_size", $size); constant->import("${caller}::_ffi_record_align", $record_align); *{join '::', $caller, 'new'} = sub { my $class = shift; my $args = ref($_[0]) ? [%{$_[0]}] : \@_; croak "uneven number of arguments to record constructor" if @$args % 2; my $record = "\0" x $class->_ffi_record_size; my $self = bless \$record, $class; while(@$args) { my $key = shift @$args; my $value = shift @$args; $self->$key($value); } $self; }; my $destroy_sub = sub {}; if(@destroy) { $destroy_sub = sub { $_->($_[0]) for @destroy; }; } do { no strict 'refs'; *{"${caller}::DESTROY"} = $destroy_sub; }; (); } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Record - FFI support for structured records data =head1 VERSION version 0.47 =head1 SYNOPSIS C: struct my_person { int age; const char title[3]; const char *name }; void process_person(struct my_person *person) { /* ... */ } Perl: package MyPerson; use FFI::Platypus::Record; record_layout(qw( int age string(3) title string_rw name ); package main; use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lib("myperson.so"); $ffi->type("record(MyPerson)" => 'MyPerson'); my $person = MyPerson->new( age => 40, title => "Mr.", name => "John Smith", ); $ffi->attach( process_person => [ 'MyPerson' ] => 'void' ); process_person($person); $person->age($person->age + 1); # another year older process_person($person); =head1 DESCRIPTION [version 0.21] This module provides a mechanism for building classes that can be used to mange structured data records (known as C as "structs" and in some languages as "records"). A structured record is a series of bytes that have structure understood by the C or other foreign language library that you are interfacing with. It is designed for use with FFI and L, though it may have other applications. =head1 FUNCTIONS =head2 record_layout record_layout($ffi, $type => $name, ... ); record_layout($type => $name, ... ); Define the layout of the record. You may optionally provide an instance of L as the first argument in order to use its type aliases. Then you provide members as type/name pairs. For each member you declare, C will create an accessor which can be used to read and write its value. For example imagine a class C: package Foo; use FFI::Platypus::Record; record_layout( int => 'bar', # int bar; 'string(10)' => 'baz', # char baz[10]; ); You can get and set its fields with like named C and C accessors: my $foo = Foo->new; $foo->bar(22); my $value = $foo->bar; $foo->baz("grimlock\0\0"); # should be 10 characters long my $string_value = $foo->baz; # includes the trailing \0\0 You can also pass initial values in to the constructor, either passing as a list of key value pairs or by passing a hash reference: $foo = Foo->new( bar => 22, baz => "grimlock\0\0", ); # same as: $foo = Foo->new( { bar => 22, baz => "grimlock\0\0", } ); If there are members of a record that you need to account for in terms of size and alignment, but do not want to have an accessor for, you can use C<:> as a place holder for its name: record_layout( 'int' => ':', 'string(10)' => 'baz', ); =head3 strings So far I've shown fixed length strings. These are declared with the word C followed by the length of the string in parentheticals. Fixed length strings are included inside the record itself and do not need to be allocated or deallocated separately from the record. Variable length strings must be allocated on the heap, and thus require a sense of "ownership", that is whomever allocates variable length strings should be responsible for also free'ing them. To handle this, you can add a C or C trait to a string field. The default is C, means that you can get, but not set its value: package Foo; record_layout( 'string ro' => 'bar', # same type as 'string' and 'string_ro' ); package main; my $foo = Foo->new; my $string = $foo->bar; # GOOD $foo->bar("starscream"); # BAD If you specify a field is C, then you can set its value: package Foo; record_layout( 'string rw' => 'bar', # same type as 'string_rw' ); package main; my $foo = Foo->new; my $string = $foo->bar; # GOOD $foo->bar("starscream"); # GOOD Any string value that is pointed to by the record will be free'd when it falls out of scope, so you must be very careful that any C fields are not set or modified by C code. You should also take care not to copy any record that has a C string in it because its values will be free'd twice! use Clone qw( clone ); my $foo2 = clone $foo; # BAD bar will be free'd twice =head3 arrays Arrays of integer, floating points and opaque pointers are supported. package Foo; record_layout( 'int[10]' => 'bar', ); my $foo = Foo->new; $foo->bar([1,2,3,4,5,6,7,8,9,10]); # sets the values for the array my $list = $foo->bar; # returns a list reference $foo->bar(5, -6); # sets the 5th element in the array to -6 my $item = $foo->bar(5); gets the 5th element in the array =head1 TODO These useful features (and probably more) are missing: =over 4 =item Unions =item Nested records =back =head1 SEE ALSO =over 4 =item L The main platypus documentation. =item L Tied array interface for record array members. =item L Another method for constructing and dissecting structured data records. =item L Built-in Perl functions for constructing and dissecting structured data records. =back =head1 AUTHOR Author: Graham Ollis Eplicease@cpan.orgE Contributors: Bakkiaraj Murugesan (bakkiaraj) Dylan Cali (calid) pipcet Zaki Mughal (zmughal) Fitz Elliott (felliott) Vickenty Fesunov (vyf) Gregor Herrmann (gregoa) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Graham Ollis. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Buffer.pm100644001750001750 501113065045605 20460 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFI/Platypuspackage FFI::Platypus::Buffer; use strict; use warnings; use base qw( Exporter ); our @EXPORT = qw( scalar_to_buffer buffer_to_scalar ); # ABSTRACT: Convert scalars to C buffers our $VERSION = '0.47'; # VERSION use constant _incantation => $^O eq 'MSWin32' && $Config::Config{archname} =~ /MSWin32-x64/ ? 'Q' : 'L!'; sub scalar_to_buffer ($) { (unpack(_incantation, pack 'P', $_[0]), do { use bytes; length $_[0] }); } sub buffer_to_scalar ($$) { unpack 'P'.$_[1], pack _incantation, defined $_[0] ? $_[0] : 0; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Buffer - Convert scalars to C buffers =head1 VERSION version 0.47 =head1 SYNOPSIS use FFI::Platypus::Buffer; my($pointer, $size) = scalar_to_buffer $scalar; my $scalar2 = buffer_to_scallar $pointer, $size; =head1 DESCRIPTION A common pattern in C is to pass a "buffer" or region of memory into a function with a pair of arguments, an opaque pointer and the size of the memory region. In Perl the equivalent structure is a scalar containing a string of bytes. This module provides portable functions for converting a Perl string or scalar into a buffer and back. These functions are implemented using L and so they should be relatively fast. Both functions are exported by default, but you can explicitly export one or neither if you so choose. A better way to do this might be with custom types see L and L. These functions were taken from the now obsolete L module, as they may be useful in some cases. =head1 FUNCTIONS =head2 scalar_to_buffer my($pointer, $size) = scalar_to_buffer $scalar; Convert a string scalar into a buffer. Returned in order are a pointer to the start of the string scalar's memory region and the size of the region. =head2 buffer_to_scalar my $scalar = buffer_to_scalar $pointer, $size; Convert the buffer region defined by the pointer and size into a string scalar. =head1 SEE ALSO =over 4 =item L Main Platypus documentation. =back =head1 AUTHOR Author: Graham Ollis Eplicease@cpan.orgE Contributors: Bakkiaraj Murugesan (bakkiaraj) Dylan Cali (calid) pipcet Zaki Mughal (zmughal) Fitz Elliott (felliott) Vickenty Fesunov (vyf) Gregor Herrmann (gregoa) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Graham Ollis. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut Lang000755001750001750 013065045605 17435 5ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFI/PlatypusC.pm100644001750001750 315413065045605 20320 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFI/Platypus/Langpackage FFI::Platypus::Lang::C; use strict; use warnings; # ABSTRACT: Documentation and tools for using Platypus with the C programming language our $VERSION = '0.47'; # VERSION sub native_type_map { require FFI::Platypus::ShareConfig; FFI::Platypus::ShareConfig->get('type_map'); } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Lang::C - Documentation and tools for using Platypus with the C programming language =head1 VERSION version 0.47 =head1 SYNOPSIS use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lang('C'); # the default =head1 DESCRIPTION This module provides some hooks for Platypus to interact with the C programming language. It is generally used by default if you do not specify another foreign programming language with the L attribute. =head1 METHODS =head2 native_type_map my $hashref = FFI::Platypus::Lang::C->native_type_map; This returns a hash reference containing the native aliases for the C programming languages. That is the keys are native C types and the values are libffi native types. =head1 SEE ALSO =over 4 =item L The Core Platypus documentation. =back =head1 AUTHOR Author: Graham Ollis Eplicease@cpan.orgE Contributors: Bakkiaraj Murugesan (bakkiaraj) Dylan Cali (calid) pipcet Zaki Mughal (zmughal) Fitz Elliott (felliott) Vickenty Fesunov (vyf) Gregor Herrmann (gregoa) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Graham Ollis. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut ffi_platypus_lang_win32.t100644001750001750 41413065045605 21060 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 1; use FFI::Platypus::Lang::Win32; my $map = FFI::Platypus::Lang::Win32->native_type_map; foreach my $alias (sort keys %$map) { my $type = $map->{$alias}; note sprintf("%-30s %s", $alias, $type); } pass 'good'; ffi_platypus_guts.h100644001750001750 557313065045605 21276 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/include#ifndef FFI_PLATYPUS_GUTS_H #define FFI_PLATYPUS_GUTS_H #ifdef __cplusplus extern "C" { #endif void ffi_pl_closure_call(ffi_cif *, void *, void **, void *); void ffi_pl_closure_add_data(SV *closure, ffi_pl_closure *closure_data); ffi_pl_closure *ffi_pl_closure_get_data(SV *closure, ffi_pl_type *type); SV* ffi_pl_custom_perl(SV*,SV*,int); void ffi_pl_custom_perl_cb(SV *, SV*, int); HV *ffi_pl_get_type_meta(ffi_pl_type *); size_t ffi_pl_sizeof(ffi_pl_type *); void ffi_pl_perl_complex_float(SV *sv, float *ptr); void ffi_pl_perl_complex_double(SV *sv, double *ptr); #define ffi_pl_perl_to_long_double(sv, ptr) \ if(!SvOK(sv)) \ { \ *(ptr) = 0.0L; \ } \ else if(sv_isobject(sv) && sv_derived_from(sv, "Math::LongDouble")) \ { \ *(ptr) = *INT2PTR(long double *, SvIV((SV*) SvRV(sv))); \ } \ else \ { \ *(ptr) = (long double) SvNV(sv); \ } /* * CAVEATS: * - We are mucking about with the innerds of Math::LongDouble * so if the innerds change we may break Math::LongDouble, * FFI::Platypus or both! * - This makes Math::LongDouble mutable. Note however, that * Math::LongDouble overloads ++ and increments the actual * longdouble pointed to in memory, so we are at least not * introducing the sin of mutability. See LongDouble.xs * C function _overload_inc. */ #define ffi_pl_long_double_to_perl(sv, ptr) \ if(sv_isobject(sv) && sv_derived_from(sv, "Math::LongDouble")) \ { \ *INT2PTR(long double *, SvIV((SV*) SvRV(sv))) = *(ptr); \ } \ else if(MY_CXT.have_math_longdouble) \ { \ long double *tmp; \ Newx(tmp, 1, long double); \ *tmp = *(ptr); \ sv_setref_pv(sv, "Math::LongDouble", (void*)tmp); \ } \ else \ { \ sv_setnv(sv, *(ptr)); \ } #ifdef __cplusplus } #endif #endif ffi_platypus_call.h100644001750001750 11376113065045605 21266 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/include /* buffer contains the memory required for the arguments structure */ buffer_size = sizeof(ffi_pl_argument) * self->ffi_cif.nargs + sizeof(void*) * self->ffi_cif.nargs + sizeof(ffi_pl_arguments); Newx_or_alloca(buffer, buffer_size, char); MY_CXT.current_argv = arguments = (ffi_pl_arguments*) buffer; arguments->count = self->ffi_cif.nargs; argument_pointers = (void**) &arguments->slot[arguments->count]; /* * ARGUMENT IN */ for(i=0, perl_arg_index=(EXTRA_ARGS); i < self->ffi_cif.nargs; i++, perl_arg_index++) { int platypus_type = self->argument_types[i]->platypus_type; argument_pointers[i] = (void*) &arguments->slot[i]; arg = perl_arg_index < items ? ST(perl_arg_index) : &PL_sv_undef; if(platypus_type == FFI_PL_NATIVE) { switch(self->argument_types[i]->ffi_type->type) { case FFI_TYPE_UINT8: ffi_pl_arguments_set_uint8(arguments, i, SvOK(arg) ? SvUV(arg) : 0); break; case FFI_TYPE_SINT8: ffi_pl_arguments_set_sint8(arguments, i, SvOK(arg) ? SvIV(arg) : 0); break; case FFI_TYPE_UINT16: ffi_pl_arguments_set_uint16(arguments, i, SvOK(arg) ? SvUV(arg) : 0); break; case FFI_TYPE_SINT16: ffi_pl_arguments_set_sint16(arguments, i, SvOK(arg) ? SvIV(arg) : 0); break; case FFI_TYPE_UINT32: ffi_pl_arguments_set_uint32(arguments, i, SvOK(arg) ? SvUV(arg) : 0); break; case FFI_TYPE_SINT32: ffi_pl_arguments_set_sint32(arguments, i, SvOK(arg) ? SvIV(arg) : 0); break; #ifdef HAVE_IV_IS_64 case FFI_TYPE_UINT64: ffi_pl_arguments_set_uint64(arguments, i, SvOK(arg) ? SvUV(arg) : 0); break; case FFI_TYPE_SINT64: ffi_pl_arguments_set_sint64(arguments, i, SvOK(arg) ? SvIV(arg) : 0); break; #else case FFI_TYPE_UINT64: ffi_pl_arguments_set_uint64(arguments, i, SvOK(arg) ? SvU64(arg) : 0); break; case FFI_TYPE_SINT64: ffi_pl_arguments_set_sint64(arguments, i, SvOK(arg) ? SvI64(arg) : 0); break; #endif case FFI_TYPE_FLOAT: ffi_pl_arguments_set_float(arguments, i, SvOK(arg) ? SvNV(arg) : 0.0); break; case FFI_TYPE_DOUBLE: ffi_pl_arguments_set_double(arguments, i, SvOK(arg) ? SvNV(arg) : 0.0); break; case FFI_TYPE_POINTER: ffi_pl_arguments_set_pointer(arguments, i, SvOK(arg) ? INT2PTR(void*, SvIV(arg)) : NULL); break; default: warn("argument type not supported (%d)", i); break; } } else if(platypus_type == FFI_PL_STRING) { switch(self->argument_types[i]->extra[0].string.platypus_string_type) { case FFI_PL_STRING_RW: case FFI_PL_STRING_RO: ffi_pl_arguments_set_string(arguments, i, SvOK(arg) ? SvPV_nolen(arg) : NULL); break; case FFI_PL_STRING_FIXED: { int expected; STRLEN size; void *ptr; expected = self->argument_types[i]->extra[0].string.size; ptr = SvOK(arg) ? SvPV(arg, size) : NULL; if(ptr != NULL && expected != 0 && size != expected) warn("fixed string argument %d has wrong size (is %d, expected %d)", i, (int)size, expected); ffi_pl_arguments_set_pointer(arguments, i, ptr); } break; } } else if(platypus_type == FFI_PL_POINTER) { void *ptr; if(SvROK(arg)) /* TODO: and a scalar ref */ { SV *arg2 = SvRV(arg); if(SvTYPE(arg2) < SVt_PVAV) { switch(self->argument_types[i]->ffi_type->type) { case FFI_TYPE_UINT8: Newx_or_alloca(ptr, 1, uint8_t); *((uint8_t*)ptr) = SvOK(arg2) ? SvUV(arg2) : 0; break; case FFI_TYPE_SINT8: Newx_or_alloca(ptr, 1, int8_t); *((int8_t*)ptr) = SvOK(arg2) ? SvIV(arg2) : 0; break; case FFI_TYPE_UINT16: Newx_or_alloca(ptr, 1, uint16_t); *((uint16_t*)ptr) = SvOK(arg2) ? SvUV(arg2) : 0; break; case FFI_TYPE_SINT16: Newx_or_alloca(ptr, 1, int16_t); *((int16_t*)ptr) = SvOK(arg2) ? SvIV(arg2) : 0; break; case FFI_TYPE_UINT32: Newx_or_alloca(ptr, 1, uint32_t); *((uint32_t*)ptr) = SvOK(arg2) ? SvUV(arg2) : 0; break; case FFI_TYPE_SINT32: Newx_or_alloca(ptr, 1, int32_t); *((int32_t*)ptr) = SvOK(arg2) ? SvIV(arg2) : 0; break; case FFI_TYPE_UINT64: Newx_or_alloca(ptr, 1, uint64_t); #ifdef HAVE_IV_IS_64 *((uint64_t*)ptr) = SvOK(arg2) ? SvUV(arg2) : 0; #else *((uint64_t*)ptr) = SvOK(arg2) ? SvU64(arg2) : 0; #endif break; case FFI_TYPE_SINT64: Newx_or_alloca(ptr, 1, int64_t); #ifdef HAVE_IV_IS_64 *((int64_t*)ptr) = SvOK(arg2) ? SvIV(arg2) : 0; #else *((int64_t*)ptr) = SvOK(arg2) ? SvI64(arg2) : 0; #endif break; case FFI_TYPE_FLOAT: Newx_or_alloca(ptr, 1, float); *((float*)ptr) = SvOK(arg2) ? SvNV(arg2) : 0.0; break; case FFI_TYPE_DOUBLE: Newx_or_alloca(ptr, 1, double); *((double*)ptr) = SvOK(arg2) ? SvNV(arg2) : 0.0; break; case FFI_TYPE_POINTER: Newx_or_alloca(ptr, 1, void*); { SV *tmp = SvRV(arg); *((void**)ptr) = SvOK(tmp) ? INT2PTR(void *, SvIV(tmp)) : NULL; } break; #ifdef FFI_PL_PROBE_LONGDOUBLE case FFI_TYPE_LONGDOUBLE: Newx_or_alloca(ptr, 1, long double); ffi_pl_perl_to_long_double(arg2, (long double*)ptr); break; #endif default: warn("argument type not supported (%d)", i); *((void**)ptr) = NULL; break; } } else { warn("argument type not a reference to scalar (%d)", i); ptr = NULL; } } else { ptr = NULL; } ffi_pl_arguments_set_pointer(arguments, i, ptr); } else if(platypus_type == FFI_PL_RECORD) { void *ptr; STRLEN size; int expected; expected = self->argument_types[i]->extra[0].record.size; if(SvROK(arg)) { SV *arg2 = SvRV(arg); ptr = SvOK(arg2) ? SvPV(arg2, size) : NULL; } else { ptr = SvOK(arg) ? SvPV(arg, size) : NULL; } if(ptr != NULL && expected != 0 && size != expected) warn("record argument %d has wrong size (is %d, expected %d)", i, (int)size, expected); ffi_pl_arguments_set_pointer(arguments, i, ptr); } else if(platypus_type == FFI_PL_ARRAY) { void *ptr; int count = self->argument_types[i]->extra[0].array.element_count; if(SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) { AV *av = (AV*) SvRV(arg); if(count == 0) count = av_len(av)+1; switch(self->argument_types[i]->ffi_type->type) { case FFI_TYPE_UINT8: Newx(ptr, count, uint8_t); for(n=0; nargument_types[i]->ffi_type->size, char); warn("argument type not supported (%d)", i); break; } } else { warn("passing non array reference into ffi/platypus array argument type"); Newxz(ptr, count*self->argument_types[i]->ffi_type->size, char); } ffi_pl_arguments_set_pointer(arguments, i, ptr); } else if(platypus_type == FFI_PL_CLOSURE) { if(!SvROK(arg)) { ffi_pl_arguments_set_pointer(arguments, i, SvOK(arg) ? INT2PTR(void*, SvIV(arg)) : NULL); } else { ffi_pl_closure *closure; ffi_status ffi_status; SvREFCNT_inc(arg); closure = ffi_pl_closure_get_data(arg, self->argument_types[i]); if(closure != NULL) { ffi_pl_arguments_set_pointer(arguments, i, closure->function_pointer); } else { Newx(closure, 1, ffi_pl_closure); closure->ffi_closure = ffi_closure_alloc(sizeof(ffi_closure), &closure->function_pointer); if(closure->ffi_closure == NULL) { Safefree(closure); ffi_pl_arguments_set_pointer(arguments, i, NULL); warn("unable to allocate memory for closure"); } else { closure->type = self->argument_types[i]; ffi_status = ffi_prep_closure_loc( closure->ffi_closure, &self->argument_types[i]->extra[0].closure.ffi_cif, ffi_pl_closure_call, closure, closure->function_pointer ); if(ffi_status != FFI_OK) { ffi_closure_free(closure->ffi_closure); Safefree(closure); ffi_pl_arguments_set_pointer(arguments, i, NULL); warn("unable to create closure"); } else { closure->coderef = arg; ffi_pl_closure_add_data(arg, closure); ffi_pl_arguments_set_pointer(arguments, i, closure->function_pointer); } } } } } else if(platypus_type == FFI_PL_CUSTOM_PERL) { SV *arg2 = ffi_pl_custom_perl( self->argument_types[i]->extra[0].custom_perl.perl_to_native, arg, i ); if(arg2 != NULL) { switch(self->argument_types[i]->ffi_type->type) { case FFI_TYPE_UINT8: ffi_pl_arguments_set_uint8(arguments, i, SvUV(arg2)); break; case FFI_TYPE_SINT8: ffi_pl_arguments_set_sint8(arguments, i, SvIV(arg2)); break; case FFI_TYPE_UINT16: ffi_pl_arguments_set_uint16(arguments, i, SvUV(arg2)); break; case FFI_TYPE_SINT16: ffi_pl_arguments_set_sint16(arguments, i, SvIV(arg2)); break; case FFI_TYPE_UINT32: ffi_pl_arguments_set_uint32(arguments, i, SvUV(arg2)); break; case FFI_TYPE_SINT32: ffi_pl_arguments_set_sint32(arguments, i, SvIV(arg2)); break; #ifdef HAVE_IV_IS_64 case FFI_TYPE_UINT64: ffi_pl_arguments_set_uint64(arguments, i, SvUV(arg2)); break; case FFI_TYPE_SINT64: ffi_pl_arguments_set_sint64(arguments, i, SvIV(arg2)); break; #else case FFI_TYPE_UINT64: ffi_pl_arguments_set_uint64(arguments, i, SvU64(arg2)); break; case FFI_TYPE_SINT64: ffi_pl_arguments_set_sint64(arguments, i, SvI64(arg2)); break; #endif case FFI_TYPE_FLOAT: ffi_pl_arguments_set_float(arguments, i, SvNV(arg2)); break; case FFI_TYPE_DOUBLE: ffi_pl_arguments_set_double(arguments, i, SvNV(arg2)); break; case FFI_TYPE_POINTER: ffi_pl_arguments_set_pointer(arguments, i, SvOK(arg2) ? INT2PTR(void*, SvIV(arg2)) : NULL); break; default: warn("argument type not supported (%d)", i); break; } SvREFCNT_dec(arg2); } for(n=0; n < self->argument_types[i]->extra[0].custom_perl.argument_count; n++) { i++; argument_pointers[i] = &arguments->slot[i]; } } else if(platypus_type == FFI_PL_EXOTIC_FLOAT) { switch(self->argument_types[i]->ffi_type->type) { #ifdef FFI_PL_PROBE_LONGDOUBLE case FFI_TYPE_LONGDOUBLE: { long double *ptr; Newx_or_alloca(ptr, 1, long double); argument_pointers[i] = ptr; ffi_pl_perl_to_long_double(arg, ptr); } break; #endif #ifdef FFI_PL_PROBE_COMPLEX case FFI_TYPE_COMPLEX: switch(self->argument_types[i]->ffi_type->size) { case 8: { float *ptr; Newx_or_alloca(ptr, 2, float complex); argument_pointers[i] = ptr; ffi_pl_perl_complex_float(arg, ptr); } break; case 16: { double *ptr; Newx_or_alloca(ptr, 2, double); argument_pointers[i] = ptr; ffi_pl_perl_complex_double(arg, ptr); } break; default : warn("argument type not supported (%d)", i); break; } break; #endif default: warn("argument type not supported (%d)", i); break; } } else { warn("argument type not supported (%d)", i); } } /* * CALL */ #if 0 fprintf(stderr, "# ===[%p]===\n", self->address); for(i=0; i < self->ffi_cif.nargs; i++) { fprintf(stderr, "# [%d] <%d:%d> %p %p", i, self->argument_types[i]->ffi_type->type, self->argument_types[i]->platypus_type, argument_pointers[i], &arguments->slot[i] ); if(self->argument_types[i]->platypus_type == FFI_PL_EXOTIC_FLOAT) { switch(self->argument_types[i]->ffi_type->type) { case FFI_TYPE_LONGDOUBLE: fprintf(stderr, " %Lg", *((long double*)argument_pointers[i])); break; case FFI_TYPE_COMPLEX: switch(self->argument_types[i]->ffi_type->size) { case 8: fprintf(stderr, " %g + %g * i", crealf(*((float complex*)argument_pointers[i])), cimagf(*((float complex*)argument_pointers[i])) ); break; case 16: fprintf(stderr, " %g + %g * i", creal(*((double complex*)argument_pointers[i])), cimag(*((double complex*)argument_pointers[i])) ); break; } } } else { fprintf(stderr, "%016llx", ffi_pl_arguments_get_uint64(arguments, i)); } fprintf(stderr, "\n"); } fprintf(stderr, "# === ===\n"); fflush(stderr); #endif MY_CXT.current_argv = NULL; if(self->address != NULL) { ffi_call(&self->ffi_cif, self->address, &result, ffi_pl_arguments_pointers(arguments)); } else { void *address = self->ffi_cif.nargs > 0 ? (void*) &cast1 : (void*) &cast0; ffi_call(&self->ffi_cif, address, &result, ffi_pl_arguments_pointers(arguments)); } /* * ARGUMENT OUT */ MY_CXT.current_argv = arguments; for(i=self->ffi_cif.nargs-1,perl_arg_index--; i >= 0; i--, perl_arg_index--) { platypus_type platypus_type; platypus_type = self->argument_types[i]->platypus_type; if(platypus_type == FFI_PL_POINTER) { void *ptr = ffi_pl_arguments_get_pointer(arguments, i); if(ptr != NULL) { arg = perl_arg_index < items ? ST(perl_arg_index) : &PL_sv_undef; if(!SvREADONLY(SvRV(arg))) { switch(self->argument_types[i]->ffi_type->type) { case FFI_TYPE_UINT8: sv_setuv(SvRV(arg), *((uint8_t*)ptr)); break; case FFI_TYPE_SINT8: sv_setiv(SvRV(arg), *((int8_t*)ptr)); break; case FFI_TYPE_UINT16: sv_setuv(SvRV(arg), *((uint16_t*)ptr)); break; case FFI_TYPE_SINT16: sv_setiv(SvRV(arg), *((int16_t*)ptr)); break; case FFI_TYPE_UINT32: sv_setuv(SvRV(arg), *((uint32_t*)ptr)); break; case FFI_TYPE_SINT32: sv_setiv(SvRV(arg), *((int32_t*)ptr)); break; case FFI_TYPE_UINT64: #ifdef HAVE_IV_IS_64 sv_setuv(SvRV(arg), *((uint64_t*)ptr)); #else sv_setu64(SvRV(arg), *((uint64_t*)ptr)); #endif break; case FFI_TYPE_SINT64: #ifdef HAVE_IV_IS_64 sv_setiv(SvRV(arg), *((int64_t*)ptr)); #else sv_seti64(SvRV(arg), *((int64_t*)ptr)); #endif break; case FFI_TYPE_FLOAT: sv_setnv(SvRV(arg), *((float*)ptr)); break; case FFI_TYPE_POINTER: if( *((void**)ptr) == NULL) sv_setsv(SvRV(arg), &PL_sv_undef); else sv_setiv(SvRV(arg), PTR2IV(*((void**)ptr))); break; case FFI_TYPE_DOUBLE: sv_setnv(SvRV(arg), *((double*)ptr)); break; #ifdef FFI_PL_PROBE_LONGDOUBLE case FFI_TYPE_LONGDOUBLE: { SV *arg2 = SvRV(arg); ffi_pl_long_double_to_perl(arg2,(long double*)ptr); } break; #endif } } } Safefree_or_alloca(ptr); } else if(platypus_type == FFI_PL_ARRAY) { void *ptr = ffi_pl_arguments_get_pointer(arguments, i); int count = self->argument_types[i]->extra[0].array.element_count; arg = perl_arg_index < items ? ST(perl_arg_index) : &PL_sv_undef; if(SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVAV) { AV *av = (AV*) SvRV(arg); if(count == 0) count = av_len(av)+1; switch(self->argument_types[i]->ffi_type->type) { case FFI_TYPE_UINT8: for(n=0; nargument_types[i]->extra[0].custom_perl.argument_count; { SV *coderef = self->argument_types[i]->extra[0].custom_perl.perl_to_native_post; if(coderef != NULL) { arg = perl_arg_index < items ? ST(perl_arg_index) : &PL_sv_undef; ffi_pl_custom_perl_cb(coderef, arg, i); } } } #ifndef HAVE_ALLOCA else if(platypus_type == FFI_PL_EXOTIC_FLOAT) { void *ptr = argument_pointers[i]; Safefree_or_alloca(ptr); } #endif } if(self->return_type->platypus_type != FFI_PL_CUSTOM_PERL) Safefree_or_alloca(arguments); MY_CXT.current_argv = NULL; /* * RETURN VALUE */ if(self->return_type->platypus_type == FFI_PL_NATIVE) { int type = self->return_type->ffi_type->type; if(type == FFI_TYPE_VOID || (type == FFI_TYPE_POINTER && result.pointer == NULL)) { XSRETURN_EMPTY; } else { switch(self->return_type->ffi_type->type) { case FFI_TYPE_UINT8: #if defined FFI_PL_PROBE_BIGENDIAN XSRETURN_UV(result.uint8_array[3]); #elif defined FFI_PL_PROBE_BIGENDIAN64 XSRETURN_UV(result.uint8_array[7]); #else XSRETURN_UV(result.uint8); #endif break; case FFI_TYPE_SINT8: #if defined FFI_PL_PROBE_BIGENDIAN XSRETURN_IV(result.sint8_array[3]); #elif defined FFI_PL_PROBE_BIGENDIAN64 XSRETURN_IV(result.sint8_array[7]); #else XSRETURN_IV(result.sint8); #endif break; case FFI_TYPE_UINT16: #if defined FFI_PL_PROBE_BIGENDIAN XSRETURN_UV(result.uint16_array[1]); #elif defined FFI_PL_PROBE_BIGENDIAN64 XSRETURN_UV(result.uint16_array[3]); #else XSRETURN_UV(result.uint16); #endif break; case FFI_TYPE_SINT16: #if defined FFI_PL_PROBE_BIGENDIAN XSRETURN_IV(result.sint16_array[1]); #elif defined FFI_PL_PROBE_BIGENDIAN64 XSRETURN_IV(result.sint16_array[3]); #else XSRETURN_IV(result.sint16); #endif break; case FFI_TYPE_UINT32: #if defined FFI_PL_PROBE_BIGENDIAN64 XSRETURN_UV(result.uint32_array[1]); #else XSRETURN_UV(result.uint32); #endif break; case FFI_TYPE_SINT32: #if defined FFI_PL_PROBE_BIGENDIAN64 XSRETURN_IV(result.sint32_array[1]); #else XSRETURN_IV(result.sint32); #endif break; case FFI_TYPE_UINT64: #ifdef HAVE_IV_IS_64 XSRETURN_UV(result.uint64); #else { ST(0) = sv_newmortal(); sv_setu64(ST(0), result.uint64); XSRETURN(1); } #endif break; case FFI_TYPE_SINT64: #ifdef HAVE_IV_IS_64 XSRETURN_IV(result.sint64); #else { ST(0) = sv_newmortal(); sv_seti64(ST(0), result.uint64); XSRETURN(1); } #endif break; case FFI_TYPE_FLOAT: XSRETURN_NV(result.xfloat); break; case FFI_TYPE_DOUBLE: XSRETURN_NV(result.xdouble); break; case FFI_TYPE_POINTER: XSRETURN_IV(PTR2IV(result.pointer)); break; } } } else if(self->return_type->platypus_type == FFI_PL_STRING) { if( result.pointer == NULL ) { XSRETURN_EMPTY; } else { if(self->return_type->extra[0].string.platypus_string_type == FFI_PL_STRING_FIXED) { SV *value = sv_newmortal(); sv_setpvn(value, result.pointer, self->return_type->extra[0].string.size); ST(0) = value; XSRETURN(1); } else { XSRETURN_PV(result.pointer); } } } else if(self->return_type->platypus_type == FFI_PL_POINTER) { if(result.pointer == NULL) { XSRETURN_EMPTY; } else { SV *value; switch(self->return_type->ffi_type->type) { case FFI_TYPE_UINT8: value = sv_newmortal(); sv_setuv(value, *((uint8_t*) result.pointer)); break; case FFI_TYPE_SINT8: value = sv_newmortal(); sv_setiv(value, *((int8_t*) result.pointer)); break; case FFI_TYPE_UINT16: value = sv_newmortal(); sv_setuv(value, *((uint16_t*) result.pointer)); break; case FFI_TYPE_SINT16: value = sv_newmortal(); sv_setiv(value, *((int16_t*) result.pointer)); break; case FFI_TYPE_UINT32: value = sv_newmortal(); sv_setuv(value, *((uint32_t*) result.pointer)); break; case FFI_TYPE_SINT32: value = sv_newmortal(); sv_setiv(value, *((int32_t*) result.pointer)); break; case FFI_TYPE_UINT64: value = sv_newmortal(); #ifdef HAVE_IV_IS_64 sv_setuv(value, *((uint64_t*) result.pointer)); #else sv_seti64(value, *((int64_t*) result.pointer)); #endif break; case FFI_TYPE_SINT64: value = sv_newmortal(); #ifdef HAVE_IV_IS_64 sv_setiv(value, *((int64_t*) result.pointer)); #else sv_seti64(value, *((int64_t*) result.pointer)); #endif break; case FFI_TYPE_FLOAT: value = sv_newmortal(); sv_setnv(value, *((float*) result.pointer)); break; case FFI_TYPE_DOUBLE: value = sv_newmortal(); sv_setnv(value, *((double*) result.pointer)); break; case FFI_TYPE_POINTER: value = sv_newmortal(); if( *((void**)result.pointer) == NULL ) value = &PL_sv_undef; else sv_setiv(value, PTR2IV(*((void**)result.pointer))); break; #ifdef FFI_PL_PROBE_LONGDOUBLE case FFI_TYPE_LONGDOUBLE: value = sv_newmortal(); ffi_pl_long_double_to_perl(value, (long double*)result.pointer); break; #endif default: warn("return type not supported"); XSRETURN_EMPTY; } ST(0) = newRV_inc(value); XSRETURN(1); } } else if(self->return_type->platypus_type == FFI_PL_RECORD) { if(result.pointer != NULL) { SV *value = sv_newmortal(); sv_setpvn(value, result.pointer, self->return_type->extra[0].record.size); if(self->return_type->extra[0].record.stash) { SV *ref = ST(0) = newRV_inc(value); sv_bless(ref, self->return_type->extra[0].record.stash); } else { ST(0) = value; } XSRETURN(1); } else { XSRETURN_EMPTY; } } else if(self->return_type->platypus_type == FFI_PL_ARRAY) { if(result.pointer == NULL) { XSRETURN_EMPTY; } else { int count = self->return_type->extra[0].array.element_count; AV *av; SV **sv; Newx(sv, count, SV*); switch(self->return_type->ffi_type->type) { case FFI_TYPE_UINT8: for(i=0; ireturn_type->platypus_type == FFI_PL_CUSTOM_PERL) { SV *ret_in=NULL, *ret_out; switch(self->return_type->ffi_type->type) { case FFI_TYPE_UINT8: #if defined FFI_PL_PROBE_BIGENDIAN ret_in = newSVuv(result.uint8_array[3]); #elif defined FFI_PL_PROBE_BIGENDIAN64 ret_in = newSVuv(result.uint8_array[7]); #else ret_in = newSVuv(result.uint8); #endif break; case FFI_TYPE_SINT8: #if defined FFI_PL_PROBE_BIGENDIAN ret_in = newSViv(result.sint8_array[3]); #elif defined FFI_PL_PROBE_BIGENDIAN64 ret_in = newSViv(result.sint8_array[7]); #else ret_in = newSViv(result.sint8); #endif break; case FFI_TYPE_UINT16: #if defined FFI_PL_PROBE_BIGENDIAN ret_in = newSVuv(result.uint16_array[1]); #elif defined FFI_PL_PROBE_BIGENDIAN64 ret_in = newSVuv(result.uint16_array[3]); #else ret_in = newSVuv(result.uint16); #endif break; case FFI_TYPE_SINT16: #if defined FFI_PL_PROBE_BIGENDIAN ret_in = newSViv(result.sint16_array[1]); #elif defined FFI_PL_PROBE_BIGENDIAN64 ret_in = newSViv(result.sint16_array[3]); #else ret_in = newSViv(result.sint16); #endif break; case FFI_TYPE_UINT32: #if defined FFI_PL_PROBE_BIGENDIAN64 ret_in = newSVuv(result.uint32_array[1]); #else ret_in = newSVuv(result.uint32); #endif break; case FFI_TYPE_SINT32: #if defined FFI_PL_PROBE_BIGENDIAN64 ret_in = newSViv(result.sint32_array[1]); #else ret_in = newSViv(result.sint32); #endif break; case FFI_TYPE_UINT64: #ifdef HAVE_IV_IS_64 ret_in = newSVuv(result.uint64); #else ret_in = newSVu64(result.uint64); #endif break; case FFI_TYPE_SINT64: #ifdef HAVE_IV_IS_64 ret_in = newSViv(result.sint64); #else ret_in = newSVi64(result.sint64); #endif break; case FFI_TYPE_FLOAT: ret_in = newSVnv(result.xfloat); break; case FFI_TYPE_DOUBLE: ret_in = newSVnv(result.xdouble); break; case FFI_TYPE_POINTER: if(result.pointer != NULL) ret_in = newSViv(PTR2IV(result.pointer)); break; default: Safefree_or_alloca(arguments); warn("return type not supported"); XSRETURN_EMPTY; } MY_CXT.current_argv = arguments; ret_out = ffi_pl_custom_perl( self->return_type->extra[0].custom_perl.native_to_perl, ret_in != NULL ? ret_in : &PL_sv_undef, -1 ); MY_CXT.current_argv = NULL; Safefree_or_alloca(arguments); if(ret_in != NULL) { SvREFCNT_dec(ret_in); } if(ret_out == NULL) { XSRETURN_EMPTY; } else { ST(0) = sv_2mortal(ret_out); XSRETURN(1); } } else if(self->return_type->platypus_type == FFI_PL_EXOTIC_FLOAT) { switch(self->return_type->ffi_type->type) { #ifdef FFI_PL_PROBE_LONGDOUBLE case FFI_TYPE_LONGDOUBLE: { if(MY_CXT.have_math_longdouble) { SV *sv; long double *ptr; Newx(ptr, 1, long double); *ptr = result.longdouble; sv = sv_newmortal(); sv_setref_pv(sv, "Math::LongDouble", (void*)ptr); ST(0) = sv; XSRETURN(1); } else { XSRETURN_NV((NV) result.longdouble); } } #endif } } warn("return type not supported"); XSRETURN_EMPTY; #undef EXTRA_ARGS Declare.pm100644001750001750 2564313065045605 20643 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFI/Platypuspackage FFI::Platypus::Declare; use strict; use warnings; use FFI::Platypus; # ABSTRACT: Declarative interface to FFI::Platypus our $VERSION = '0.47'; # VERSION our $ffi = {}; our $types = {}; sub _ffi_object { my($package, $filename) = caller(1); $ffi->{$package} ||= FFI::Platypus->new->package($package,$filename); } sub lib (@) { _ffi_object->lib(@_); } sub type ($;$) { _ffi_object->type(@_); } sub custom_type ($$) { _ffi_object->custom_type(@_); } sub load_custom_type ($$;@) { _ffi_object->load_custom_type(@_); } sub type_meta($) { _ffi_object->type_meta(@_); } my $inner_counter = 0; sub attach ($$$;$$) { my($caller, $filename, $line) = caller; my $wrapper; $wrapper = pop if ref($_[-1]) eq 'CODE'; my($name, $args, $ret, $proto) = @_; my($symbol_name, $perl_name) = ref $name ? (@$name) : ($name, $name); my $function = _ffi_object->function($symbol_name, $args, $ret); my $attach_name = $perl_name = join '::', $caller, $perl_name; if($wrapper) { $attach_name = "FFI::Platypus::Declare::Inner::xsub$inner_counter"; $inner_counter++; } $function->attach($attach_name, "$filename:$line", $proto); if($wrapper) { my $inner = \&{$attach_name}; no strict 'refs'; *{$perl_name} = sub { $wrapper->($inner, @_) }; } (); } sub closure (&) { my($coderef) = @_; FFI::Platypus::Closure->new($coderef); } sub cast ($$$) { _ffi_object->cast(@_); } sub attach_cast ($$$) { my($name, $type1, $type2) = @_; my $caller = caller; $name = join '::', $caller, $name; _ffi_object->attach_cast($name, $type1, $type2); } sub sizeof ($) { _ffi_object->sizeof($_[0]); } sub lang ($) { _ffi_object->lang($_[0]); } sub abi ($) { _ffi_object->abi($_[0]); } sub import { my $caller = caller; shift; # class foreach my $arg (@_) { if(ref $arg) { if($arg->[0] =~ /::/) { _ffi_object->load_custom_type(@$arg); no strict 'refs'; *{join '::', $caller, $arg->[1]} = sub () { $arg->[1] }; } else { _ffi_object->type(@$arg); no strict 'refs'; *{join '::', $caller, $arg->[1]} = sub () { $arg->[0] }; } } else { _ffi_object->type($arg); no strict 'refs'; *{join '::', $caller, $arg} = sub () { $arg }; } } no strict 'refs'; *{join '::', $caller, 'lib'} = \&lib; *{join '::', $caller, 'type'} = \&type; *{join '::', $caller, 'type_meta'} = \&type_meta; *{join '::', $caller, 'custom_type'} = \&custom_type; *{join '::', $caller, 'load_custom_type'} = \&load_custom_type; *{join '::', $caller, 'attach'} = \&attach; *{join '::', $caller, 'closure'} = \&closure; *{join '::', $caller, 'sticky'} = \&sticky; *{join '::', $caller, 'cast'} = \&cast; *{join '::', $caller, 'attach_cast'} = \&attach_cast; *{join '::', $caller, 'sizeof'} = \&sizeof; *{join '::', $caller, 'lang'} = \⟨ *{join '::', $caller, 'abi'} = \&abi; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Declare - Declarative interface to FFI::Platypus =head1 VERSION version 0.47 =head1 SYNOPSIS use FFI::Platypus::Declare 'string', 'int'; lib undef; # use libc attach puts => [string] => int; puts("hello world"); =head1 DESCRIPTION This module is officially B. The idea was to provide a simpler declarative interface without the need of (directly) creating an L instance. In practice it is almost as complicated and makes it difficult to upgrade to the proper OO interface if the need arises. I have stopped using it mainly for this reason. It will remain as part of the Platypus core distribution to keep old code working, but you are encouraged to write new code using the OO interface. Alternatively, you can try the Perl 6 inspired L, which provides most of the goals this module was intended for (that is a simple interface at the cost of some power), without much of the complexity. The remainder of this document describes the interface. This module provides a declarative interface to L. It provides a more concise interface at the cost of a little less power, and a little more namespace pollution. Any strings passed into the C line will be declared as types and exported as constants into your namespace, so that you can use them without quotation marks. Aliases can be declared using a list reference: use FFI::Platypus [ 'int[48]' => 'my_integer_array' ]; Custom types can also be declared as a list reference (the type name must include a ::): use FFI::Platypus [ '::StringPointer' => 'my_string_pointer' ]; # short for FFI::Platypus::Type::StringPointer =head1 FUNCTIONS All functions are exported into your namespace. If you do not want that, then use the OO interface (see L). =head2 lib lib $libpath; Specify one or more dynamic libraries to search for symbols. If you are unsure of the location / version of the library then you can use L. =head2 type type $type; type $type = $alias; Declare the given type. Examples: type 'uint8'; # only really checks that uint8 is a valid type type 'uint8' => 'my_unsigned_int_8'; =head2 custom_type custom_type $alias => \%args; Declare the given custom type. See L for details. =head2 load_custom_type load_custom_type $name => $alias, @type_args; Load the custom type defined in the module I<$name>, and make an alias with the name I<$alias>. If the custom type requires any arguments, they may be passed in as I<@type_args>. See L for details. If I<$name> contains C<::> then it will be assumed to be a fully qualified package name. If not, then C will be prepended to it. =head2 type_meta my $meta = type_meta $type; Get the type meta data for the given type. Example: my $meta = type_meta 'int'; =head2 attach attach $name => \@argument_types => $return_type; attach [$c_name => $perl_name] => \@argument_types => $return_type; attach [$address => $perl_name] => \@argument_types => $return_type; Find and attach a C function as a Perl function as a real live xsub. If just one I<$name> is given, then the function will be attached in Perl with the same name as it has in C. The second form allows you to give the Perl function a different name. You can also provide a memory address (the third form) of a function to attach. Examples: attach 'my_function', ['uint8'] => 'string'; attach ['my_c_function_name' => 'my_perl_function_name'], ['uint8'] => 'string'; my $string1 = my_function($int); my $string2 = my_perl_function_name($int); =head2 closure my $closure = closure $codeblock; Create a closure that can be passed into a C function. For details on closures, see L. Example: my $closure1 = closure { return $_[0] * 2 }; my $closure2 = closure sub { return $_[0] * 4 }; =head2 sticky my $closure = sticky closure $codeblock; Keyword to indicate the closure should not be deallocated for the life of the current process. If you pass a closure into a C function without saving a reference to it like this: foo(closure { ... }); # BAD Perl will not see any references to it and try to free it immediately. (this has to do with the way Perl and C handle responsibilities for memory allocation differently). One fix for this is to make sure the closure remains in scope using either C or C. If you know the closure will need to remain in existence for the life of the process (or if you do not care about leaking memory), then you can add the sticky keyword to tell L to keep the thing in memory. foo(sticky closure { ... }); # OKAY =head2 cast my $converted_value = cast $original_type, $converted_type, $original_value; The C function converts an existing I<$original_value> of type I<$original_type> into one of type I<$converted_type>. Not all types are supported, so care must be taken. For example, to get the address of a string, you can do this: my $address = cast 'string' => 'opaque', $string_value; =head2 attach_cast attach_cast "cast_name", $original_type, $converted_type; my $converted_value = cast_name($original_value); This function creates a subroutine which can be used to convert variables just like the L function above. The above synopsis is roughly equivalent to this: sub cast_name { cast($original_type, $converted_type, $_[0]) } my $converted_value = cast_name($original_value); Except that the L variant will be much faster if called multiple times since the cast does not need to be dynamically allocated on each instance. =head2 sizeof my $size = sizeof $type; Returns the total size of the given type. For example to get the size of an integer: my $intsize = sizeof 'int'; # usually 4 or 8 depending on platform You can also get the size of arrays my $intarraysize = sizeof 'int[64]'; Keep in mind that "pointer" types will always be the pointer / word size for the platform that you are using. This includes strings, opaque and pointers to other types. This function is not very fast, so you might want to save this value as a constant, particularly if you need the size in a loop with many iterations. =head2 lang lang $language; Specifies the foreign language that you will be interfacing with. The default is C. The foreign language specified with this attribute changes the default native types (for example, if you specify L, you will get C as an alias for C instead of C as you do with L). In the future this may attribute may offer hints when doing demangling of languages that require it like L. =head2 abi abi $abi; Set the ABI or calling convention for use in subsequent calls to L. May be either a string name or integer value from L. =head1 SEE ALSO =over 4 =item L Object oriented interface to Platypus. =item L Type definitions for Platypus. =item L Custom types API for Platypus. =item L memory functions for FFI. =item L Find dynamic libraries in a portable way. =item L JIT compiler for FFI. =item L Alternate interface to libffi with fewer features. It notably lacks the ability to create real xsubs, which may make L much faster. =back =head1 AUTHOR Author: Graham Ollis Eplicease@cpan.orgE Contributors: Bakkiaraj Murugesan (bakkiaraj) Dylan Cali (calid) pipcet Zaki Mughal (zmughal) Fitz Elliott (felliott) Vickenty Fesunov (vyf) Gregor Herrmann (gregoa) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Graham Ollis. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut ffi_platypus_find_symbol.t100644001750001750 133213065045605 21442 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 2; use File::Spec; use FFI::Platypus; use FFI::CheckLib; subtest external => sub { plan tests => 2; my $ffi = FFI::Platypus->new; $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'); my $good = $ffi->find_symbol('f0'); ok $good, "ffi.find_symbol(f0) = $good"; my $bad = $ffi->find_symbol('bogus'); is $bad, undef, 'ffi.find_symbol(bogus) = undef'; }; subtest internal => sub { plan tests => 2; my $ffi = FFI::Platypus->new; $ffi->lib(undef); my $good = $ffi->find_symbol('printf'); ok $good, "ffi.find_symbol(printf) = $good"; my $bad = $ffi->find_symbol('bogus'); is $bad, undef, 'ffi.find_symbol(bogus) = undef'; }; ffi_platypus_custom_type.t100644001750001750 353013065045605 21512 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More; use FFI::Platypus; use JSON::PP; BEGIN { eval q{ use YAML () } }; sub xdump ($) { my($object) = @_; note(YAML->can('Dump') ? YAML::Dump($object) : JSON::PP->new->allow_unknown->encode($object)); } my $ffi = FFI::Platypus->new; my @basic_types = (qw( float double opaque ), map { ("uint$_", "sint$_") } (8,16,32,64)); plan tests => scalar @basic_types; foreach my $basic (@basic_types) { subtest $basic => sub { plan tests => 6; eval { $ffi->custom_type("foo_${basic}_1", { native_type => $basic, perl_to_native => sub {} }) }; is $@, '', 'ffi.custom_type 1'; xdump({ "${basic}_1" => $ffi->type_meta("foo_${basic}_1") }); eval { $ffi->custom_type("bar_${basic}_1", { native_type => $basic, native_to_perl => sub {} }) }; is $@, '', 'ffi.custom_type 1'; xdump({ "${basic}_1" => $ffi->type_meta("bar_${basic}_1") }); eval { $ffi->custom_type("baz_${basic}_1", { native_type => $basic, perl_to_native => sub {}, native_to_perl => sub {} }) }; is $@, '', 'ffi.custom_type 1'; xdump({ "${basic}_1" => $ffi->type_meta("baz_${basic}_1") }); eval { $ffi->custom_type("foo_${basic}_2", { native_type => $basic, perl_to_native => sub {}, perl_to_native_post => sub { } }) }; is $@, '', 'ffi.custom_type 1'; xdump({ "${basic}_1" => $ffi->type_meta("foo_${basic}_2") }); eval { $ffi->custom_type("bar_${basic}_2", { native_type => $basic, native_to_perl => sub {}, perl_to_native_post => sub { } }) }; is $@, '', 'ffi.custom_type 1'; xdump({ "${basic}_1" => $ffi->type_meta("bar_${basic}_2") }); eval { $ffi->custom_type("baz_${basic}_2", { native_type => $basic, perl_to_native => sub {}, native_to_perl => sub {}, perl_to_native_post => sub { } }) }; is $@, '', 'ffi.custom_type 1'; xdump({ "${basic}_1" => $ffi->type_meta("baz_${basic}_2") }); }; } ffi_platypus_attach_void.t100644001750001750 67513065045605 21413 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 2; use FFI::Platypus; use FFI::CheckLib; my $ffi = FFI::Platypus->new; $ffi->lib(find_lib lib => 'test', symbol => 'f2', libpath => 'libtest'); $ffi->attach('f2' => ['int*'] => 'void'); $ffi->attach([f2=>'f2_implicit'] => ['int*']); my $i_ptr = 42; f2(\$i_ptr); is $i_ptr, 43, '$i_ptr = 43 after f2(\$i_ptr)'; f2_implicit(\$i_ptr); is $i_ptr, 44, '$i_ptr = 44 after f2_implicit(\$i_ptr)'; ffi_platypus_declare_abi.t100644001750001750 102613065045605 21347 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More; use FFI::Platypus::Declare; my %abis = %{ FFI::Platypus->abis }; plan tests => 2 + scalar keys %abis; ok defined $abis{default_abi}, 'has a default ABI'; foreach my $abi (keys %abis) { subtest $abi => sub { eval { abi $abi }; is $@, '', 'string'; eval { abi $abis{$abi} }; is $@, '', 'integer'; }; } subtest 'bogus' => sub { eval { abi 'bogus' }; like $@, qr{no such ABI: bogus}, 'string'; eval { abi 999999 }; like $@, qr{no such ABI: 999999}, 'integer'; }; ASM.pm100644001750001750 332613065045605 20557 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFI/Platypus/Langpackage FFI::Platypus::Lang::ASM; use strict; use warnings; # ABSTRACT: Documentation and tools for using Platypus with the Assembly our $VERSION = '0.47'; # VERSION sub native_type_map { {} } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Lang::ASM - Documentation and tools for using Platypus with the Assembly =head1 VERSION version 0.47 =head1 SYNOPSIS use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lang('ASM'); =head1 DESCRIPTION Setting your lang to C includes no native type aliases, so types like C or C will not work. You need to specify instead C or C. Although intended for use with Assembly it could also be used for other languages if you did not want to use the normal C aliases for native types. This document will one day include information on bundling Assembly with your Perl / FFI / Platypus distribution. Pull requests welcome! =head1 METHODS =head2 native_type_map my $hashref = FFI::Platypus::Lang::ASM->native_type_map; This returns an empty hash reference. For other languages it returns a hash reference that defines the aliases for the types normally used for that language. =head1 SEE ALSO =over 4 =item L The Core Platypus documentation. =back =head1 AUTHOR Author: Graham Ollis Eplicease@cpan.orgE Contributors: Bakkiaraj Murugesan (bakkiaraj) Dylan Cali (calid) pipcet Zaki Mughal (zmughal) Fitz Elliott (felliott) Vickenty Fesunov (vyf) Gregor Herrmann (gregoa) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Graham Ollis. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut ffi_platypus_declare_cast.t100644001750001750 275513065045605 21560 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 3; use FFI::Platypus::Declare; use FFI::CheckLib; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach string_matches_foobarbaz => ['opaque'] => 'int'; attach string_return_foobarbaz => [] => 'opaque'; attach string_set_closure => ['opaque'] => 'void'; attach string_call_closure => ['string'] => 'void'; subtest 'cast from string to pointer' => sub { plan tests => 2; my $string = "foobarbaz"; my $pointer = cast string => opaque => $string; is string_matches_foobarbaz($pointer), 1, 'dynamic'; attach_cast cast1 => string => 'opaque'; my $pointer2 = cast1($string); is string_matches_foobarbaz($pointer2), 1, 'static'; }; subtest 'cast from pointer to string' => sub { plan tests => 2; my $pointer = string_return_foobarbaz(); my $string = cast opaque => string => $pointer; is $string, "foobarbaz", "dynamic"; attach_cast cast2 => pointer => 'string'; my $string2 = cast2($pointer); is $string2, "foobarbaz", "static"; }; subtest 'cast closure to opaque' => sub { plan tests => 2; my $testname = 'dynamic'; my $closure = closure { is $_[0], "testvalue", $testname }; my $pointer = cast '(string)->void' => opaque => $closure; string_set_closure($pointer); string_call_closure("testvalue"); attach_cast 'cast3', '(string)->void' => 'opaque'; my $pointer2 = cast3($closure); $testname = 'static'; string_set_closure($pointer2); string_call_closure("testvalue"); }; ffi_platypus_type_private.t100644001750001750 212113065045605 21645 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 15; use FFI::Platypus; # this tests the private OO type API used only internally # to FFI::Platypus. DO NOT USE FFI::Platypus::Type # its interface can and WILL change. my @names = qw( void uint8 sint8 uint16 sint16 uint32 sint32 uint64 sint64 float double longdouble opaque pointer ); foreach my $name (@names) { subtest $name => sub { plan skip_all => 'test requires longdouble support' unless FFI::Platypus::_have_type($name); plan tests => 3; my $type = eval { FFI::Platypus::Type->new($name) }; is $@, '', "type = FFI::Platypus::Type->new($name)"; isa_ok $type, 'FFI::Platypus::Type'; my $expected = $name eq 'opaque' ? 'pointer' : $name; is eval { $type->meta->{ffi_type} }, $expected, "type.meta.ffi_type = $expected"; } } subtest string => sub { plan tests => 3; my $type = eval { FFI::Platypus::Type->new('string') }; is $@, '', "type = FFI::Platypus::Type->new(string)"; isa_ok $type, 'FFI::Platypus::Type'; is eval { $type->meta->{ffi_type} }, 'pointer', 'type.meta.ffi_type = pointer'; }; ffi_platypus_declare_lang.t100644001750001750 165513065045605 21545 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 2; subtest C => sub { plan tests => 3; package Test1; use Test::More; use FFI::Platypus::Declare; eval { type 'int' }; is $@, '', 'int is an okay type'; eval { type 'foo_t' }; isnt $@, '', 'foo_t is not an okay type'; note $@; eval { type 'sint16' }; is $@, '', 'sint16 is an okay type'; }; subtest 'Foo constructor' => sub { plan tests => 5; package Test2; use Test::More; use FFI::Platypus::Declare; lang 'Foo'; eval { type 'int' }; isnt $@, '', 'int is not an okay type'; note $@; eval { type 'foo_t' }; is $@, '', 'foo_t is an okay type'; eval { type 'sint16' }; is $@, '', 'sint16 is an okay type'; is sizeof('foo_t'), 2, 'sizeof foo_t = 2'; is sizeof('bar_t'), 4, 'sizeof foo_t = 4'; }; package FFI::Platypus::Lang::Foo; sub native_type_map { { foo_t => 'sint16', bar_t => 'uint32', } } list_integer_types.pl100644001750001750 42013065045605 21764 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new; foreach my $type_name (sort FFI::Platypus->types) { my $meta = $ffi->type_meta($type_name); next unless $meta->{element_type} eq 'int'; printf "%20s %s\n", $type_name, $meta->{ffi_type}; } Win32.pm100644001750001750 1500513065045605 21056 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFI/Platypus/Langpackage FFI::Platypus::Lang::Win32; use strict; use warnings; use Config; # ABSTRACT: Documentation and tools for using Platypus with the Windows API our $VERSION = '0.47'; # VERSION sub abi { $^O =~ /^(cygwin|MSWin32|msys)$/ && $Config{ptrsize} == 4 ? 'stdcall' : 'default_abi'; } my %map; sub native_type_map { unless(%map) { require FFI::Platypus::ShareConfig; %map = %{ FFI::Platypus::ShareConfig->get('type_map') }; my %win32_map = qw( BOOL int BOOLEAN BYTE BYTE uchar CCHAR char CHAR char COLORREF DWORD DWORD uint DWORDLONG uint64 DWORD_PTR ULONG_PTR DWORD32 uint32 DWORD64 uint64 FLOAT float HACCEL HANDLE HANDLE PVOID HBITMAP HANDLE HBRUSH HANDLE HCOLORSPACE HANDLE HCONV HANDLE HCONVLIST HANDLE HCURSOR HICON HDC HANDLE HDDEDATA HANDLE HDESK HANDLE HDROP HANDLE HDWP HANDLE HENHMETAFILE HANDLE HFILE int HFONT HANDLE HGDIOBJ HANDLE HGLOBAL HANDLE HHOOK HANDLE HICON HANDLE HINSTANCE HANDLE HKEY HANDLE HKL HANDLE HLOCAL HANDLE HMENU HANDLE HMETAFILE HANDLE HMODULE HINSTANCE HMONITOR HANDLE HPALETTE HANDLE HPEN HANDLE HRESULT LONG HRGN HANDLE HRSRC HANDLE HSZ HANDLE HWINSTA HANDLE HWND HANDLE INT int INT8 sint8 INT16 sint16 INT32 sint32 INT64 sint64 LANGID WORD LCID DWORD LCTYPE DWORD LGRPID DWORD LONG sint32 LONGLONG sint64 LONG32 sint32 LONG64 sint64 LPCSTR string LPCVOID opaque LPVOID opaque LRESULT LONG_PTR PSTR string PVOID opaque QWORD uint64 SC_HANDLE HANDLE SC_LOCK LPVOID SERVICE_STATUS_HANDLE HANDLE SHORT sint16 SIZE_T ULONG_PTR SSIZE_T LONG_PTR UCHAR uint8 UINT8 uint8 UINT16 uint16 UINT32 uint32 UINT64 uint64 ULONG uint32 ULONGLONG uint64 ULONG32 uint32 ULONG64 uint64 USHORT uint16 USN LONGLONG VOID void WORD uint16 WPARAM UINT_PTR ); if($Config{ptrsize} == 4) { $win32_map{HALF_PTR} = 'sint16'; $win32_map{INT_PTR} = 'sint32'; $win32_map{LONG_PTR} = 'sint16'; $win32_map{UHALF_PTR} = 'uint16'; $win32_map{UINT_PTR} = 'uint32'; $win32_map{ULONG_PTR} = 'uint16'; } elsif($Config{ptrsize} == 8) { $win32_map{HALF_PTR} = 'sint16'; $win32_map{INT_PTR} = 'sint32'; $win32_map{LONG_PTR} = 'sint16'; $win32_map{UHALF_PTR} = 'uint16'; $win32_map{UINT_PTR} = 'uint32'; $win32_map{ULONG_PTR} = 'uint16'; } else { die "interesting word size you have"; } foreach my $alias (keys %win32_map) { my $type = $alias; while(1) { if($type =~ /^(opaque|[us]int(8|16|32|64)|float|double|string|void)$/) { $map{$alias} = $type; last; } if(defined $map{$type}) { $map{$alias} = $map{$type}; last; } if(defined $win32_map{$type}) { $type = $win32_map{$type}; next; } die "unable to resolve $alias => ... => $type"; } } # stuff we are not yet dealing with # LPCTSTR is unicode string, not currently supported # LPWSTR 16 bit unicode string # TBYTE TCHAR UNICODE_STRING WCHAR # Not supported: POINTER_32 POINTER_64 POINTER_SIGNED POINTER_UNSIGNED } \%map; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Lang::Win32 - Documentation and tools for using Platypus with the Windows API =head1 VERSION version 0.47 =head1 SYNOPSIS use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->lang('Win32'); =head1 DESCRIPTION This module provides the Windows datatypes used by the Windows API. This means that you can use things like C as an alias for C. =head1 METHODS =head2 abi my $abi = FFI::Platypus::Lang::Win32->abi; =head2 native_type_map my $hashref = FFI::Platypus::Lang::Win32->native_type_map; This returns a hash reference containing the native aliases for the Windows API. That is the keys are native Windows API C types and the values are libffi native types. =head1 SEE ALSO =over 4 =item L The Core Platypus documentation. =back =head1 AUTHOR Author: Graham Ollis Eplicease@cpan.orgE Contributors: Bakkiaraj Murugesan (bakkiaraj) Dylan Cali (calid) pipcet Zaki Mughal (zmughal) Fitz Elliott (felliott) Vickenty Fesunov (vyf) Gregor Herrmann (gregoa) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Graham Ollis. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut ffi_platypus_memory__strdup.t100644001750001750 67113065045605 22172 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More; use FFI::Platypus; use FFI::Platypus::Memory; my $ffi = FFI::Platypus->new; $ffi->lib(undef); note "strdup implementation = $FFI::Platypus::Memory::_strdup_impl"; my $ptr1 = malloc 32; my $tmp = strdup "this and\0"; memcpy $ptr1, $tmp, 9; free $tmp; my $string = $ffi->cast('opaque' => 'string', $ptr1); is $string, 'this and', 'string = this and'; free $ptr1; ok 1, 'free $ptr1'; done_testing; ffi_platypus_memory__memcpy.t100644001750001750 110613065045605 22155 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More; use FFI::Platypus; use FFI::Platypus::Memory; my $ffi = FFI::Platypus->new; $ffi->lib(undef); my $ptr1 = malloc 64; my $ptr2 = malloc 64; $ffi->function(strcpy => ['opaque', 'string'] => 'opaque')->call($ptr1, "starscream"); is( $ffi->cast('opaque','string', $ptr1), "starscream", "initial data copied" ); my $ret = memcpy $ptr2, $ptr1, 64; is( $ffi->cast('opaque','string', $ptr2), "starscream", "copy of copy" ); is $ret, $ptr2, "memcpy returns a pointer"; free $ptr1; ok 1, 'free $ptr1'; free $ptr2; ok 1, 'free $ptr2'; done_testing; ffi_platypus_declare_sticky.t100644001750001750 70313065045605 22103 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 1; use FFI::CheckLib; use FFI::Platypus::Declare qw( uint8 void ), ['(uint8)->uint8' => 'closure_t']; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach [uint8_set_closure => 'set_closure'] => [closure_t] => void; attach [uint8_call_closure => 'call_closure'] => [uint8] => uint8; set_closure(sticky closure { $_[0] * 2 }); is call_closure(2), 4, 'call_closure(2) = 4'; ffi_platypus_declare_sizeof.t100644001750001750 26113065045605 22073 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 2; use FFI::Platypus::Declare; is sizeof 'uint32', 4, 'sizeof uint32 = 4'; is sizeof 'uint32[2]', 8, 'sizeof uint32[2] = 8'; attach_from_pointer.pl100644001750001750 51313065045605 22102 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examplesuse strict; use warnings; use FFI::TinyCC; use FFI::Platypus; my $ffi = FFI::Platypus->new; my $tcc = FFI::TinyCC->new; $tcc->compile_string(q{ int add(int a, int b) { return a+b; } }); my $address = $tcc->get_symbol('add'); $ffi->attach( [ $address => 'add' ] => ['int','int'] => 'int' ); print add(1,2), "\n"; win32_getSystemTime.pl100644001750001750 302713065045605 21723 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/examples#!perl # Author : Bakkiaraj M # Script: Get System time from windows OS using GetLocalTime API. use strict; use warnings; use FFI::CheckLib; use FFI::Platypus; use Convert::Binary::C; #Get the system time using Kernel32.dll #find the Kernel32.dll my $libPath = find_lib(lib=>'Kernel32'); #Create FFI Object my $ffiObj = FFI::Platypus->new(); $ffiObj->lib($libPath); #Import the GetLocalTime function $ffiObj->attach('GetLocalTime',['record(16)'],'void'); #Define SYSTEMTIME Struct as per https://msdn.microsoft.com/en-us/library/windows/desktop/ms724950(v=vs.85).aspx #As per, C:\MinGW\include\windef.h, WORD id unsigned short my $c = Convert::Binary::C->new->parse(<0, wMonth=>0, wDayOfWeek=>0, wDay=>0, wHour=>0, wMinute=>0, wSecond=>0, wMilliseconds=>0, }; my $packed = $c->pack('SYSTEMTIME', $dateStruct); #Call the function by passing the structure reference GetLocalTime($packed); if (defined ($packed)) { #Unpack the structure my $sysDate = $c->unpack('SYSTEMTIME', $packed); print "\n WINDOWS SYSTEM TIME: ",$$sysDate{'wHour'},':',$$sysDate{'wMinute'},':',$$sysDate{'wSecond'},'.',$$sysDate{'wMilliseconds'},' ',$$sysDate{'wDay'},'/',$$sysDate{'wMonth'},'/',$$sysDate{'wYear'}, "\n"; } else { print "\n Something is wrong\n"; } exit 0; ShareConfig.pm100644001750001750 203413065045605 21441 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFI/Platypuspackage FFI::Platypus::ShareConfig; use strict; use warnings; use File::ShareDir qw( dist_dir ); use File::Spec; use JSON::PP qw( decode_json ); our $VERSION = '0.47'; # VERSION sub get { my(undef, $name) = @_; my $config; unless($config) { my $fn = File::Spec->catfile(dist_dir('FFI-Platypus'), 'config.json'); my $fh; open $fh, '<', $fn; my $raw = do { local $/; <$fh> }; close $fh; $config = decode_json $raw; } $config->{$name}; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::ShareConfig =head1 VERSION version 0.47 =head1 AUTHOR Author: Graham Ollis Eplicease@cpan.orgE Contributors: Bakkiaraj Murugesan (bakkiaraj) Dylan Cali (calid) pipcet Zaki Mughal (zmughal) Fitz Elliott (felliott) Vickenty Fesunov (vyf) Gregor Herrmann (gregoa) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Graham Ollis. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut pod_spelling_common.t100644001750001750 135213065045605 22073 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xt/authoruse strict; use warnings; use Test::More; BEGIN { plan skip_all => 'test requires Test::Pod::Spelling::CommonMistakes' unless eval q{ use Test::Pod::Spelling::CommonMistakes; 1 }; plan skip_all => 'test requires YAML' unless eval q{ use YAML qw( LoadFile ); 1 }; }; use Test::Pod::Spelling::CommonMistakes; use FindBin; use File::Spec; my $config_filename = File::Spec->catfile( $FindBin::Bin, File::Spec->updir, File::Spec->updir, 'author.yml' ); my $config; $config = LoadFile($config_filename) if -r $config_filename; plan skip_all => 'disabled' if $config->{pod_spelling_common}->{skip}; chdir(File::Spec->catdir($FindBin::Bin, File::Spec->updir, File::Spec->updir)); # TODO: test files in bin too. all_pod_files_ok; pod_spelling_system.t100644001750001750 237213065045605 22132 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/xt/authoruse strict; use warnings; use Test::More; BEGIN { plan skip_all => 'test requires Test::Spelling' unless eval q{ use Test::Spelling; 1 }; plan skip_all => 'test requires YAML' unless eval q{ use YAML; 1; }; }; use Test::Spelling; use YAML qw( LoadFile ); use FindBin; use File::Spec; my $config_filename = File::Spec->catfile( $FindBin::Bin, File::Spec->updir, File::Spec->updir, 'author.yml' ); my $config; $config = LoadFile($config_filename) if -r $config_filename; plan skip_all => 'disabled' if $config->{pod_spelling_system}->{skip}; chdir(File::Spec->catdir($FindBin::Bin, File::Spec->updir, File::Spec->updir)); add_stopwords(@{ $config->{pod_spelling_system}->{stopwords} }); add_stopwords(qw( Plicease stdout stderr stdin subref loopback username os Ollis Mojolicious plicease CPAN reinstall TODO filename filenames login callback callbacks standalone VMS hostname hostnames TCP UDP IP API MSWin32 OpenBSD FreeBSD NetBSD unencrypted WebSocket WebSockets timestamp timestamps poney BackPAN portably RedHat AIX BSD XS FFI perlish optimizations subdirectory RESTful SQLite JavaScript dir plugins munge jQuery namespace PDF PDFs usernames DBI pluggable APIs SSL JSON YAML uncommented Solaris OpenVMS URI URL CGI )); all_pod_files_spelling_ok; ffi_platypus_record_tiearray.t100644001750001750 122113065045605 22310 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 45; do { package Foo; use FFI::Platypus::Record; use FFI::Platypus::Record::TieArray; record_layout(qw( int[20] _bar )); sub bar { my($self) = @_; tie my @list, 'FFI::Platypus::Record::TieArray', $self, '_bar', 20; \@list; } }; my $foo = Foo->new( _bar => [1..20] ); isa_ok $foo, 'Foo'; is $foo->bar->[1], 2; $foo->bar->[1] = 22; is $foo->bar->[1], 22; is scalar(@{ $foo->bar }), 20; is $#{ $foo->bar}, 19; @{ $foo->bar } = (); is $foo->bar->[$_], 0 for 0..19; @{ $foo->bar } = (0..5); is $foo->bar->[$_], $_ for 0..5; is $foo->bar->[$_], 0 for 6..19; ffi_platypus_memory__realloc.t100644001750001750 107013065045605 22304 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More; use FFI::Platypus; use FFI::Platypus::Memory; my $ffi = FFI::Platypus->new; $ffi->lib(undef); my $ptr = realloc undef, 32; ok $ptr, "realloc call ptr = @{[ $ptr ]}"; $ffi->function(strcpy => ['opaque', 'string'] => 'opaque')->call($ptr, "hello"); is( $ffi->cast('opaque','string', $ptr), "hello", "initial data copied" ); $ptr = realloc $ptr, 1024*5; ok $ptr, "realloc call ptr = @{[ $ptr ]} (2)"; is( $ffi->cast('opaque','string', $ptr), "hello", "after realloc data there" ); free $ptr; ok 1, 'final free'; done_testing; ffi_platypus_closure_private.t100644001750001750 33113065045605 22321 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 2; use FFI::Platypus; my $closure = FFI::Platypus::Closure->new(sub { $_[0] + 1}); isa_ok $closure, 'FFI::Platypus::Closure'; is $closure->(1), 2, 'closure.(1) = 2'; accessor_wrapper.tt100644001750001750 47613065045605 22207 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/template/* DO NOT MODIFY THIS FILE it is generated from these files: * inc/template/accessor.tt * inc/template/accessor_wrapper.tt * inc/run/generate_record_accessor.pl */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #include "ffi_platypus.h" #include "ffi_platypus_guts.h" [% content %] ffi_platypus_ignore_not_found.t100644001750001750 615413065045605 22502 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 6; use FFI::Platypus; use FFI::CheckLib; my $lib = find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; note "lib=$lib"; subtest 'ignore_not_found=undef' => sub { plan tests => 4; my $ffi = FFI::Platypus->new; $ffi->lib($lib); my $f1 = eval { $ffi->function(f1 => [] => 'void') }; is $@, '', 'no exception'; ok ref($f1), 'returned a function'; note "f1 isa ", ref($f1); my $f2 = eval { $ffi->function(bogus => [] => 'void') }; isnt $@, '', 'function exception'; note "exception=$@"; eval { $ffi->attach(bogus => [] => 'void') }; isnt $@, '', 'attach exception'; note "exception=$@"; }; subtest 'ignore_not_found=0' => sub { plan tests => 4; my $ffi = FFI::Platypus->new; $ffi->lib($lib); $ffi->ignore_not_found(0); my $f1 = eval { $ffi->function(f1 => [] => 'void') }; is $@, '', 'no exception'; ok ref($f1), 'returned a function'; note "f1 isa ", ref($f1); my $f2 = eval { $ffi->function(bogus => [] => 'void') }; isnt $@, '', 'function exception'; note "exception=$@"; eval { $ffi->attach(bogus => [] => 'void') }; isnt $@, '', 'attach exception'; note "exception=$@"; }; subtest 'ignore_not_found=0 (constructor)' => sub { plan tests => 4; my $ffi = FFI::Platypus->new( ignore_not_found => 0 ); $ffi->lib($lib); my $f1 = eval { $ffi->function(f1 => [] => 'void') }; is $@, '', 'no exception'; ok ref($f1), 'returned a function'; note "f1 isa ", ref($f1); my $f2 = eval { $ffi->function(bogus => [] => 'void') }; isnt $@, '', 'function exception'; note "exception=$@"; eval { $ffi->attach(bogus => [] => 'void') }; isnt $@, '', 'attach exception'; note "exception=$@"; }; subtest 'ignore_not_found=1' => sub { plan tests => 5; my $ffi = FFI::Platypus->new; $ffi->lib($lib); $ffi->ignore_not_found(1); my $f1 = eval { $ffi->function(f1 => [] => 'void') }; is $@, '', 'no exception'; ok ref($f1), 'returned a function'; note "f1 isa ", ref($f1); my $f2 = eval { $ffi->function(bogus => [] => 'void') }; is $@, '', 'function no exception'; is $f2, undef, 'f2 is undefined'; eval { $ffi->attach(bogus => [] => 'void') }; is $@, '', 'attach no exception'; }; subtest 'ignore_not_found=1 (constructor)' => sub { plan tests => 5; my $ffi = FFI::Platypus->new( ignore_not_found => 1 ); $ffi->lib($lib); my $f1 = eval { $ffi->function(f1 => [] => 'void') }; is $@, '', 'no exception'; ok ref($f1), 'returned a function'; note "f1 isa ", ref($f1); my $f2 = eval { $ffi->function(bogus => [] => 'void') }; is $@, '', 'function no exception'; is $f2, undef, 'f2 is undefined'; eval { $ffi->attach(bogus => [] => 'void') }; is $@, '', 'attach no exception'; }; subtest 'ignore_not_found bool context' => sub { plan tests => 2; my $ffi = FFI::Platypus->new( ignore_not_found => 1 ); $ffi->lib($lib); my $f1 = eval { $ffi->function(f1 => [] => 'void') }; ok $f1, 'f1 exists and resolved to boolean true'; my $f2 = eval { $ffi->function(bogus => [] => 'void') }; ok !$f2, 'f2 does not exist and resolved to boolean false'; }; ffi_platypus_function_private.t100644001750001750 114713065045605 22520 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 4; use FFI::Platypus; use FFI::CheckLib; my $ffi = FFI::Platypus->new; $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'); my $address = $ffi->find_symbol('f0'); my $uint8 = FFI::Platypus::Type->new('uint8'); my $function = eval { FFI::Platypus::Function->new($ffi, $address, -1, $uint8, $uint8) }; is $@, '', 'FFI::Platypus::Function->new'; isa_ok $function, 'FFI::Platypus::Function'; is $function->call(22), 22, 'function.call(22) = 22'; $function->attach('main::fooble', 'whatever.c', undef); is fooble(22), 22, 'fooble(22) = 22'; generate_record_accessor.pl100644001750001750 125013065045605 22643 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/inc/runuse strict; use warnings; use autodie; use Template; my $tt2 = Template->new( INCLUDE_PATH => 'inc/template', ); my @list = map { ( { ffi_type => "uint$_", c_type => "uint${_}_t", perl_type => "UV", zero => "0" }, { ffi_type => "sint$_", c_type => "int${_}_t", perl_type => "IV", zero => "0" }, ) } (8,16,32,64); push @list, map { { ffi_type => $_, c_type => $_, perl_type => "NV", zero => "0.0" } } qw( float double ); my $content = ''; foreach my $config (@list) { $tt2->process("accessor.tt", $config, \$content) || die $tt2->error; } open my $fh, '>', 'xs/record_simple.c'; $tt2->process("accessor_wrapper.tt", { content => $content }, $fh); close $fh; Record000755001750001750 013065045605 17772 5ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFI/PlatypusTieArray.pm100644001750001750 462313065045605 22215 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFI/Platypus/Recordpackage FFI::Platypus::Record::TieArray; use strict; use warnings; use Carp qw( croak ); # ABSTRACT: Tied array interface for record array members our $VERSION = '0.47'; # VERSION sub TIEARRAY { my $class = shift; bless [ @_ ], $class; } sub FETCH { my($self, $key) = @_; my($obj, $member) = @$self; $obj->$member($key); } sub STORE { my($self, $key, $value) = @_; my($obj, $member) = @$self; $obj->$member($key, $value); } sub FETCHSIZE { my($self) = @_; $self->[2]; } sub CLEAR { my($self) = @_; my($obj, $member) = @$self; $obj->$member([]); } sub EXTEND { my($self, $count) = @_; croak "tried to extend a fixed length array" if $count > $self->[2]; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Record::TieArray - Tied array interface for record array members =head1 VERSION version 0.47 =head1 SYNOPSIS package Foo; use FFI::Platypus::Record; use FFI::Platypus::Record::TieArray; record_layout(qw( int[20] _bar )); sub bar { my($self, $arg) = @_; $self->_bar($arg) if ref($arg) eq ' ARRAY'; tie my @list, 'FFI::Platypus::Record::TieArray', $self, '_bar', 20; } package main; my $foo = Foo->new; my $bar5 = $foo->bar->[5]; # get the 5th element of the bar array $foo->bar->[5] = 10; # set the 5th element of the bar array @{ $foo->bar } = (); # set all elements in bar to 0 @{ $foo->bar } = (1..5); # set the first five elements of the bar array =head1 DESCRIPTION B: This module is considered EXPERIMENTAL. It may go away or be changed in incompatible ways, possibly without notice, but not without a good reason. This class provides a tie interface for record array members. In the future a short cut for using this with L directly may be provided. =head1 SEE ALSO =over 4 =item L The main Platypus documentation. =item L Documentation on Platypus records. =back =head1 AUTHOR Author: Graham Ollis Eplicease@cpan.orgE Contributors: Bakkiaraj Murugesan (bakkiaraj) Dylan Cali (calid) pipcet Zaki Mughal (zmughal) Fitz Elliott (felliott) Vickenty Fesunov (vyf) Gregor Herrmann (gregoa) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Graham Ollis. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut ffi_platypus_type_string_pointer.t100644001750001750 262713065045605 23254 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 3; use FFI::CheckLib; use FFI::Platypus::Declare qw( int string void ), [ '::StringPointer' => 'string_p']; lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach string_pointer_pointer_get => [string_p] => string; attach string_pointer_pointer_set => [string_p, string] => void; attach pointer_pointer_is_null => [string_p] => int; attach pointer_is_null => [string_p] => int; attach string_pointer_pointer_return => [string] => string_p; attach pointer_null => [] => string_p; subtest 'arg pass in' => sub { plan tests => 3; is string_pointer_pointer_get(\"hello there"), "hello there", "not null"; is pointer_pointer_is_null(\undef), 1, "\\undef is null"; is pointer_is_null(undef), 1, "undef is null"; }; subtest 'arg pass out' => sub { plan tests => 2; my $string = ''; string_pointer_pointer_set(\$string, "hi there"); is $string, "hi there", "not null string = $string"; my $string2; string_pointer_pointer_set(\$string2, "and another"); is $string2, "and another", "not null string = $string2"; }; subtest 'return value' => sub { plan tests => 3; my $string = "once more onto"; is_deeply string_pointer_pointer_return($string), \"once more onto", "not null string = $string"; is_deeply string_pointer_pointer_return(undef), \undef, "\\null"; my $value = pointer_null(); is $value, undef, "null"; }; Type000755001750001750 013065045605 17475 5ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFI/PlatypusStringPointer.pm100644001750001750 545213065045605 23010 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFI/Platypus/Typepackage FFI::Platypus::Type::StringPointer; use strict; use warnings; use FFI::Platypus; use Scalar::Util qw( readonly ); use Config (); # ABSTRACT: Convert a pointer to a string and back our $VERSION = '0.47'; # VERSION use constant _incantation => $^O eq 'MSWin32' && $Config::Config{archname} =~ /MSWin32-x64/ ? 'Q' : 'L!'; use constant _pointer_buffer => "P" . FFI::Platypus->new->sizeof('opaque'); my @stack; sub perl_to_native { if(defined $_[0]) { my $packed = pack 'P', ${$_[0]}; my $pointer_pointer = pack 'P', $packed; my $unpacked = unpack _incantation, $pointer_pointer; push @stack, [ \$packed, \$pointer_pointer ]; return $unpacked; } else { push @stack, []; return undef; } } sub perl_to_native_post { my($packed) = @{ pop @stack }; return unless defined $packed; unless(readonly(${$_[0]})) { ${$_[0]} = unpack 'p', $$packed; } } sub native_to_perl { return unless defined $_[0]; my $pointer_pointer = unpack(_incantation, unpack(_pointer_buffer, pack(_incantation, $_[0]))); $pointer_pointer ? \unpack('p', pack(_incantation, $pointer_pointer)) : \undef; } sub ffi_custom_type_api_1 { return { native_type => 'opaque', perl_to_native => \&perl_to_native, perl_to_native_post => \&perl_to_native_post, native_to_perl => \&native_to_perl, } } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Type::StringPointer - Convert a pointer to a string and back =head1 VERSION version 0.47 =head1 SYNOPSIS In your C code: void string_pointer_argument(const char **string) { ... } const char ** string_pointer_return(void) { ... } In your Platypus::FFI code: use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->load_custom_type('::StringPointer' => 'string_pointer'); $ffi->attach(string_pointer_argument => ['string_pointer'] => 'void'); $ffi->attach(string_pointer_return => [] => 'string_pointer'); my $string = "foo"; string_pointer_argument(\$string); # $string may be modified $ref = string_pointer_return(); print $$ref; # print the string pointed to by $ref =head1 DESCRIPTION This module provides a L custom type for pointers to strings. =head1 SEE ALSO =over 4 =item L Main Platypus documentation. =item L Platypus types documentation. =back =head1 AUTHOR Author: Graham Ollis Eplicease@cpan.orgE Contributors: Bakkiaraj Murugesan (bakkiaraj) Dylan Cali (calid) pipcet Zaki Mughal (zmughal) Fitz Elliott (felliott) Vickenty Fesunov (vyf) Gregor Herrmann (gregoa) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Graham Ollis. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut ffi_platypus_type_pointer_size_buffer.t100644001750001750 164213065045605 24245 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/tuse strict; use warnings; use Test::More tests => 5; use FFI::CheckLib; use FFI::Platypus::Memory qw( malloc ); use FFI::Platypus::Declare qw( void opaque string ), [ '::PointerSizeBuffer' => 'buffer_t2' ]; load_custom_type '::PointerSizeBuffer' => 'buffer_t'; lib undef; attach memcpy => [opaque, 'buffer_t'] => void; my $string = "luna park\0"; my $pointer = malloc length $string; memcpy($pointer, $string); my $string2 = cast opaque => string, $pointer; is $string2, 'luna park'; SKIP: { eval { attach snprintf => ['buffer_t', string ] => 'int' }; skip "test require working snprintf", 2 if $@; is snprintf($string2, "this is a very long string"), 26; is $string2, "this is \000"; } lib find_lib lib => 'test', symbol => 'f0', libpath => 'libtest'; attach memcmp4 => ['buffer_t', 'buffer_t'] => 'int'; my $str1 = "test"; my $str2 = "test2"; is !!memcmp4($str1, $str2), 1; is memcmp4($str1, $str1), 0; PointerSizeBuffer.pm100644001750001750 504013065045605 23577 0ustar00ollisgollisg000000000000FFI-Platypus-0.47/lib/FFI/Platypus/Typepackage FFI::Platypus::Type::PointerSizeBuffer; use strict; use warnings; use FFI::Platypus; use FFI::Platypus::API qw( arguments_set_pointer arguments_set_uint32 arguments_set_uint64 ); use FFI::Platypus::Buffer qw( scalar_to_buffer ); use FFI::Platypus::Buffer qw( buffer_to_scalar ); # ABSTRACT: Convert string scalar to a buffer as a pointer / size_t combination our $VERSION = '0.47'; # VERSION my @stack; *arguments_set_size_t = FFI::Platypus->new->sizeof('size_t') == 4 ? \&arguments_set_uint32 : \&arguments_set_uint64; sub perl_to_native { my($pointer, $size) = scalar_to_buffer($_[0]); push @stack, [ $pointer, $size ]; arguments_set_pointer $_[1], $pointer; arguments_set_size_t($_[1]+1, $size); } sub perl_to_native_post { my($pointer, $size) = @{ pop @stack }; $_[0] = buffer_to_scalar($pointer, $size); } sub ffi_custom_type_api_1 { { native_type => 'opaque', perl_to_native => \&perl_to_native, perl_to_native_post => \&perl_to_native_post, argument_count => 2, } } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Type::PointerSizeBuffer - Convert string scalar to a buffer as a pointer / size_t combination =head1 VERSION version 0.47 =head1 SYNOPSIS In your C code: void function_with_buffer(void *pointer, size_t size) { ... } In your Platypus::FFI code: use FFI::Platypus; my $ffi = FFI::Platypus->new; $ffi->load_custom_type('::PointerSizeBuffer' => 'buffer'); $ffi->attach(function_with_buffer => ['buffer'] => 'void'); my $string = "content of buffer"; function_with_buffer($string); =head1 DESCRIPTION A common pattern in C code is to pass in a region of memory as a buffer, consisting of a pointer and a size of the memory region. In Perl, string scalars also point to a contiguous series of bytes that has a size, so when interfacing with C libraries it is handy to be able to pass in a string scalar as a pointer / size buffer pair. =head1 SEE ALSO =over 4 =item L Main Platypus documentation. =item L Platypus types documentation. =back =head1 AUTHOR Author: Graham Ollis Eplicease@cpan.orgE Contributors: Bakkiaraj Murugesan (bakkiaraj) Dylan Cali (calid) pipcet Zaki Mughal (zmughal) Fitz Elliott (felliott) Vickenty Fesunov (vyf) Gregor Herrmann (gregoa) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Graham Ollis. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut